From 8b3346c8d55301c9906433275e43c49605ca9ca2 Mon Sep 17 00:00:00 2001 From: Alexander Esgen Date: Wed, 6 Aug 2025 18:37:51 +0200 Subject: [PATCH 01/43] Modify PerasCertDB (and to some extent, ChainDB) to allow snapshot of PerasCerts Conflicts: ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/API.hs ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs --- .../Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs index 8b8a33c342..34380963f3 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs @@ -261,6 +261,8 @@ data PerasVolatileCertState blk = PerasVolatileCertState -- ^ The weight of boosted blocks w.r.t. the certificates currently in the db. , pvcsCertsByTicket :: !(Map PerasCertTicketNo (ValidatedPerasCert blk)) -- ^ The certificates by 'PerasCertTicketNo'. + -- + -- INVARIANT: In sync with 'pvcsCerts'. , pvcsLastTicketNo :: !PerasCertTicketNo -- ^ The most recent 'PerasCertTicketNo' (or 'zeroPerasCertTicketNo' -- otherwise). From 5657065f3105b906aae1081bf0d55b77d02fe939 Mon Sep 17 00:00:00 2001 From: Thomas BAGREL Date: Wed, 6 Aug 2025 11:17:03 +0200 Subject: [PATCH 02/43] Replace hardcoded miniprotocol parameters by default ones in unstable-diffusion-testlib --- .../Test/ThreadNet/Network.hs | 10 ++-------- 1 file changed, 2 insertions(+), 8 deletions(-) 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 6df036c539..847659c2ad 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 @@ -123,8 +123,8 @@ import Ouroboros.Network.NodeToNode ( ConnectionId (..) , ExpandedInitiatorContext (..) , IsBigLedgerPeer (..) - , MiniProtocolParameters (..) , ResponderContext (..) + , defaultMiniProtocolParameters ) import Ouroboros.Network.PeerSelection.Governor ( makePublicPeerSelectionStateVar @@ -1056,13 +1056,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 From b12d4de7b6cffeeab5c581e6cbe4c004a21d11a0 Mon Sep 17 00:00:00 2001 From: Thomas BAGREL Date: Wed, 6 Aug 2025 18:30:13 +0200 Subject: [PATCH 03/43] Introduce the (generic) ObjectDiffusion protocol, ObjectPool, and the associated smoke tests Conflicts: cabal.project --- cabal.project | 13 +- ouroboros-consensus/ouroboros-consensus.cabal | 4 + .../MiniProtocol/ObjectDiffusion/Inbound.hs | 461 ++++++++++++++++++ .../ObjectDiffusion/ObjectPool/API.hs | 38 ++ .../MiniProtocol/ObjectDiffusion/Outbound.hs | 252 ++++++++++ .../test/consensus-test/Main.hs | 2 + .../MiniProtocol/ObjectDiffusion/Smoke.hs | 333 +++++++++++++ 7 files changed, 1100 insertions(+), 3 deletions(-) create mode 100644 ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Inbound.hs create mode 100644 ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/API.hs create mode 100644 ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Outbound.hs create mode 100644 ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/Smoke.hs diff --git a/cabal.project b/cabal.project index 9c97a6c5ba..b23db4a785 100644 --- a/cabal.project +++ b/cabal.project @@ -50,6 +50,12 @@ if impl (ghc >= 9.10) -- https://github.com/phadej/regression-simple/pull/14 , regression-simple:base +allow-newer: + -- https://github.com/phadej/vec/issues/121 + , ral:QuickCheck + , fin:QuickCheck + , bin:QuickCheck + source-repository-package type: git location: https://github.com/IntersectMBO/cardano-ledger @@ -80,12 +86,13 @@ source-repository-package eras/byron/ledger/impl eras/byron/crypto --- Backported version of https://github.com/IntersectMBO/ouroboros-network/pull/5161 source-repository-package type: git location: https://github.com/IntersectMBO/ouroboros-network - tag: 1385b53cefb81e79553b6b0252537455833ea9c4 - --sha256: sha256-zZ7WsMfRs1fG16bmvI5vIh4fhQ8RGyEvYGLSWlrxpg0= + tag: c2e936f454a0026b9a854e5f230714de81b9965c + --sha256: sha256-139VtT1VJkBqIcqf+vak7h4Fh+Z748dHoHwaCCpKOy4= subdir: + ouroboros-network + ouroboros-network-protocols ouroboros-network-api ouroboros-network diff --git a/ouroboros-consensus/ouroboros-consensus.cabal b/ouroboros-consensus/ouroboros-consensus.cabal index 5f2cd98720..d5e65f2b72 100644 --- a/ouroboros-consensus/ouroboros-consensus.cabal +++ b/ouroboros-consensus/ouroboros-consensus.cabal @@ -191,6 +191,9 @@ 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.ObjectPool.API + Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Outbound Ouroboros.Consensus.Node.GsmState Ouroboros.Consensus.Node.InitStorage Ouroboros.Consensus.Node.NetworkProtocolVersion @@ -664,6 +667,7 @@ test-suite consensus-test Test.Consensus.MiniProtocol.ChainSync.CSJ Test.Consensus.MiniProtocol.ChainSync.Client Test.Consensus.MiniProtocol.LocalStateQuery.Server + Test.Consensus.MiniProtocol.ObjectDiffusion.Smoke Test.Consensus.Peras.WeightSnapshot Test.Consensus.Util.MonadSTM.NormalForm Test.Consensus.Util.Versioned 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..b6ad524e42 --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Inbound.hs @@ -0,0 +1,461 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE KindSignatures #-} +{-# 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.ObjectPool.API +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 + | -- | Inbound received 'MsgDone' + TraceObjectInboundTerminated + | TraceObjectInboundCanRequestMoreObjects Int + | TraceObjectInboundCannotRequestMoreObjects Int + 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 -> + ObjectDiffusionInboundPipelined objectId object m () +objectDiffusionInbound tracer (maxFifoLength, maxNumIdsToReq, maxNumObjectsToReq) ObjectPoolWriter{..} _version = + 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 -> 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)) + 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 <- 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 + -- Our result if the outbound peer terminates the protocol + (traceWith tracer TraceObjectInboundTerminated) + ( \neCollectedIds -> + 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 + } + ) + +------------------------------------------------------------------------------- +-- 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/ObjectPool/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/API.hs new file mode 100644 index 0000000000..0d74a6d94a --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/API.hs @@ -0,0 +1,38 @@ +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. + -- + -- TODO: This signature assume that we have all the IDs and ticketNos in + -- memory, but not the actual objects. This might change if IDs must be loaded + -- from disk too. + } + +-- | 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 :: 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/Outbound.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Outbound.hs new file mode 100644 index 0000000000..37b7e66748 --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Outbound.hs @@ -0,0 +1,252 @@ +{-# 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.ControlMessage + ( ControlMessage + , ControlMessageSTM + , timeoutWithControlMessage + ) +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] + | TraceControlMessage ControlMessage + 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 -> + ControlMessageSTM m -> + ObjectDiffusionOutbound objectId object m () +objectDiffusionOutbound tracer maxFifoLength ObjectPoolReader{..} _version controlMessageSTM = + 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 + } + + 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 + + mbNewContent <- timeoutWithControlMessage controlMessageSTM $ + do + newObjectsWithTicketNos <- + oprObjectsAfter + lastTicketNo + (fromIntegral numIdsToReq) + check (not $ null newObjectsWithTicketNos) + pure newObjectsWithTicketNos + + case mbNewContent of + Nothing -> pure (SendMsgDone ()) + Just newContent -> do + 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/test/consensus-test/Main.hs b/ouroboros-consensus/test/consensus-test/Main.hs index beddd1f7d2..439d7b3043 100644 --- a/ouroboros-consensus/test/consensus-test/Main.hs +++ b/ouroboros-consensus/test/consensus-test/Main.hs @@ -16,6 +16,7 @@ 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.Smoke (tests) import qualified Test.Consensus.Peras.WeightSnapshot (tests) import qualified Test.Consensus.Util.MonadSTM.NormalForm (tests) import qualified Test.Consensus.Util.Versioned (tests) @@ -37,6 +38,7 @@ 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.LocalStateQuery.Server.tests , testGroup "Mempool" 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..e751559939 --- /dev/null +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/Smoke.hs @@ -0,0 +1,333 @@ +{-# 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.ObjectPool.API + ( ObjectPoolReader (..) + , ObjectPoolWriter (..) + ) +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Outbound (objectDiffusionOutbound) +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 + , objectDiffusionInboundClientPeerPipelined + , objectDiffusionInboundServerPeerPipelined + ) +import Ouroboros.Network.Protocol.ObjectDiffusion.Outbound + ( ObjectDiffusionOutbound + , objectDiffusionOutboundClientPeer + , objectDiffusionOutboundServerPeer + ) +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 (client inbound, server outbound)" + prop_smoke_init_inbound + , testProperty + "ObjectDiffusion smoke test with mock objects (client outbound, server inbound)" + prop_smoke_init_outbound + ] + +{------------------------------------------------------------------------------- + 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 <- atomically $ 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_init_inbound :: ProtocolConstants -> ListWithUniqueIds SmokeObject idTy -> Property +prop_smoke_init_inbound 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 + (objectDiffusionOutboundServerPeer outbound) + >> pure () + + runInboundPeer inbound inboundChannel tracer = + runPipelinedPeer + ((\x -> "Inbound (Client): " ++ show x) `contramap` tracer) + codecObjectDiffusionId + inboundChannel + (objectDiffusionInboundClientPeerPipelined inbound) + >> pure () + +prop_smoke_init_outbound :: + ProtocolConstants -> ListWithUniqueIds SmokeObject SmokeObjectId -> Property +prop_smoke_init_outbound protocolConstants (ListWithUniqueIds objects) = + prop_smoke_object_diffusion + protocolConstants + objects + runOutboundPeer + runInboundPeer + (mkMockPoolInterfaces objects) + where + runOutboundPeer outbound outboundChannel tracer = + runPeer + ((\x -> "Outbound (Client): " ++ show x) `contramap` tracer) + codecObjectDiffusionId + outboundChannel + (objectDiffusionOutboundClientPeer outbound) + >> pure () + + runInboundPeer inbound inboundChannel tracer = + runPipelinedPeer + ((\x -> "Inbound (Server): " ++ show x) `contramap` tracer) + codecObjectDiffusionId + inboundChannel + (objectDiffusionInboundServerPeerPipelined 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 initAgency objectId object)) -> + (Tracer m String) -> + m () + ) -> + ( forall m. + IOLike m => + ObjectDiffusionInboundPipelined objectId object m () -> + (Channel m (AnyMessage (ObjectDiffusion initAgency 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 + inbound = + objectDiffusionInbound + tracer + ( maxFifoSize + , maxIdsToReq + , maxObjectsToReq + ) + inboundPoolWriter + nodeToNodeVersion + + outbound = + objectDiffusionOutbound + tracer + maxFifoSize + outboundPoolReader + nodeToNodeVersion + (readTVar controlMessage) + + 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 From a840ac58c4a24536501646c04f80c9c2ee10813b Mon Sep 17 00:00:00 2001 From: Thomas BAGREL Date: Wed, 6 Aug 2025 18:45:49 +0200 Subject: [PATCH 04/43] Introduce the PerasCertDiffusion protocol (instance of ObjectDiffusion), and the associated smoke test --- ouroboros-consensus/ouroboros-consensus.cabal | 3 + .../ObjectDiffusion/ObjectPool/PerasCert.hs | 76 +++++++++++ .../MiniProtocol/ObjectDiffusion/PerasCert.hs | 36 +++++ .../test/consensus-test/Main.hs | 2 + .../ObjectDiffusion/PerasCert/Smoke.hs | 126 ++++++++++++++++++ 5 files changed, 243 insertions(+) create mode 100644 ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasCert.hs create mode 100644 ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/PerasCert.hs create mode 100644 ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasCert/Smoke.hs diff --git a/ouroboros-consensus/ouroboros-consensus.cabal b/ouroboros-consensus/ouroboros-consensus.cabal index d5e65f2b72..091aeea1e9 100644 --- a/ouroboros-consensus/ouroboros-consensus.cabal +++ b/ouroboros-consensus/ouroboros-consensus.cabal @@ -193,7 +193,9 @@ library Ouroboros.Consensus.MiniProtocol.LocalTxSubmission.Server Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API + Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.PerasCert Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Outbound + Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.PerasCert Ouroboros.Consensus.Node.GsmState Ouroboros.Consensus.Node.InitStorage Ouroboros.Consensus.Node.NetworkProtocolVersion @@ -667,6 +669,7 @@ 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 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..2c734cff28 --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasCert.hs @@ -0,0 +1,76 @@ +-- | 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 Ouroboros.Consensus.Block +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 = perasCertRound + , oprZeroTicketNo = PerasCertDB.zeroPerasCertTicketNo + , oprObjectsAfter = \lastKnown limit -> do + certSnapshot <- getCertSnapshot + pure $ + take (fromIntegral limit) $ + [ (ticketNo, perasCertRound cert, pure 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, MonadSTM m) => + PerasCertDB m blk -> ObjectPoolWriter PerasRoundNo (PerasCert blk) m +makePerasCertPoolWriterFromCertDB perasCertDB = + ObjectPoolWriter + { opwObjectId = perasCertRound + , opwAddObjects = + mapM_ $ PerasCertDB.addCert perasCertDB + , opwHasObject = do + certSnapshot <- atomically $ 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, MonadSTM m) => + ChainDB m blk -> ObjectPoolWriter PerasRoundNo (PerasCert blk) m +makePerasCertPoolWriterFromChainDB chainDB = + ObjectPoolWriter + { opwObjectId = perasCertRound + , opwAddObjects = + mapM_ $ ChainDB.addPerasCertAsync chainDB + , opwHasObject = do + certSnapshot <- atomically $ ChainDB.getPerasCertSnapshot chainDB + pure $ PerasCertDB.containsCert certSnapshot + } 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..004c38525b --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/PerasCert.hs @@ -0,0 +1,36 @@ +-- | 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 + ) where + +import Ouroboros.Consensus.Block +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound +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) + +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 diff --git a/ouroboros-consensus/test/consensus-test/Main.hs b/ouroboros-consensus/test/consensus-test/Main.hs index 439d7b3043..79d681213a 100644 --- a/ouroboros-consensus/test/consensus-test/Main.hs +++ b/ouroboros-consensus/test/consensus-test/Main.hs @@ -16,6 +16,7 @@ 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) @@ -39,6 +40,7 @@ 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" 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..a04d6b97fa --- /dev/null +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasCert/Smoke.hs @@ -0,0 +1,126 @@ +{-# 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.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 +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 + ( objectDiffusionInboundServerPeerPipelined + ) +import Ouroboros.Network.Protocol.ObjectDiffusion.Outbound (objectDiffusionOutboundClientPeer) +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 + ] + +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 + +newCertDB :: (IOLike m, StandardHash blk) => [PerasCert blk] -> m (PerasCertDB m blk) +newCertDB certs = do + db <- PerasCertDB.openDB (PerasCertDB.PerasCertDbArgs @Identity nullTracer) + mapM_ + ( \cert -> do + result <- PerasCertDB.addCert db cert + 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 + (objectDiffusionOutboundClientPeer outbound) + >> pure () + runInboundPeer inbound inboundChannel tracer = + runPipelinedPeer + ((\x -> "Inbound (Server): " ++ show x) `contramap` tracer) + codecObjectDiffusionId + inboundChannel + (objectDiffusionInboundServerPeerPipelined inbound) + >> pure () + mkPoolInterfaces :: + forall m. + IOLike m => + m + ( ObjectPoolReader PerasRoundNo (PerasCert TestBlock) PerasCertTicketNo m + , ObjectPoolWriter PerasRoundNo (PerasCert TestBlock) m + , m [PerasCert TestBlock] + ) + mkPoolInterfaces = do + outboundPool <- newCertDB certs + inboundPool <- newCertDB [] + + let outboundPoolReader = makePerasCertPoolReaderFromCertDB outboundPool + inboundPoolWriter = makePerasCertPoolWriterFromCertDB inboundPool + getAllInboundPoolContent = do + snap <- atomically $ PerasCertDB.getCertSnapshot inboundPool + let rawContent = PerasCertDB.getCertsAfter snap (PerasCertDB.zeroPerasCertTicketNo) + pure $ fst <$> rawContent + + return (outboundPoolReader, inboundPoolWriter, getAllInboundPoolContent) From 5d9e9b2a06103dc2f92eace31c0bbfbd2389ebd7 Mon Sep 17 00:00:00 2001 From: Thomas BAGREL Date: Wed, 6 Aug 2025 18:46:37 +0200 Subject: [PATCH 05/43] Wire-in the PerasCertDiffusion protocol in NodeToNode Conflicts: ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/Tracers.hs ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasCert.hs ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasCert/Smoke.hs ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/Smoke.hs --- .../Ouroboros/Consensus/Network/NodeToNode.hs | 33 +++++++++++ .../Ouroboros/Consensus/Node/Tracers.hs | 11 ++++ .../MiniProtocol/ObjectDiffusion/Inbound.hs | 2 +- .../ObjectDiffusion/ObjectPool/API.hs | 31 ++++++++-- .../ObjectDiffusion/ObjectPool/PerasCert.hs | 58 ++++++++++++++----- .../ObjectDiffusion/PerasCert/Smoke.hs | 14 ++++- .../MiniProtocol/ObjectDiffusion/Smoke.hs | 2 +- 7 files changed, 128 insertions(+), 23 deletions(-) diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs index bc66cf78d6..b413bb915e 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 @@ -68,6 +68,10 @@ 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.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 @@ -197,6 +201,19 @@ data Handlers m addr blk = Handlers NodeToNodeVersion -> ConnectionId addr -> TxSubmissionServerPipelined (GenTxId blk) (GenTx blk) m () + , hPerasCertDiffusionInbound :: + NodeToNodeVersion -> + ConnectionId addr -> + PerasCertDiffusionInboundPipelined blk m () + -- ^ TODO: We should pass 'hPerasCertDiffusionInbound' to the network + -- layer, as per https://github.com/tweag/cardano-peras/issues/78 + , hPerasCertDiffusionOutbound :: + NodeToNodeVersion -> + ControlMessageSTM m -> + ConnectionId addr -> + PerasCertDiffusionOutbound blk m () + -- ^ TODO: We should pass 'hPerasCertDiffusionOutbound' to the network + -- layer, as per https://github.com/tweag/cardano-peras/issues/78 , hKeepAliveClient :: NodeToNodeVersion -> ControlMessageSTM m -> @@ -293,6 +310,22 @@ mkHandlers (mapTxSubmissionMempoolReader txForgetValidated $ getMempoolReader getMempool) (getMempoolWriter getMempool) version + , hPerasCertDiffusionInbound = \version 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 $ getChainDB) + version + , hPerasCertDiffusionOutbound = \version controlMessageSTM peer -> + objectDiffusionOutbound + (contramap (TraceLabelPeer peer) (Node.perasCertDiffusionOutboundTracer tracers)) + (perasCertDiffusionMaxFifoLength miniProtocolParameters) + (makePerasCertPoolReaderFromChainDB $ getChainDB) + version + controlMessageSTM , hKeepAliveClient = \_version -> keepAliveClient (Node.keepAliveClientTracer tracers) keepAliveRng , hKeepAliveServer = \_version _peer -> keepAliveServer , hPeerSharingClient = \_version controlMessageSTM _peer -> peerSharingClient controlMessageSTM 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 3d025ea91d..0509743d0a 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.Consensus.Protocol.Praos.AgentClient ( KESAgentClientTrace (..) @@ -91,6 +92,10 @@ data Tracers' remotePeer localPeer blk f = Tracers f (TraceLabelPeer remotePeer (CSJumping.TraceEventCsj remotePeer blk)) , dbfTracer :: f (CSJumping.TraceEventDbf remotePeer) , kesAgentTracer :: f KESAgentClientTrace + , perasCertDiffusionInboundTracer :: + f (TraceLabelPeer remotePeer (TracePerasCertDiffusionInbound blk)) + , perasCertDiffusionOutboundTracer :: + f (TraceLabelPeer remotePeer (TracePerasCertDiffusionOutbound blk)) } instance @@ -120,6 +125,8 @@ instance , csjTracer = f csjTracer , dbfTracer = f dbfTracer , kesAgentTracer = f kesAgentTracer + , perasCertDiffusionInboundTracer = f perasCertDiffusionInboundTracer + , perasCertDiffusionOutboundTracer = f perasCertDiffusionOutboundTracer } where f :: @@ -157,6 +164,8 @@ nullTracers = , csjTracer = nullTracer , dbfTracer = nullTracer , kesAgentTracer = nullTracer + , perasCertDiffusionInboundTracer = nullTracer + , perasCertDiffusionOutboundTracer = nullTracer } showTracers :: @@ -196,6 +205,8 @@ showTracers tr = , csjTracer = showTracing tr , dbfTracer = showTracing tr , kesAgentTracer = showTracing tr + , perasCertDiffusionInboundTracer = showTracing tr + , perasCertDiffusionOutboundTracer = showTracing tr } {------------------------------------------------------------------------------- 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 index b6ad524e42..587036d87d 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Inbound.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Inbound.hs @@ -287,7 +287,7 @@ objectDiffusionInbound tracer (maxFifoLength, maxNumIdsToReq, maxNumObjectsToReq -- objectIds that we already have in the pool and thus don't need to -- request. let st' = st{numIdsInFlight = numIdsInFlight st - numIdsRequested} - poolHasObject <- opwHasObject + poolHasObject <- atomically $ opwHasObject continueWithStateM (go n) (preAcknowledge st' poolHasObject collectedIds) 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 index 0d74a6d94a..2f949d8b3b 100644 --- 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 @@ -1,3 +1,28 @@ +-- | 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 (..) @@ -19,10 +44,6 @@ data ObjectPoolReader objectId object ticketNo m -- 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. - -- - -- TODO: This signature assume that we have all the IDs and ticketNos in - -- memory, but not the actual objects. This might change if IDs must be loaded - -- from disk too. } -- | Interface used by the inbound side of object diffusion when receiving @@ -33,6 +54,6 @@ data ObjectPoolWriter objectId object m -- ^ Return the id of the specified object , opwAddObjects :: [object] -> m () -- ^ Add a batch of objects to the objectPool. - , opwHasObject :: m (objectId -> Bool) + , 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 index 2c734cff28..1e9e966341 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasCert.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasCert.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE StandaloneDeriving #-} + -- | Instantiate 'ObjectPoolReader' and 'ObjectPoolWriter' using Peras -- certificates from the 'PerasCertDB' (or the 'ChainDB' which is wrapping the -- 'PerasCertDB'). @@ -8,6 +11,8 @@ module Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.PerasCert , makePerasCertPoolWriterFromChainDB ) where +import qualified Data.Map as Map +import GHC.Exception (throw) import Ouroboros.Consensus.Block import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API import Ouroboros.Consensus.Storage.ChainDB.API (ChainDB) @@ -26,14 +31,16 @@ makePerasCertPoolReaderFromSnapshot :: ObjectPoolReader PerasRoundNo (PerasCert blk) PerasCertTicketNo m makePerasCertPoolReaderFromSnapshot getCertSnapshot = ObjectPoolReader - { oprObjectId = perasCertRound + { oprObjectId = getPerasCertRound , oprZeroTicketNo = PerasCertDB.zeroPerasCertTicketNo , oprObjectsAfter = \lastKnown limit -> do certSnapshot <- getCertSnapshot pure $ take (fromIntegral limit) $ - [ (ticketNo, perasCertRound cert, pure cert) - | (cert, ticketNo) <- PerasCertDB.getCertsAfter certSnapshot lastKnown + [ (ticketNo, getPerasCertRound cert, pure (getPerasCert cert)) + | (ticketNo, cert) <- + Map.toAscList $ + PerasCertDB.getCertsAfter certSnapshot lastKnown ] } @@ -44,15 +51,16 @@ makePerasCertPoolReaderFromCertDB perasCertDB = makePerasCertPoolReaderFromSnapshot (PerasCertDB.getCertSnapshot perasCertDB) makePerasCertPoolWriterFromCertDB :: - (StandardHash blk, MonadSTM m) => + (StandardHash blk, IOLike m) => PerasCertDB m blk -> ObjectPoolWriter PerasRoundNo (PerasCert blk) m makePerasCertPoolWriterFromCertDB perasCertDB = ObjectPoolWriter - { opwObjectId = perasCertRound - , opwAddObjects = - mapM_ $ PerasCertDB.addCert perasCertDB + { opwObjectId = getPerasCertRound + , opwAddObjects = \certs -> do + validatePerasCerts certs + >>= mapM_ (PerasCertDB.addCert perasCertDB) , opwHasObject = do - certSnapshot <- atomically $ PerasCertDB.getCertSnapshot perasCertDB + certSnapshot <- PerasCertDB.getCertSnapshot perasCertDB pure $ PerasCertDB.containsCert certSnapshot } @@ -63,14 +71,38 @@ makePerasCertPoolReaderFromChainDB chainDB = makePerasCertPoolReaderFromSnapshot (ChainDB.getPerasCertSnapshot chainDB) makePerasCertPoolWriterFromChainDB :: - (StandardHash blk, MonadSTM m) => + (StandardHash blk, IOLike m) => ChainDB m blk -> ObjectPoolWriter PerasRoundNo (PerasCert blk) m makePerasCertPoolWriterFromChainDB chainDB = ObjectPoolWriter - { opwObjectId = perasCertRound - , opwAddObjects = - mapM_ $ ChainDB.addPerasCertAsync chainDB + { opwObjectId = getPerasCertRound + , opwAddObjects = \certs -> do + validatePerasCerts certs + >>= mapM_ (ChainDB.addPerasCertAsync chainDB) , opwHasObject = do - certSnapshot <- atomically $ ChainDB.getPerasCertSnapshot chainDB + 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 + -- see https://github.com/tweag/cardano-peras/issues/73 + -- see https://github.com/tweag/cardano-peras/issues/120 + case traverse (validatePerasCert perasCfg) certs of + Left validationErr -> throw (PerasCertValidationError validationErr) + Right validatedCerts -> return validatedCerts diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasCert/Smoke.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasCert/Smoke.hs index a04d6b97fa..00649475ab 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasCert/Smoke.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasCert/Smoke.hs @@ -12,6 +12,7 @@ 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 qualified Data.Map as Map import Network.TypedProtocol.Driver.Simple (runPeer, runPipelinedPeer) import Ouroboros.Consensus.Block.SupportsPeras import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API @@ -78,7 +79,12 @@ newCertDB certs = do db <- PerasCertDB.openDB (PerasCertDB.PerasCertDbArgs @Identity nullTracer) mapM_ ( \cert -> do - result <- PerasCertDB.addCert db cert + let validatedCert = + ValidatedPerasCert + { vpcCert = cert + , vpcCertBoost = boostPerCert + } + result <- PerasCertDB.addCert db validatedCert case result of AddedPerasCertToDB -> pure () PerasCertAlreadyInDB -> throwIO (userError "Expected AddedPerasCertToDB, but cert was already in DB") @@ -120,7 +126,9 @@ prop_smoke protocolConstants (ListWithUniqueIds certs) = inboundPoolWriter = makePerasCertPoolWriterFromCertDB inboundPool getAllInboundPoolContent = do snap <- atomically $ PerasCertDB.getCertSnapshot inboundPool - let rawContent = PerasCertDB.getCertsAfter snap (PerasCertDB.zeroPerasCertTicketNo) - pure $ fst <$> rawContent + let rawContent = + Map.toAscList $ + PerasCertDB.getCertsAfter snap (PerasCertDB.zeroPerasCertTicketNo) + pure $ getPerasCert . snd <$> 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 index e751559939..d681c12016 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/Smoke.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/Smoke.hs @@ -139,7 +139,7 @@ makeObjectPoolWriter (SmokeObjectPool poolContentTvar) = atomically $ modifyTVar poolContentTvar (++ objects) return () , opwHasObject = do - poolContent <- atomically $ readTVar poolContentTvar + poolContent <- readTVar poolContentTvar pure $ \objectId -> any (\obj -> getSmokeObjectId obj == objectId) poolContent } From 37e5bb89527067776a1d45b2bcc70eb8f617431a Mon Sep 17 00:00:00 2001 From: Thomas BAGREL Date: Tue, 2 Sep 2025 16:57:35 +0200 Subject: [PATCH 06/43] Add codec for PerasCert and PerasCertDiffusion Conflicts: ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs --- .../Ouroboros/Consensus/Network/NodeToNode.hs | 51 +++++++++++-------- .../Test/ThreadNet/Network.hs | 5 ++ .../MiniProtocol/ObjectDiffusion/PerasCert.hs | 5 ++ .../Ouroboros/Consensus/Node/Serialisation.hs | 40 +++++++++++++-- 4 files changed, 76 insertions(+), 25 deletions(-) diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs index b413bb915e..35fdfe0b49 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 @@ -85,10 +85,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 @@ -128,6 +124,10 @@ 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 + ( codecObjectDiffusion + , codecObjectDiffusionId + ) import Ouroboros.Network.Protocol.PeerSharing.Client ( PeerSharingClient , peerSharingClientPeer @@ -337,7 +337,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 @@ -345,6 +345,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 } @@ -372,49 +373,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 @@ -434,6 +439,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 = @@ -443,6 +449,7 @@ identityCodecs = , cBlockFetchCodec = codecBlockFetchId , cBlockFetchCodecSerialised = codecBlockFetchId , cTxSubmission2Codec = codecTxSubmission2Id + , cPerasCertDiffusionCodec = codecObjectDiffusionId , cKeepAliveCodec = codecKeepAliveId , cPeerSharingCodec = codecPeerSharingId } @@ -627,7 +634,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 @@ -642,7 +649,7 @@ 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) -> + (NodeToNodeVersion -> Codecs blk addrNTN e m bCS bCS bBF bBF bTX bPCD bKA bPS) -> ByteLimits bCS bBF bTX bKA bPS -> -- Chain-Sync timeouts for chain-sync client (using `Header blk`) as well as -- the server (`SerialisedHeader blk`). diff --git a/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs b/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs index 847659c2ad..29ac1621ea 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 @@ -1182,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 = @@ -1201,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 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 index 004c38525b..f646fa27b4 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/PerasCert.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/PerasCert.hs @@ -7,6 +7,7 @@ module Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.PerasCert , PerasCertPoolWriter , PerasCertDiffusionInboundPipelined , PerasCertDiffusionOutbound + , PerasCertDiffusion ) where import Ouroboros.Consensus.Block @@ -16,6 +17,7 @@ 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, OutboundAgency) type TracePerasCertDiffusionInbound blk = TraceObjectDiffusionInbound PerasRoundNo (PerasCert blk) @@ -34,3 +36,6 @@ type PerasCertDiffusionInboundPipelined blk m a = type PerasCertDiffusionOutbound blk m a = ObjectDiffusionOutbound PerasRoundNo (PerasCert blk) m a + +type PerasCertDiffusion blk = + ObjectDiffusion OutboundAgency PerasRoundNo (PerasCert blk) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Node/Serialisation.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Node/Serialisation.hs index 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) From 50def7b8538d541a7988498c8cfd5e93a9547794 Mon Sep 17 00:00:00 2001 From: Alexander Esgen Date: Thu, 4 Sep 2025 19:27:54 +0200 Subject: [PATCH 07/43] Integrate `NodeToNodeV_16` --- .../Ouroboros/Consensus/Cardano/Node.hs | 1 + .../Ouroboros/Consensus/Shelley/Ledger/NetworkProtocolVersion.hs | 1 + 2 files changed, 2 insertions(+) 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 52a7e4f910..98093f86c5 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 @@ -430,6 +430,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/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 From 8bf583d91162bba738015990ff5bb3cc8f8234b5 Mon Sep 17 00:00:00 2001 From: Alexander Esgen Date: Wed, 3 Sep 2025 20:03:16 +0200 Subject: [PATCH 08/43] Peras: add a few `ShowProxy` instances --- .../Ouroboros/Consensus/Block/SupportsPeras.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs index bdfd9c826c..9a5b9c8ab7 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs @@ -144,6 +144,9 @@ instance StandardHash blk => BlockSupportsPeras blk where instance ShowProxy blk => ShowProxy (PerasCert blk) where showProxy _ = "PerasCert " <> showProxy (Proxy @blk) +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 From 4b4f5399a661414795f37d7839bfdd51293c860d Mon Sep 17 00:00:00 2001 From: Alexander Esgen Date: Thu, 4 Sep 2025 20:06:35 +0200 Subject: [PATCH 09/43] Adapt to removal of `initAgency` --- .../Consensus/MiniProtocol/ObjectDiffusion/PerasCert.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) 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 index f646fa27b4..ba0ba934a2 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/PerasCert.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/PerasCert.hs @@ -17,7 +17,7 @@ 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, OutboundAgency) +import Ouroboros.Network.Protocol.ObjectDiffusion.Type (ObjectDiffusion) type TracePerasCertDiffusionInbound blk = TraceObjectDiffusionInbound PerasRoundNo (PerasCert blk) @@ -38,4 +38,4 @@ type PerasCertDiffusionOutbound blk m a = ObjectDiffusionOutbound PerasRoundNo (PerasCert blk) m a type PerasCertDiffusion blk = - ObjectDiffusion OutboundAgency PerasRoundNo (PerasCert blk) + ObjectDiffusion PerasRoundNo (PerasCert blk) From bc75e378a94aa251ac3622df639e3b62787733ed Mon Sep 17 00:00:00 2001 From: Alexander Esgen Date: Thu, 4 Sep 2025 20:32:46 +0200 Subject: [PATCH 10/43] Adapt to changed agency of `MsgDone` The diff is actually quite small; it is recommended to review with sth like https://github.com/Wilfred/difftastic --- .../MiniProtocol/ObjectDiffusion/Inbound.hs | 578 +++++++++--------- .../MiniProtocol/ObjectDiffusion/Outbound.hs | 68 +-- 2 files changed, 331 insertions(+), 315 deletions(-) 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 index 587036d87d..bba2d07cb0 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Inbound.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Inbound.hs @@ -7,6 +7,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -38,6 +39,7 @@ import GHC.Generics (Generic) import Network.TypedProtocol.Core (N (Z), Nat (..), natToInt) import NoThunks.Class (NoThunks (..), unsafeNoThunks) import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API +import Ouroboros.Network.ControlMessage import Ouroboros.Network.NodeToNode.Version (NodeToNodeVersion) import Ouroboros.Network.Protocol.ObjectDiffusion.Inbound import Ouroboros.Network.Protocol.ObjectDiffusion.Type @@ -55,8 +57,9 @@ data TraceObjectDiffusionInbound objectId object TraceObjectDiffusionCollected Int | -- | Just processed object pass/fail breakdown. TraceObjectDiffusionProcessed NumObjectsProcessed - | -- | Inbound received 'MsgDone' - TraceObjectInboundTerminated + | -- | Received a 'ControlMessage' from the outbound peer governor, and about + -- to act on it. + TraceObjectDiffusionControlMessage ControlMessage | TraceObjectInboundCanRequestMoreObjects Int | TraceObjectInboundCannotRequestMoreObjects Int deriving (Eq, Show) @@ -127,291 +130,312 @@ objectDiffusionInbound :: (NumObjectsOutstanding, NumObjectIdsReq, NumObjectsReq) -> ObjectPoolWriter objectId object m -> NodeToNodeVersion -> + ControlMessageSTM m -> ObjectDiffusionInboundPipelined objectId object m () -objectDiffusionInbound tracer (maxFifoLength, maxNumIdsToReq, maxNumObjectsToReq) ObjectPoolWriter{..} _version = - 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 -> 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)) - 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) +objectDiffusionInbound + tracer + (maxFifoLength, maxNumIdsToReq, maxNumObjectsToReq) + ObjectPoolWriter{..} + _version + controlMessageSTM = + 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 - { pendingObjects = pendingObjects'' - , outstandingFifo = outstandingFifo' + { canRequestNext = canRequestNext st <> (Set.fromList notYetObtained) + , 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 - -- Our result if the outbound peer terminates the protocol - (traceWith tracer TraceObjectInboundTerminated) - ( \neCollectedIds -> - collectAndContinueWithState - (goCollect Zero) - st - { numToAckOnNextReq = 0 - , numIdsInFlight = numIdsToRequest - } - (CollectObjectIds numIdsToRequest (NonEmpty.toList neCollectedIds)) + 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)) + 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) ) - - 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)) + $ SendMsgRequestObjectIdsBlocking + (numToAckOnNextReq st) + numIdsToRequest + ( \neCollectedIds -> + collectAndContinueWithState + (goCollect Zero) st - { numIdsInFlight = - numIdsInFlight st - + numIdsToRequest - , numToAckOnNextReq = 0 + { 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) 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 index 37b7e66748..34c90b9836 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Outbound.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Outbound.hs @@ -20,11 +20,6 @@ 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.ControlMessage - ( ControlMessage - , ControlMessageSTM - , timeoutWithControlMessage - ) import Ouroboros.Network.NodeToNode.Version (NodeToNodeVersion) import Ouroboros.Network.Protocol.ObjectDiffusion.Outbound import Ouroboros.Network.Protocol.ObjectDiffusion.Type @@ -41,7 +36,8 @@ data TraceObjectDiffusionOutbound objectId object | -- | The objects to be sent in the response. TraceObjectDiffusionOutboundSendMsgReplyObjects [object] - | TraceControlMessage ControlMessage + | -- | Received 'MsgDone' + TraceObjectDiffusionOutboundTerminated deriving Show data ObjectDiffusionOutboundError @@ -90,9 +86,8 @@ objectDiffusionOutbound :: NumObjectsOutstanding -> ObjectPoolReader objectId object ticketNo m -> NodeToNodeVersion -> - ControlMessageSTM m -> ObjectDiffusionOutbound objectId object m () -objectDiffusionOutbound tracer maxFifoLength ObjectPoolReader{..} _version controlMessageSTM = +objectDiffusionOutbound tracer maxFifoLength ObjectPoolReader{..} _version = ObjectDiffusionOutbound (pure (makeBundle $ OutboundSt Seq.empty oprZeroTicketNo)) where makeBundle :: OutboundSt objectId object ticketNo -> OutboundStIdle objectId object m () @@ -100,6 +95,7 @@ objectDiffusionOutbound tracer maxFifoLength ObjectPoolReader{..} _version contr OutboundStIdle { recvMsgRequestObjectIds = recvMsgRequestObjectIds st , recvMsgRequestObjects = recvMsgRequestObjects st + , recvMsgDone = traceWith tracer TraceObjectDiffusionOutboundTerminated } updateStNewObjects :: @@ -158,36 +154,32 @@ objectDiffusionOutbound tracer maxFifoLength ObjectPoolReader{..} _version contr unless (Seq.null outstandingFifo') $ throwIO ProtocolErrorRequestBlocking - mbNewContent <- timeoutWithControlMessage controlMessageSTM $ - do - newObjectsWithTicketNos <- - oprObjectsAfter - lastTicketNo - (fromIntegral numIdsToReq) - check (not $ null newObjectsWithTicketNos) - pure newObjectsWithTicketNos - - case mbNewContent of - Nothing -> pure (SendMsgDone ()) - Just newContent -> do - 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'') + 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 From 3e23e6c0b2aec5eac4bd99bbd2cdcbeb8723f285 Mon Sep 17 00:00:00 2001 From: Alexander Esgen Date: Wed, 3 Sep 2025 20:03:23 +0200 Subject: [PATCH 11/43] `O.C.Network.NodeToNode`: plumbing for Peras cert diffusion Conflicts: ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs Rebase note: After having to update the ouroboros-network s-r-p, the easiest was to check out some files directly from origin/main-pr/object-diffusion to make things compile. --- cabal.project | 5 +- .../Ouroboros/Consensus/Network/NodeToNode.hs | 118 +++++-- .../Ouroboros/Consensus/Node.hs | 2 + .../Test/ThreadNet/Network.hs | 1 + .../Consensus/Block/SupportsPeras.hs | 3 - .../MiniProtocol/ObjectDiffusion/Inbound.hs | 293 ++++++++---------- .../ObjectDiffusion/PerasCert/Smoke.hs | 8 +- .../MiniProtocol/ObjectDiffusion/Smoke.hs | 53 +--- 8 files changed, 249 insertions(+), 234 deletions(-) diff --git a/cabal.project b/cabal.project index b23db4a785..6f8a8dbfdf 100644 --- a/cabal.project +++ b/cabal.project @@ -86,11 +86,12 @@ source-repository-package eras/byron/ledger/impl eras/byron/crypto +-- Using https://github.com/IntersectMBO/ouroboros-network/tree/peras-staging/pr-5202-v2 source-repository-package type: git location: https://github.com/IntersectMBO/ouroboros-network - tag: c2e936f454a0026b9a854e5f230714de81b9965c - --sha256: sha256-139VtT1VJkBqIcqf+vak7h4Fh+Z748dHoHwaCCpKOy4= + tag: peras-staging/pr-5202-v2 + --sha256: sha256-vEO721Xab0RTVKFQFKal5VCV5y+OUzELo8+7Z8TETJQ= subdir: ouroboros-network ouroboros-network-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 35fdfe0b49..294aace61f 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 @@ -54,6 +54,7 @@ import qualified Data.ByteString.Lazy as BSL import Data.Hashable (Hashable) import Data.Int (Int64) import Data.Map.Strict (Map) +import qualified Data.Set as Set import Data.Void (Void) import qualified Network.Mux as Mux import Network.TypedProtocol.Codec @@ -125,8 +126,16 @@ import Ouroboros.Network.Protocol.KeepAlive.Codec import Ouroboros.Network.Protocol.KeepAlive.Server import Ouroboros.Network.Protocol.KeepAlive.Type import Ouroboros.Network.Protocol.ObjectDiffusion.Codec - ( codecObjectDiffusion + ( 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 @@ -201,19 +210,15 @@ data Handlers m addr blk = Handlers NodeToNodeVersion -> ConnectionId addr -> TxSubmissionServerPipelined (GenTxId blk) (GenTx blk) m () - , hPerasCertDiffusionInbound :: + , hPerasCertDiffusionClient :: NodeToNodeVersion -> + ControlMessageSTM m -> ConnectionId addr -> PerasCertDiffusionInboundPipelined blk m () - -- ^ TODO: We should pass 'hPerasCertDiffusionInbound' to the network - -- layer, as per https://github.com/tweag/cardano-peras/issues/78 - , hPerasCertDiffusionOutbound :: + , hPerasCertDiffusionServer :: NodeToNodeVersion -> - ControlMessageSTM m -> ConnectionId addr -> PerasCertDiffusionOutbound blk m () - -- ^ TODO: We should pass 'hPerasCertDiffusionOutbound' to the network - -- layer, as per https://github.com/tweag/cardano-peras/issues/78 , hKeepAliveClient :: NodeToNodeVersion -> ControlMessageSTM m -> @@ -310,22 +315,22 @@ mkHandlers (mapTxSubmissionMempoolReader txForgetValidated $ getMempoolReader getMempool) (getMempoolWriter getMempool) version - , hPerasCertDiffusionInbound = \version peer -> + , hPerasCertDiffusionClient = \version controlMessageSTM 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 + , 10 -- TODO: see https://github.com/tweag/cardano-peras/issues/97 + , 10 -- TODO: see https://github.com/tweag/cardano-peras/issues/97 ) (makePerasCertPoolWriterFromChainDB $ getChainDB) version - , hPerasCertDiffusionOutbound = \version controlMessageSTM peer -> + controlMessageSTM + , hPerasCertDiffusionServer = \version peer -> objectDiffusionOutbound (contramap (TraceLabelPeer peer) (Node.perasCertDiffusionOutboundTracer tracers)) (perasCertDiffusionMaxFifoLength miniProtocolParameters) (makePerasCertPoolReaderFromChainDB $ getChainDB) version - controlMessageSTM , hKeepAliveClient = \_version -> keepAliveClient (Node.keepAliveClientTracer tracers) keepAliveRng , hKeepAliveServer = \_version _peer -> keepAliveServer , hPeerSharingClient = \_version controlMessageSTM _peer -> peerSharingClient controlMessageSTM @@ -472,6 +477,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))) } @@ -484,6 +490,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 } @@ -504,6 +511,7 @@ nullTracers = , tBlockFetchTracer = nullTracer , tBlockFetchSerialisedTracer = nullTracer , tTxSubmission2Tracer = nullTracer + , tPerasCertDiffusionTracer = nullTracer , tKeepAliveTracer = nullTracer , tPeerSharingTracer = nullTracer } @@ -525,6 +533,7 @@ showTracers tr = , tBlockFetchTracer = showTracing tr , tBlockFetchSerialisedTracer = showTracing tr , tTxSubmission2Tracer = showTracing tr + , tPerasCertDiffusionTracer = showTracing tr , tKeepAliveTracer = showTracing tr , tPeerSharingTracer = showTracing tr } @@ -549,7 +558,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. @@ -565,6 +574,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 @@ -580,7 +593,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 bPS = ByteLimits +data ByteLimits bCS bBF bTX bPCD bKA bPS = ByteLimits { blChainSync :: forall header point tip. ProtocolSizeLimits @@ -596,6 +609,11 @@ data ByteLimits bCS bBF bTX bKA bPS = ByteLimits ProtocolSizeLimits (TxSubmission2 txid tx) bTX + , blPerasCertDiffusion :: + forall blk. + ProtocolSizeLimits + (PerasCertDiffusion blk) + bPCD , blKeepAlive :: ProtocolSizeLimits KeepAlive @@ -607,22 +625,24 @@ data ByteLimits bCS bBF bTX bKA bPS = ByteLimits bPS } -noByteLimits :: ByteLimits bCS bBF bTX bKA bPS +noByteLimits :: ByteLimits bCS bBF bTX bPCD bKA bPS noByteLimits = ByteLimits { blChainSync = byteLimitsChainSync (const 0) , blBlockFetch = byteLimitsBlockFetch (const 0) , blTxSubmission2 = byteLimitsTxSubmission2 (const 0) + , blPerasCertDiffusion = byteLimitsObjectDiffusion (const 0) , blKeepAlive = byteLimitsKeepAlive (const 0) , blPeerSharing = byteLimitsPeerSharing (const 0) } -byteLimits :: ByteLimits ByteString ByteString ByteString ByteString ByteString +byteLimits :: ByteLimits ByteString ByteString ByteString ByteString ByteString ByteString byteLimits = ByteLimits { blChainSync = byteLimitsChainSync size , blBlockFetch = byteLimitsBlockFetch size , blTxSubmission2 = byteLimitsTxSubmission2 size + , blPerasCertDiffusion = byteLimitsObjectDiffusion size , blKeepAlive = byteLimitsKeepAlive size , blPeerSharing = byteLimitsPeerSharing size } @@ -650,7 +670,7 @@ mkApps :: StdGen -> Tracers m addrNTN blk e -> (NodeToNodeVersion -> Codecs blk addrNTN e m bCS bCS bBF bBF bTX bPCD bKA bPS) -> - ByteLimits bCS bBF bTX bKA bPS -> + ByteLimits bCS bBF bTX bPCD bKA bPS -> -- 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))) -> @@ -658,7 +678,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 @@ -837,6 +857,51 @@ 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" + ((), trailing) <- + runPipelinedPeerWithLimits + (TraceLabelPeer them `contramap` tPerasCertDiffusionTracer) + (cPerasCertDiffusionCodec (mkCodecs version)) + blPerasCertDiffusion + timeLimitsObjectDiffusion + channel + ( objectDiffusionInboundPeerPipelined + (hPerasCertDiffusionClient version controlMessageSTM 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 -> @@ -940,10 +1005,11 @@ initiator :: 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{..} = nodeToNodeProtocols + Set.empty -- TODO: change for a meaningful value miniProtocolParameters -- TODO: currently consensus is using 'ConnectionId' for its 'peer' type. -- This is currently ok, as we might accept multiple connections from the @@ -958,6 +1024,9 @@ 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 = @@ -976,10 +1045,11 @@ initiatorAndResponder :: 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{..} = nodeToNodeProtocols + Set.empty -- TODO: change for a meaningful value miniProtocolParameters ( NodeToNodeProtocols { chainSyncProtocol = @@ -997,6 +1067,12 @@ 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 5bd6b825f0..b0d749a940 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 @@ -650,6 +650,7 @@ runWith RunNodeArgs{..} encAddrNtN decAddrNtN LowLevelRunNodeArgs{..} = ByteString ByteString ByteString + ByteString NodeToNodeInitiatorResult () mkNodeToNodeApps nodeKernelArgs nodeKernel peerMetrics encAddrNTN decAddrNTN version = @@ -691,6 +692,7 @@ runWith RunNodeArgs{..} encAddrNtN decAddrNtN LowLevelRunNodeArgs{..} = ByteString ByteString ByteString + ByteString NodeToNodeInitiatorResult () ) -> 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 29ac1621ea..44f13dbfe8 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 @@ -1796,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/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs index 9a5b9c8ab7..bdfd9c826c 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs @@ -144,9 +144,6 @@ instance StandardHash blk => BlockSupportsPeras blk where instance ShowProxy blk => ShowProxy (PerasCert blk) where showProxy _ = "PerasCert " <> showProxy (Proxy @blk) -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 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 index bba2d07cb0..f72299d0fe 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Inbound.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Inbound.hs @@ -18,7 +18,7 @@ module Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound , NumObjectsProcessed (..) ) where -import Cardano.Prelude (catMaybes) +import Cardano.Prelude (catMaybes, (&)) import Control.Concurrent.Class.MonadSTM.Strict.TVar.Checked import Control.Exception (assert) import Control.Monad (when) @@ -37,8 +37,9 @@ 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 NoThunks.Class (NoThunks (..)) import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API +import Ouroboros.Consensus.Util.NormalForm.Invariant (noThunksInvariant) import Ouroboros.Network.ControlMessage import Ouroboros.Network.NodeToNode.Version (NodeToNodeVersion) import Ouroboros.Network.Protocol.ObjectDiffusion.Inbound @@ -54,14 +55,14 @@ newtype NumObjectsProcessed data TraceObjectDiffusionInbound objectId object = -- | Number of objects just about to be inserted. - TraceObjectDiffusionCollected Int + TraceObjectDiffusionInboundCollectedObjects Int | -- | Just processed object pass/fail breakdown. - TraceObjectDiffusionProcessed NumObjectsProcessed + TraceObjectDiffusionInboundAddedObjects NumObjectsProcessed | -- | Received a 'ControlMessage' from the outbound peer governor, and about -- to act on it. - TraceObjectDiffusionControlMessage ControlMessage - | TraceObjectInboundCanRequestMoreObjects Int - | TraceObjectInboundCannotRequestMoreObjects Int + TraceObjectDiffusionInboundRecvControlMessage ControlMessage + | TraceObjectDiffusionInboundCanRequestMoreObjects Int + | TraceObjectDiffusionInboundCannotRequestMoreObjects Int deriving (Eq, Show) data ObjectDiffusionInboundError @@ -138,17 +139,17 @@ objectDiffusionInbound ObjectPoolWriter{..} _version controlMessageSTM = - ObjectDiffusionInboundPipelined $ do - continueWithStateM (go Zero) initialInboundSt + ObjectDiffusionInboundPipelined $! + checkState initialInboundSt & go Zero where canRequestMoreObjects :: InboundSt k object -> Bool - canRequestMoreObjects st = + 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 = + numIdsToReq !st = maxNumIdsToReq `min` ( fromIntegral maxFifoLength - (fromIntegral $ Seq.length $ outstandingFifo st) @@ -165,14 +166,14 @@ objectDiffusionInbound (objectId -> Bool) -> [objectId] -> InboundSt objectId object - preAcknowledge st _ collectedIds | null collectedIds = st - preAcknowledge st poolHasObject collectedIds = + 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) + poolHasObject collectedIds -- The objects that we intentionally don't request, because they are @@ -180,8 +181,10 @@ objectDiffusionInbound -- So we extend 'pendingObjects' with those objects (so of course they -- have no corresponding reply). pendingObjects' = - pendingObjects st - <> Map.fromList [(objectId, Nothing) | objectId <- alreadyObtained] + foldl' + (\accMap objectId -> Map.insert objectId Nothing accMap) + (pendingObjects st) + alreadyObtained -- We initially extend 'outstandingFifo' with the all the collected IDs -- (to properly mirror the server state). @@ -202,28 +205,33 @@ objectDiffusionInbound (flip Map.delete) pendingObjects' objectIdsToAck + + !st' = + st + { canRequestNext = canRequestNext st <> (Set.fromList notYetObtained) + , pendingObjects = pendingObjects'' + , outstandingFifo = outstandingFifo'' + , numToAckOnNextReq = + numToAckOnNextReq st + + fromIntegral (Seq.length objectIdsToAck) + } in - st - { canRequestNext = canRequestNext st <> (Set.fromList notYetObtained) - , pendingObjects = pendingObjects'' - , outstandingFifo = outstandingFifo'' - , numToAckOnNextReq = - numToAckOnNextReq st - + fromIntegral (Seq.length objectIdsToAck) - } + st' go :: forall (n :: N). Nat n -> - StatefulM (InboundSt objectId object) n objectId object m - go n = StatefulM $ \st -> do + InboundSt objectId object -> + InboundStIdle n objectId object m () + go n !st = WithEffect $ do -- Check whether we should continue engaging in the protocol. ctrlMsg <- atomically controlMessageSTM - traceWith tracer $ TraceObjectDiffusionControlMessage ctrlMsg + traceWith tracer $ + TraceObjectDiffusionInboundRecvControlMessage ctrlMsg case ctrlMsg of -- The peer selection governor is asking us to terminate the connection. Terminate -> - pure $ terminateAfterDrain n + 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 @@ -234,15 +242,17 @@ objectDiffusionInbound -- 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 + traceWith tracer $ + TraceObjectDiffusionInboundCanRequestMoreObjects (natToInt n) + pure $! checkState st & goReqObjectsAndObjectIdsPipelined Zero 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)) - pure $ continueWithState goReqObjectIdsBlocking st + traceWith tracer $ + TraceObjectDiffusionInboundCannotRequestMoreObjects (natToInt n) + pure $! checkState st & goReqObjectIdsBlocking -- We have pipelined some requests, so there are some replies in flight. Succ n' -> @@ -252,13 +262,15 @@ objectDiffusionInbound -- 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 $ + traceWith tracer $ + TraceObjectDiffusionInboundCanRequestMoreObjects (natToInt n) + pure $! CollectPipelined - (Just (continueWithState (goReqObjectsAndObjectIdsPipelined (Succ n')) st)) - (collectAndContinueWithState (goCollect n') st) + (Just (checkState st & goReqObjectsAndObjectIdsPipelined (Succ n'))) + (\collected -> checkState st & goCollect n' collected) else do - traceWith tracer (TraceObjectInboundCannotRequestMoreObjects (natToInt n)) + traceWith tracer $ + TraceObjectDiffusionInboundCannotRequestMoreObjects (natToInt n) -- In this case we can theoretically only collect replies or request -- new object IDs. -- @@ -270,17 +282,19 @@ objectDiffusionInbound -- requests. -- -- So we instead block until we collect a reply. - pure $ + pure $! CollectPipelined Nothing - (collectAndContinueWithState (goCollect n') st) + (\collected -> checkState st & goCollect n' collected) 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 + Collect objectId object -> + InboundSt objectId object -> + InboundStIdle n objectId object m () + goCollect n collect !st = case collect of + CollectObjectIds numIdsRequested collectedIds -> WithEffect $ do let numCollectedIds = length collectedIds collectedIdsSet = Set.fromList collectedIds @@ -304,12 +318,11 @@ objectDiffusionInbound -- 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} + let !st' = st{numIdsInFlight = numIdsInFlight st - numIdsRequested} poolHasObject <- atomically $ opwHasObject - continueWithStateM - (go n) - (preAcknowledge st' poolHasObject collectedIds) - CollectObjects requestedIds collectedObjects -> do + let !st'' = preAcknowledge st' poolHasObject collectedIds + pure $! checkState st'' & go n + CollectObjects requestedIds collectedObjects -> WithEffect $ do let requestedIdsSet = Set.fromList requestedIds obtainedIdsSet = Set.fromList (opwObjectId <$> collectedObjects) @@ -319,12 +332,14 @@ objectDiffusionInbound throwIO ProtocolErrorObjectNotRequested traceWith tracer $ - TraceObjectDiffusionCollected (length collectedObjects) + TraceObjectDiffusionInboundCollectedObjects (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 + let pendingObjects' = + foldl' + (\accMap object -> Map.insert (opwObjectId object) (Just object) accMap) + (pendingObjects st) + collectedObjects -- We then find the longest prefix of 'outstandingFifo' for which we have -- all the corresponding IDs in 'pendingObjects'. @@ -348,138 +363,92 @@ objectDiffusionInbound catMaybes $ (((Map.!) pendingObjects') <$> toList objectIdsToAck) - -- TODO: Certificate / Vote validation - opwAddObjects objectsToAck traceWith tracer $ - TraceObjectDiffusionProcessed + TraceObjectDiffusionInboundAddedObjects (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 !st' = + st + { pendingObjects = pendingObjects'' + , outstandingFifo = outstandingFifo' + , numToAckOnNextReq = + numToAckOnNextReq st + + fromIntegral (Seq.length objectIdsToAck) + } + pure $! checkState st' & go n + + goReqObjectIdsBlocking :: + InboundSt objectId object -> + InboundStIdle 'Z objectId object m () + goReqObjectIdsBlocking !st = 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 -> - collectAndContinueWithState - (goCollect Zero) - st - { numToAckOnNextReq = 0 - , numIdsInFlight = numIdsToRequest - } - (CollectObjectIds numIdsToRequest (NonEmpty.toList neCollectedIds)) - ) + -- We should only request new object IDs in a blocking way if we have + -- absolutely nothing else we can do. + !st' = + st + { numToAckOnNextReq = 0 + , numIdsInFlight = numIdsToRequest + } + in assert + ( numIdsInFlight st == 0 + && Seq.null (outstandingFifo st) + && Set.null (canRequestNext st) + && Map.null (pendingObjects st) + ) + $ SendMsgRequestObjectIdsBlocking + (numToAckOnNextReq st) + numIdsToRequest + ( \neCollectedIds -> + checkState st' & goCollect Zero (CollectObjectIds numIdsToRequest (NonEmpty.toList neCollectedIds)) + ) goReqObjectsAndObjectIdsPipelined :: forall (n :: N). Nat n -> - Stateful (InboundSt objectId object) n objectId object m - goReqObjectsAndObjectIdsPipelined n = Stateful $ \st -> do + InboundSt objectId object -> + InboundStIdle n objectId object m () + goReqObjectsAndObjectIdsPipelined n !st = -- 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'} - ) + !st' = st{canRequestNext = canRequestNext'} + in SendMsgRequestObjectsPipelined + (toList toRequest) + (checkState st' & goReqObjectIdsPipelined (Succ n)) goReqObjectIdsPipelined :: forall (n :: N). Nat n -> - StatefulM (InboundSt objectId object) n objectId object m - goReqObjectIdsPipelined n = StatefulM $ \st -> do + InboundSt objectId object -> + InboundStIdle n objectId object m () + goReqObjectIdsPipelined n !st = 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 - } - ) + in if numIdsToRequest <= 0 + then checkState st & go n + else + let !st' = + st + { numIdsInFlight = + numIdsInFlight st + + numIdsToRequest + , numToAckOnNextReq = 0 + } + in SendMsgRequestObjectIdsPipelined + (numToAckOnNextReq st) + numIdsToRequest + (checkState st' & go (Succ n)) -- 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 #-} + Zero -> SendMsgDone () + Succ n -> CollectPipelined Nothing $ \_ignoredMsg -> terminateAfterDrain n + +-- | Helper to ensure that the `InboundSt` is free of unexpected thunks and +-- stays strict during the whole process +checkState :: NoThunks s => s -> s +checkState !st = checkInvariant (noThunksInvariant st) st diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasCert/Smoke.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasCert/Smoke.hs index 00649475ab..bfdabbe57a 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasCert/Smoke.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasCert/Smoke.hs @@ -29,9 +29,9 @@ 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 - ( objectDiffusionInboundServerPeerPipelined + ( objectDiffusionInboundPeerPipelined ) -import Ouroboros.Network.Protocol.ObjectDiffusion.Outbound (objectDiffusionOutboundClientPeer) +import Ouroboros.Network.Protocol.ObjectDiffusion.Outbound (objectDiffusionOutboundPeer) import Test.Consensus.MiniProtocol.ObjectDiffusion.Smoke ( ListWithUniqueIds (..) , ProtocolConstants @@ -101,14 +101,14 @@ prop_smoke protocolConstants (ListWithUniqueIds certs) = ((\x -> "Outbound (Client): " ++ show x) `contramap` tracer) codecObjectDiffusionId outboundChannel - (objectDiffusionOutboundClientPeer outbound) + (objectDiffusionOutboundPeer outbound) >> pure () runInboundPeer inbound inboundChannel tracer = runPipelinedPeer ((\x -> "Inbound (Server): " ++ show x) `contramap` tracer) codecObjectDiffusionId inboundChannel - (objectDiffusionInboundServerPeerPipelined inbound) + (objectDiffusionInboundPeerPipelined inbound) >> pure () mkPoolInterfaces :: forall m. 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 index d681c12016..d2f21c9b66 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/Smoke.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/Smoke.hs @@ -51,13 +51,11 @@ import Ouroboros.Network.NodeToNode.Version (NodeToNodeVersion (..)) import Ouroboros.Network.Protocol.ObjectDiffusion.Codec (codecObjectDiffusionId) import Ouroboros.Network.Protocol.ObjectDiffusion.Inbound ( ObjectDiffusionInboundPipelined - , objectDiffusionInboundClientPeerPipelined - , objectDiffusionInboundServerPeerPipelined + , objectDiffusionInboundPeerPipelined ) import Ouroboros.Network.Protocol.ObjectDiffusion.Outbound ( ObjectDiffusionOutbound - , objectDiffusionOutboundClientPeer - , objectDiffusionOutboundServerPeer + , objectDiffusionOutboundPeer ) import Ouroboros.Network.Protocol.ObjectDiffusion.Type ( NumObjectIdsReq (..) @@ -76,11 +74,8 @@ tests = testGroup "ObjectDiffusion.Smoke" [ testProperty - "ObjectDiffusion smoke test with mock objects (client inbound, server outbound)" - prop_smoke_init_inbound - , testProperty - "ObjectDiffusion smoke test with mock objects (client outbound, server inbound)" - prop_smoke_init_outbound + "ObjectDiffusion smoke test with mock objects" + prop_smoke ] {------------------------------------------------------------------------------- @@ -185,8 +180,8 @@ instance Arbitrary ProtocolConstants where nodeToNodeVersion :: NodeToNodeVersion nodeToNodeVersion = NodeToNodeV_14 -prop_smoke_init_inbound :: ProtocolConstants -> ListWithUniqueIds SmokeObject idTy -> Property -prop_smoke_init_inbound protocolConstants (ListWithUniqueIds objects) = +prop_smoke :: ProtocolConstants -> ListWithUniqueIds SmokeObject idTy -> Property +prop_smoke protocolConstants (ListWithUniqueIds objects) = prop_smoke_object_diffusion protocolConstants objects @@ -199,7 +194,7 @@ prop_smoke_init_inbound protocolConstants (ListWithUniqueIds objects) = ((\x -> "Outbound (Server): " ++ show x) `contramap` tracer) codecObjectDiffusionId outboundChannel - (objectDiffusionOutboundServerPeer outbound) + (objectDiffusionOutboundPeer outbound) >> pure () runInboundPeer inbound inboundChannel tracer = @@ -207,33 +202,7 @@ prop_smoke_init_inbound protocolConstants (ListWithUniqueIds objects) = ((\x -> "Inbound (Client): " ++ show x) `contramap` tracer) codecObjectDiffusionId inboundChannel - (objectDiffusionInboundClientPeerPipelined inbound) - >> pure () - -prop_smoke_init_outbound :: - ProtocolConstants -> ListWithUniqueIds SmokeObject SmokeObjectId -> Property -prop_smoke_init_outbound protocolConstants (ListWithUniqueIds objects) = - prop_smoke_object_diffusion - protocolConstants - objects - runOutboundPeer - runInboundPeer - (mkMockPoolInterfaces objects) - where - runOutboundPeer outbound outboundChannel tracer = - runPeer - ((\x -> "Outbound (Client): " ++ show x) `contramap` tracer) - codecObjectDiffusionId - outboundChannel - (objectDiffusionOutboundClientPeer outbound) - >> pure () - - runInboundPeer inbound inboundChannel tracer = - runPipelinedPeer - ((\x -> "Inbound (Server): " ++ show x) `contramap` tracer) - codecObjectDiffusionId - inboundChannel - (objectDiffusionInboundServerPeerPipelined inbound) + (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 @@ -251,14 +220,14 @@ prop_smoke_object_diffusion :: ( forall m. IOLike m => ObjectDiffusionOutbound objectId object m () -> - Channel m (AnyMessage (ObjectDiffusion initAgency objectId object)) -> + Channel m (AnyMessage (ObjectDiffusion objectId object)) -> (Tracer m String) -> m () ) -> ( forall m. IOLike m => ObjectDiffusionInboundPipelined objectId object m () -> - (Channel m (AnyMessage (ObjectDiffusion initAgency objectId object))) -> + (Channel m (AnyMessage (ObjectDiffusion objectId object))) -> (Tracer m String) -> m () ) -> @@ -297,6 +266,7 @@ prop_smoke_object_diffusion ) inboundPoolWriter nodeToNodeVersion + (readTVar controlMessage) outbound = objectDiffusionOutbound @@ -304,7 +274,6 @@ prop_smoke_object_diffusion maxFifoSize outboundPoolReader nodeToNodeVersion - (readTVar controlMessage) withRegistry $ \reg -> do (outboundChannel, inboundChannel) <- createConnectedChannels From d0f13adbc3fa37dd6b9e18e781441197d7bf7951 Mon Sep 17 00:00:00 2001 From: Alexander Esgen Date: Tue, 2 Sep 2025 11:58:27 +0200 Subject: [PATCH 12/43] Add basic API for certificate validation Conflicts: ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasCert.hs ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/API.hs ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasCert/Smoke.hs ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/Model.hs ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs --- .../Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs | 2 ++ .../Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs | 10 +++++++++- 2 files changed, 11 insertions(+), 1 deletion(-) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs index 34380963f3..e8738ad0b7 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs @@ -259,6 +259,8 @@ data PerasVolatileCertState blk = PerasVolatileCertState -- ^ 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 (ValidatedPerasCert blk)) -- ^ The certificates by 'PerasCertTicketNo'. -- diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs index 5df29e3d27..97bf4844c6 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs @@ -113,7 +113,15 @@ instance StateModel Model where precondition (Model model) = \case OpenDB -> not model.open - _ -> 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) From 11d47de5b2cc4c2f0313e59ee4b2eeaa369cf7d2 Mon Sep 17 00:00:00 2001 From: Georgy Lukyanov Date: Tue, 22 Jul 2025 09:13:31 +0200 Subject: [PATCH 13/43] Adapt the HFC time translation layer for Peras - Add `PerasRoundLength` - introduce the `PerasEnabled` datatype to track values are only used when Peras is enabled - HFC: translate between Peras rounds and slots Conflicts: ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs --- .../Consensus/Byron/Ledger/Ledger.hs | 2 + .../Consensus/Shelley/Ledger/Ledger.hs | 4 + .../Test/Consensus/Cardano/Generators.hs | 10 +- .../Test/Consensus/HardFork/Combinator.hs | 1 + .../test/mock-test/Test/ThreadNet/BFT.hs | 1 + .../Ouroboros/Consensus/HardFork/Abstract.hs | 2 +- .../Consensus/HardFork/History/EraParams.hs | 78 ++++++++++++++- .../Consensus/HardFork/History/Qry.hs | 96 ++++++++++++++++++- .../Consensus/HardFork/History/Summary.hs | 64 +++++++++++-- .../Consensus/HardFork/History/Util.hs | 10 ++ .../Test/Ouroboros/Storage/TestBlock.hs | 1 + .../Test/Util/Orphans/Arbitrary.hs | 21 +++- .../Test/Consensus/HardFork/History.hs | 40 +++++++- .../Test/Consensus/HardFork/Infra.hs | 14 ++- .../Test/Consensus/HardFork/Summary.hs | 64 ++++++++++++- 15 files changed, 382 insertions(+), 26 deletions(-) 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/shelley/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs index 72871d95e8..c8851eaaf1 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 @@ -117,6 +117,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 @@ -173,6 +174,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 = @@ -188,6 +191,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/unstable-cardano-testlib/Test/Consensus/Cardano/Generators.hs b/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/Consensus/Cardano/Generators.hs index 0e0672c7c9..ac35649dad 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/test/consensus-test/Test/Consensus/HardFork/Combinator.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator.hs index fdd205031b..b07657af11 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 a455689110..34d0c567a9 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/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/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/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/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{..} = From 7bd5d6db059180112946f7aee5a38c9855737d35 Mon Sep 17 00:00:00 2001 From: Alexander Esgen Date: Tue, 9 Sep 2025 14:03:54 +0200 Subject: [PATCH 14/43] Peras.SelectView: use fragment length instead of tip `BlockNo` In the presence of EBBs, block numbers can be very misleading, eg the tip block number of a shorter chain can have a higher block number than that of a longer one. To avoid test failures due to this peculiar behavior, we do not look at block numbers at all for the `WeightedSelectView`, and instead measure the length of the fragment (relative to its anchor). Concretely, this change fixes test failures in the ChainDB q-s-m test when testing with eg `k=5` instead of `k=2` (as different candidates can then actually contain *multiple* EBBs). When EBBs are not used (which has been the case on mainnet for >5 years), this change has no semantic impact. --- .../Ouroboros/Consensus/Peras/SelectView.hs | 16 +++++++++++----- 1 file changed, 11 insertions(+), 5 deletions(-) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/SelectView.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/SelectView.hs index 04e4eed8ea..ae7b8d9eb5 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/SelectView.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/SelectView.hs @@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} @@ -20,6 +21,7 @@ module Ouroboros.Consensus.Peras.SelectView ) where import Data.Function (on) +import Data.Word (Word64) import Ouroboros.Consensus.Block import Ouroboros.Consensus.Peras.Weight import Ouroboros.Consensus.Protocol.Abstract @@ -37,8 +39,12 @@ import qualified Ouroboros.Network.AnchoredFragment as AF -- as the fragments might not intersect, and so some blocks after their -- intersection (and hence their weight boost) are unknown. data WeightedSelectView proto = WeightedSelectView - { wsvBlockNo :: !BlockNo - -- ^ The 'BlockNo' at the tip of a fragment. + { 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 @@ -52,11 +58,11 @@ deriving stock instance Eq (TiebreakerView proto) => Eq (WeightedSelectView prot -- 'WeightedSelectView's obtained from fragments with different anchors? -- Something ST-trick like? --- | The total weight, ie the sum of 'wsvBlockNo' and 'wsvBoostedWeight'. +-- | 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 (unBlockNo (wsvBlockNo wsv)) <> wsvWeightBoost wsv + PerasWeight (wsvLength wsv) <> wsvWeightBoost wsv instance Ord (TiebreakerView proto) => Ord (WeightedSelectView proto) where compare = @@ -94,7 +100,7 @@ weightedSelectView bcfg weights = \case frag@(_ AF.:> (getHeader1 -> hdr)) -> NonEmptyFragment WeightedSelectView - { wsvBlockNo = blockNo hdr + { wsvLength = fromIntegral @Int @Word64 $ AF.length frag , wsvWeightBoost = weightBoostOfFragment weights frag , wsvTiebreaker = tiebreakerView bcfg hdr } From 4b0aae5fdcbea4542ab2292b5cd4eba6e9399ef3 Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Wed, 10 Sep 2025 20:13:54 +0200 Subject: [PATCH 15/43] Avoid exposing Peras boostPerCert in tests Since the Peras boost per certificate will likely become a protocol parameter, we proactively avoid exposing the current hardcoded value, replacing it with an instantiation of (currently trivial) the PerasCfg builder. In the special cases where it's interesting to vary the boost dynamically (ChainDB q-s-m), validated Peras certs now contain randomly generated boost weights. --- .../Ouroboros/Consensus/Block/SupportsPeras.hs | 2 +- .../ObjectDiffusion/PerasCert/Smoke.hs | 14 +++++++++----- .../Test/Ouroboros/Storage/ChainDB/StateMachine.hs | 3 ++- .../Ouroboros/Storage/PerasCertDB/StateMachine.hs | 5 ++++- 4 files changed, 16 insertions(+), 8 deletions(-) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs index bdfd9c826c..030ab9d7e2 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs @@ -14,9 +14,9 @@ module Ouroboros.Consensus.Block.SupportsPeras ( PerasRoundNo (..) , PerasWeight (..) - , boostPerCert , BlockSupportsPeras (..) , PerasCert (..) + , PerasCfg (..) , ValidatedPerasCert (..) , makePerasCfg , HasPerasCert (..) diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasCert/Smoke.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasCert/Smoke.hs index bfdabbe57a..72ac5217f7 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasCert/Smoke.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasCert/Smoke.hs @@ -51,6 +51,9 @@ tests = [ testProperty "PerasCertDiffusion smoke test" prop_smoke ] +perasTestCfg :: PerasCfg TestBlock +perasTestCfg = makePerasCfg Nothing + instance Arbitrary (Point TestBlock) where arbitrary = -- Sometimes pick the genesis point @@ -74,15 +77,16 @@ instance Arbitrary (Point blk) => Arbitrary (PerasCert blk) where instance WithId (PerasCert blk) PerasRoundNo where getId = pcCertRound -newCertDB :: (IOLike m, StandardHash blk) => [PerasCert blk] -> m (PerasCertDB m blk) -newCertDB certs = do +newCertDB :: + (IOLike m, StandardHash blk) => PerasCfg blk -> [PerasCert blk] -> m (PerasCertDB m blk) +newCertDB perasCfg certs = do db <- PerasCertDB.openDB (PerasCertDB.PerasCertDbArgs @Identity nullTracer) mapM_ ( \cert -> do let validatedCert = ValidatedPerasCert { vpcCert = cert - , vpcCertBoost = boostPerCert + , vpcCertBoost = perasCfgWeightBoost perasCfg } result <- PerasCertDB.addCert db validatedCert case result of @@ -119,8 +123,8 @@ prop_smoke protocolConstants (ListWithUniqueIds certs) = , m [PerasCert TestBlock] ) mkPoolInterfaces = do - outboundPool <- newCertDB certs - inboundPool <- newCertDB [] + outboundPool <- newCertDB perasTestCfg certs + inboundPool <- newCertDB perasTestCfg [] let outboundPoolReader = makePerasCertPoolReaderFromCertDB outboundPool inboundPoolWriter = makePerasCertPoolWriterFromCertDB inboundPool 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 e3a787a6c6..93cb2917b1 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 @@ -1051,6 +1051,7 @@ generator loe genBlock m@Model{..} = let roundNo = case Model.maxPerasRoundNo dbModel of Nothing -> PerasRoundNo 0 Just (PerasRoundNo r) -> PerasRoundNo (r + 1) + boost <- PerasWeight <$> choose (2, 4) pure $ ValidatedPerasCert { vpcCert = @@ -1058,7 +1059,7 @@ generator loe genBlock m@Model{..} = { pcCertRound = roundNo , pcCertBoostedBlock = blockPoint blk } - , vpcCertBoost = boostPerCert + , vpcCertBoost = boost } genBounds :: Gen (StreamFrom blk, StreamTo blk) diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs index 97bf4844c6..4e64ad18fe 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs @@ -45,6 +45,9 @@ tests = [ 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 @@ -82,7 +85,7 @@ instance StateModel Model where { pcCertRound = roundNo , pcCertBoostedBlock = boostedBlock } - , vpcCertBoost = boostPerCert + , vpcCertBoost = perasCfgWeightBoost perasTestCfg } -- Generators are heavily skewed toward collisions, to get equivocating certificates From 78bb0fa0d403143fe2eac8694398e6b8949f534a Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Wed, 10 Sep 2025 21:30:49 +0200 Subject: [PATCH 16/43] Refactor ChainDB q-s-m test to carry gap blocks between commands Extends the ChainDB model with generator state to support carrying gap blocks in state machine tests. This increases the chances of generating and adding (possibly out-of-order) branching sequences of blocks. This, in turn increases the chances of observing the event where the chain selection logic switches from a longer to a shorter (but heavier) chain containing a boosted block. Conflicts: ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs --- .../Ouroboros/Storage/ChainDB/StateMachine.hs | 224 +++++++++++++----- 1 file changed, 163 insertions(+), 61 deletions(-) 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 93cb2917b1..6516fa0b8c 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 @@ -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 (..)) @@ -176,10 +177,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 - | AddPerasCert (ValidatedPerasCert 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 (ValidatedPerasCert blk) (Persistent [blk]) | GetCurrentChain | GetTipBlock | GetTipHeader @@ -405,8 +414,8 @@ run :: m (Success blk (TestIterator m blk) (TestFollower m blk)) run cfg env@ChainDBEnv{varDB, ..} cmd = readTVarIO varDB >>= \st@ChainDBState{chainDB = chainDB@ChainDB{..}, internal} -> case cmd of - AddBlock blk -> Point <$> advanceAndAdd st blk - AddPerasCert cert -> Unit <$> addPerasCertSync chainDB cert + AddBlock blk _ -> Point <$> advanceAndAdd st blk + AddPerasCert cert _ -> Unit <$> addPerasCertSync chainDB cert GetCurrentChain -> Chain <$> atomically getCurrentChain GetTipBlock -> MbBlock <$> getTipBlock GetTipHeader -> MbHeader <$> getTipHeader @@ -611,7 +620,7 @@ instance Eq IsValidResult where (Just _, Nothing) -> False {------------------------------------------------------------------------------- - Instantiating the semantics + Responses -------------------------------------------------------------------------------} -- | Responses are either successful termination or an error. @@ -628,6 +637,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 @@ -640,8 +669,8 @@ runPure :: DBModel blk -> (Resp blk IteratorId FollowerId, DBModel blk) runPure cfg = \case - AddBlock blk -> ok Point $ update (add blk) - AddPerasCert cert -> ok Unit $ ((),) . update (Model.addPerasCert cfg cert) + 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) @@ -728,22 +757,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 -------------------------------------------------------------------------------} @@ -760,12 +773,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 @@ -784,6 +854,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 @@ -871,6 +942,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 @@ -879,18 +951,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 } @@ -899,14 +974,12 @@ 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{..} = @@ -917,7 +990,7 @@ generator loe genBlock m@Model{..} = LoEDisabled -> 10 -- The LoE does not yet support Peras. LoEEnabled () -> 0 - in (freq, AddPerasCert <$> genAddPerasCert) + 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) @@ -973,7 +1046,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 @@ -994,7 +1067,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) @@ -1033,6 +1106,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 @@ -1041,26 +1115,42 @@ 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 (ValidatedPerasCert blk) + genAddPerasCert :: Gen (Cmd blk it flr) genAddPerasCert = do -- TODO should we be more strict on which blocks we add certs to? -- see https://github.com/tweag/cardano-peras/issues/124 - blk <- genBlock m + (blk, gapBlks) <- genBlock m let roundNo = case Model.maxPerasRoundNo dbModel of Nothing -> PerasRoundNo 0 Just (PerasRoundNo r) -> PerasRoundNo (r + 1) - boost <- PerasWeight <$> choose (2, 4) + -- 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)) + ] + -- Include the boosted block itself in the persisted seenBlocks + let seenBlks = fmap (blk :) gapBlks + pure $ - ValidatedPerasCert - { vpcCert = - PerasCert - { pcCertRound = roundNo - , pcCertBoostedBlock = blockPoint blk - } - , vpcCertBoost = boost - } + AddPerasCert + ( ValidatedPerasCert + { vpcCert = + PerasCert + { pcCertRound = roundNo + , pcCertBoostedBlock = blockPoint blk + } + , vpcCertBoost = boost + } + ) + seenBlks genBounds :: Gen (StreamFrom blk, StreamTo blk) genBounds = @@ -1303,7 +1393,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 @@ -1487,21 +1577,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 <- @@ -1534,20 +1628,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 From d246270c8eac0dc9be7fe10efe3ebe20bed9d618 Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Fri, 12 Sep 2025 13:53:54 +0200 Subject: [PATCH 17/43] Tweak generation frequencies in ChainDB q-s-m tests This commit increases the generation frequencies of both the 'genAddBlock' and 'genAddPerasCert' constructions to help producing denser chains of blocks. This way, some of the events that were harder to trigger (especially TagSwitchedToShorterChain) are much more common now: * Before: Tags (5784 in total): 39.83% TagGetIsValidJust 29.72% TagChainSelReprocessKeptSelection 27.92% TagGetIsValidNothing 2.42% TagChainSelReprocessChangedSelection 0.10% TagSwitchedToShorterChain * After: Tags (5202 in total): 38.66% TagGetIsValidJust 27.87% TagChainSelReprocessKeptSelection 26.43% TagGetIsValidNothing 5.71% TagChainSelReprocessChangedSelection 1.33% TagSwitchedToShorterChain --- .../Test/Ouroboros/Storage/ChainDB/StateMachine.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) 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 6516fa0b8c..5d608400e6 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 @@ -985,9 +985,9 @@ generator :: generator loe genBlock m@Model{..} = At <$> frequency - [ (30, genAddBlock) + [ (100, genAddBlock) , let freq = case loe of - LoEDisabled -> 10 + LoEDisabled -> 100 -- The LoE does not yet support Peras. LoEEnabled () -> 0 in (freq, genAddPerasCert) From 79e237b8fb0b93518311e4f9dfdb3eaf3bba58c1 Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Mon, 15 Sep 2025 12:50:05 +0200 Subject: [PATCH 18/43] Generate security parameter for ChainDB q-s-m test on the fly After analysing the effect of varying the security parameter (`k`) of the ChainDB state machine tests (currently hardcoded with 2), we have observed a tension between: 1) generating enough tests exercising the new Peras behavior where the chain selection mechanism switches to a shorter but heavier chain (cert boost is derived from k and must be large enough to overcome the weight of a longer chain), and 2) generating enough tests exercising the ImmutableDB logic (the chain must have at least k blocks) Here are some empirical results: k -> P(switch to shorter chain), P(generate a chain with >= k blocks) k=2 -> ~1.3%, ~40% k=3 -> ~1.9%, ~20% k=4 -> ~2.4%, ~9% k=5 -> ~2.5%, ~3% k=10 -> ~3%, ~0.05% We believe that the sweet spot between both desiderata appears to be around `k=2` and `k=4`. This commit introduces a random generator for `k` using a geometric distribution to bias the randomly generated `k`s to be relatively small, while still allowing larger ones to appear from time to time. Under the current parameters, roughly 75% of the tests use `k<=4`; ``` Security Parameter (k) (10000 in total): 50.82% 2 23.83% 3 12.62% 4 6.69% 5 3.08% 6 1.54% 7 0.74% 8 0.37% 9 0.16% 10 0.06% 11 0.05% 12 0.02% 13 0.01% 14 0.01% 17 ``` Yielding the following distributions for 1) and 2), respectively: ``` Tags (5161 in total): 39.35% TagGetIsValidJust 29.22% TagChainSelReprocessKeptSelection 25.91% TagGetIsValidNothing 3.88% TagChainSelReprocessChangedSelection 1.65% TagSwitchedToShorterChain <- HERE ``` ``` Chain length >= k (10000 in total): 73.25% False 26.75% True <- HERE ``` --- .../Ouroboros/Storage/ChainDB/StateMachine.hs | 78 ++++++++++++------- .../ChainDB/StateMachine/Utils/RunOnRepl.hs | 6 +- .../Test/Ouroboros/Storage/ChainDB/Unit.hs | 10 ++- 3 files changed, 63 insertions(+), 31 deletions(-) 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 5d608400e6..7e0bd33edc 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 @@ -151,6 +151,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 @@ -1710,40 +1711,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. @@ -1751,15 +1771,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) -> @@ -1822,26 +1842,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 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 From 7da3375adb06ca058c50e17310c098568a61a4f9 Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Thu, 9 Oct 2025 14:30:15 +0200 Subject: [PATCH 19/43] Propagate feature flags down to NodeKernelArgs Brings in cardano-base and propagates a set of `CardanoFeatureFlag`s from the top-level `RunNodeArgs` down to the `NodeKernelArgs`. This is currently needed by an upcoming PR to the GSM to distinguish whether having an established PerasCertDiffusion connection with a given peer is necessary or not when trying to decide if such peer is idling. Conflicts: cabal.project flake.lock ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node.hs --- cabal.project | 2 +- flake.lock | 6 +++--- .../ouroboros-consensus-diffusion.cabal | 1 + .../Ouroboros/Consensus/Node.hs | 13 +++++++++++++ .../Ouroboros/Consensus/NodeKernel.hs | 3 +++ .../Test/ThreadNet/Network.hs | 1 + 6 files changed, 22 insertions(+), 4 deletions(-) diff --git a/cabal.project b/cabal.project index 6f8a8dbfdf..8faec02812 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-09-26T20:57:57Z -- Bump this if you need newer packages from CHaP - , cardano-haskell-packages 2025-10-01T14:54:25Z + , cardano-haskell-packages 2025-10-07T11:20:00Z packages: ouroboros-consensus diff --git a/flake.lock b/flake.lock index acef080678..4feaa39476 100644 --- a/flake.lock +++ b/flake.lock @@ -3,11 +3,11 @@ "CHaP": { "flake": false, "locked": { - "lastModified": 1759339316, - "narHash": "sha256-SW/K9yfhNLNCDAl2ZC8ol0w8X+AwyLin0XOvnn50468=", + "lastModified": 1759837865, + "narHash": "sha256-g8SMcVN1v51Muz6a+xJkB92mPx1jsg+sjHKvQ3Wj/jY=", "owner": "intersectmbo", "repo": "cardano-haskell-packages", - "rev": "aa50d6dffede91c8fdfcef94c71641a00214522a", + "rev": "9a46cacd941c108492cd4cee5d29735e8cd8ee65", "type": "github" }, "original": { diff --git a/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal b/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal index f1c5b42fcd..0caddc634b 100644 --- a/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal +++ b/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal @@ -77,6 +77,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, 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 b0d749a940..fd009ec4b3 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 @@ -61,6 +61,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 @@ -85,6 +86,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 @@ -233,6 +235,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. @@ -320,6 +324,8 @@ data LowLevelRunNodeArgs m addrNTN addrNTC blk , llrnPublicPeerSelectionStateVar :: StrictSTM.StrictTVar m (PublicPeerSelectionState addrNTN) , llrnLdbFlavorArgs :: LedgerDbBackendArgs m blk -- ^ The flavor arguments + , llrnFeatureFlags :: Set CardanoFeatureFlag + -- ^ Enabled experimental features } data NodeDatabasePaths @@ -571,6 +577,7 @@ runWith RunNodeArgs{..} encAddrNtN decAddrNtN LowLevelRunNodeArgs{..} = gsmAntiThunderingHerd keepAliveRng cfg + llrnFeatureFlags rnTraceConsensus btime (InFutureCheck.realHeaderInFutureCheck llrnMaxClockSkew systemTime) @@ -848,6 +855,7 @@ mkNodeKernelArgs :: StdGen -> StdGen -> TopLevelConfig blk -> + Set CardanoFeatureFlag -> Tracers m (ConnectionId addrNTN) (ConnectionId addrNTC) blk -> BlockchainTime m -> InFutureCheck.SomeHeaderInFutureCheck m blk -> @@ -867,6 +875,7 @@ mkNodeKernelArgs gsmAntiThunderingHerd rng cfg + featureFlags tracers btime chainSyncFutureCheck @@ -886,6 +895,7 @@ mkNodeKernelArgs { tracers , registry , cfg + , featureFlags , btime , chainDB , initChainDB = nodeInitChainDB @@ -1004,6 +1014,7 @@ stdLowLevelRunNodeArgsIO { rnProtocolInfo , rnPeerSharing , rnGenesisConfig + , rnFeatureFlags } $(SafeWildCards.fields 'StdRunNodeArgs) = do llrnBfcSalt <- stdBfcSaltIO @@ -1053,6 +1064,8 @@ stdLowLevelRunNodeArgsIO , llrnPublicPeerSelectionStateVar = Diffusion.dcPublicPeerSelectionVar srnDiffusionConfiguration , llrnLdbFlavorArgs = srnLedgerDbBackendArgs + , llrnFeatureFlags = + rnFeatureFlags } where networkMagic :: NetworkMagic 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 1c45c68155..36ba2cbcf2 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 @@ -51,6 +52,7 @@ import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NE import Data.Maybe (isJust, mapMaybe) import Data.Proxy +import Data.Set (Set) import qualified Data.Text as Text import Data.Void (Void) import Ouroboros.Consensus.Block hiding (blockMatchesHeader) @@ -195,6 +197,7 @@ 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 , chainDB :: ChainDB m blk , initChainDB :: StorageConfig blk -> InitChainDB m blk -> m () 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 44f13dbfe8..6bd6d9bde4 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 @@ -1045,6 +1045,7 @@ runThreadNetwork { tracers , registry , cfg = pInfoConfig + , featureFlags = mempty , btime , chainDB , initChainDB = nodeInitChainDB From a5f5f3b1ca4f9e9aaf977263b493d1e30feb82df Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Mon, 13 Oct 2025 18:50:03 +0200 Subject: [PATCH 20/43] Bump ouroboros-network to match peras-staging/pr-5202 Bumps the external ouroboros-network source-repository-package to the updated peras-staging/pr-5202, which incorporates the changes from: https://github.com/IntersectMBO/ouroboros-network/pull/5202 In addition, it tweak call sites of `nodeToNodeProtocols` to match its updated signature, passing down the enabled feature flags. Conflicts: cabal.project ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs --- .../Ouroboros/Consensus/Network/NodeToNode.hs | 19 ++++++++++++------- .../Ouroboros/Consensus/Node.hs | 4 ++-- 2 files changed, 14 insertions(+), 9 deletions(-) diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs index 294aace61f..c96dc97e61 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,7 +55,7 @@ import qualified Data.ByteString.Lazy as BSL import Data.Hashable (Hashable) import Data.Int (Int64) import Data.Map.Strict (Map) -import qualified Data.Set as Set +import Data.Set (Set) import Data.Void (Void) import qualified Network.Mux as Mux import Network.TypedProtocol.Codec @@ -1002,14 +1003,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 b a c -> OuroborosBundleWithExpandedCtx 'Mux.InitiatorMode addr b m a Void -initiator miniProtocolParameters version versionData Apps{..} = +initiator featureFlags miniProtocolParameters version versionData Apps{..} = nodeToNodeProtocols - Set.empty -- TODO: change for a meaningful value + featureFlags miniProtocolParameters -- TODO: currently consensus is using 'ConnectionId' for its 'peer' type. -- This is currently ok, as we might accept multiple connections from the @@ -1026,7 +1028,8 @@ initiator miniProtocolParameters version versionData Apps{..} = (InitiatorProtocolOnly (MiniProtocolCb (\ctx -> aTxSubmission2Client version ctx))) , perasCertDiffusionProtocol = (InitiatorProtocolOnly (MiniProtocolCb (\ctx -> aPerasCertDiffusionClient version ctx))) - , perasVoteDiffusionProtocol = error "perasVoteDiffusionProtocol not implemented" + , perasVoteDiffusionProtocol = + error "perasVoteDiffusionProtocol not implemented" , keepAliveProtocol = (InitiatorProtocolOnly (MiniProtocolCb (\ctx -> aKeepAliveClient version ctx))) , peerSharingProtocol = @@ -1042,14 +1045,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 b a c -> OuroborosBundleWithExpandedCtx 'Mux.InitiatorResponderMode addr b m a c -initiatorAndResponder miniProtocolParameters version versionData Apps{..} = +initiatorAndResponder featureFlags miniProtocolParameters version versionData Apps{..} = nodeToNodeProtocols - Set.empty -- TODO: change for a meaningful value + featureFlags miniProtocolParameters ( NodeToNodeProtocols { chainSyncProtocol = @@ -1072,7 +1076,8 @@ initiatorAndResponder miniProtocolParameters version versionData Apps{..} = (MiniProtocolCb (\initiatorCtx -> aPerasCertDiffusionClient version initiatorCtx)) (MiniProtocolCb (\responderCtx -> aPerasCertDiffusionServer version responderCtx)) ) - , perasVoteDiffusionProtocol = error "perasVoteDiffusionProtocol not implemented" + , 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 fd009ec4b3..fc7242de91 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 @@ -741,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. @@ -756,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 From 9ce9a393fc69ab109f8cf79f71235b4c0f858bd0 Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Mon, 6 Oct 2025 20:31:42 +0200 Subject: [PATCH 21/43] Break Idling into its own module --- .../bench/ChainSync-client-bench/Main.hs | 3 +- ouroboros-consensus/ouroboros-consensus.cabal | 2 ++ .../MiniProtocol/ChainSync/Client.hs | 22 +------------ .../Ouroboros/Consensus/MiniProtocol/Util.hs | 5 +++ .../Consensus/MiniProtocol/Util/Idling.hs | 31 +++++++++++++++++++ 5 files changed, 41 insertions(+), 22 deletions(-) create mode 100644 ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/Util.hs create mode 100644 ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/Util/Idling.hs 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/ouroboros-consensus.cabal b/ouroboros-consensus/ouroboros-consensus.cabal index 091aeea1e9..0b4f576d31 100644 --- a/ouroboros-consensus/ouroboros-consensus.cabal +++ b/ouroboros-consensus/ouroboros-consensus.cabal @@ -196,6 +196,8 @@ library 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 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 fcb0e25388..0c0d46c4ee 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,6 +121,7 @@ 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) @@ -272,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 ()) 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 () + } From 11791ad6c64a0835e5e81a4140122fcbb32d25dd Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Mon, 6 Oct 2025 20:44:07 +0200 Subject: [PATCH 22/43] Introduce O.C.MiniProtocol.ObjectDiffusion.Inbound.State --- ouroboros-consensus/ouroboros-consensus.cabal | 1 + .../ObjectDiffusion/Inbound/State.hs | 127 ++++++++++++++++++ 2 files changed, 128 insertions(+) create mode 100644 ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Inbound/State.hs diff --git a/ouroboros-consensus/ouroboros-consensus.cabal b/ouroboros-consensus/ouroboros-consensus.cabal index 0b4f576d31..434cc3e8d2 100644 --- a/ouroboros-consensus/ouroboros-consensus.cabal +++ b/ouroboros-consensus/ouroboros-consensus.cabal @@ -192,6 +192,7 @@ library 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 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..83d8d26c8f --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Inbound/State.hs @@ -0,0 +1,127 @@ +{-# 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.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 we have received all objects from a peer + } + deriving stock Generic + +deriving anyclass instance + ( HasHeader blk + , NoThunks (Header blk) + ) => + NoThunks (ObjectDiffusionInboundState blk) + +initObjectDiffusionInboundState :: ObjectDiffusionInboundState blk +initObjectDiffusionInboundState = ObjectDiffusionInboundState{odisIdling = True} + +-- | 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)) => + ObjectDiffusionInboundHandleCollection peer m blk -> + peer -> + (ObjectDiffusionInboundStateView m -> m a) -> + m a +bracketObjectDiffusionInbound handles peer body = do + odiState <- newTVarIO initObjectDiffusionInboundState + 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 From 2f812725565ce6d7a99d03ead0f4b8e410d7a74e Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Mon, 13 Oct 2025 10:29:46 +0200 Subject: [PATCH 23/43] Introduce PerasCertDiffusion type synonyms --- .../MiniProtocol/ObjectDiffusion/PerasCert.hs | 13 +++++++++++++ 1 file changed, 13 insertions(+) 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 index ba0ba934a2..5c024618b0 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/PerasCert.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/PerasCert.hs @@ -8,10 +8,14 @@ module Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.PerasCert , 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 @@ -39,3 +43,12 @@ type PerasCertDiffusionOutbound 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 From 221ae99361e73e1972f4341c0e55d76f81eac5f9 Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Thu, 9 Oct 2025 10:20:04 +0200 Subject: [PATCH 24/43] Generalize chainSyncState to peerState in the GSM --- .../Ouroboros/Consensus/Node/GSM.hs | 32 ++++++++----------- .../Ouroboros/Consensus/NodeKernel.hs | 2 +- .../test/consensus-test/Test/Consensus/GSM.hs | 2 +- .../Consensus/Genesis/Tests/LoE/CaughtUp.hs | 2 +- 4 files changed, 17 insertions(+), 21 deletions(-) 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 780602118b..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,7 +95,7 @@ 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 @@ -108,13 +106,13 @@ data GsmView m upstreamPeer selection chainSyncState = GsmView STM m ( selection -> - chainSyncState -> + peerState -> CandidateVersusSelection ) -- ^ Whether the candidate from the @chainSyncState@ is preferable to the -- selection. This can depend on external state (Peras certificates boosting -- blocks). - , peerIsIdle :: chainSyncState -> Bool + , 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 @@ -123,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 @@ -244,7 +240,7 @@ realGsmEntryPoints tracerArgs gsmView = , peerIsIdle , durationUntilTooOld , equivalent - , getChainSyncStates + , getPeerStates , getCurrentSelection , minCaughtUpDuration , setCaughtUpPersistentMark @@ -370,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 @@ -388,16 +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/NodeKernel.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs index 36ba2cbcf2..8626bf084f 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 @@ -292,7 +292,7 @@ initNodeKernel <&> \wd (_headers, lst) -> GSM.getDurationUntilTooOld wd (getTipSlot lst) , GSM.equivalent = (==) `on` (AF.headPoint . fst) - , GSM.getChainSyncStates = fmap cschState <$> cschcMap varChainSyncHandles + , GSM.getPeerStates = traverse (readTVar . cschState) =<< cschcMap varChainSyncHandles , GSM.getCurrentSelection = do headers <- ChainDB.getCurrentChainWithTime chainDB extLedgerState <- ChainDB.getCurrentLedger chainDB 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 44a57f4c32..8941958814 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/GSM.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/GSM.hs @@ -142,7 +142,7 @@ setupGsm isHaaSatisfied vars = do , 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/LoE/CaughtUp.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/LoE/CaughtUp.hs index a58923bd60..6ae1c4d0d4 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 @@ -283,7 +283,7 @@ mkGsmEntryPoints varChainSyncHandles chainDB writeGsmState = { 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. From ccc68e94e083740a662fd3a90161a715ebc91668 Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Thu, 9 Oct 2025 16:42:10 +0200 Subject: [PATCH 25/43] Store NodeToNodeVersion in GSM peer state components --- .../Ouroboros/Consensus/NodeKernel.hs | 2 +- .../Genesis/Tests/DensityDisconnect.hs | 2 ++ .../Consensus/Genesis/Tests/LoE/CaughtUp.hs | 10 ++++----- .../MiniProtocol/ChainSync/Client.hs | 1 + .../MiniProtocol/ChainSync/Client/State.hs | 6 ++++++ .../ObjectDiffusion/Inbound/State.hs | 21 ++++++++++++++----- .../Ouroboros/Consensus/Util/Orphans.hs | 4 ++++ 7 files changed, 35 insertions(+), 11 deletions(-) diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs index 8626bf084f..94618f9ebd 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,7 +27,7 @@ module Ouroboros.Consensus.NodeKernel , toConsensusMode ) where -import Cardano.Base.FeatureFlags (CardanoFeatureFlag) +import Cardano.Base.FeatureFlags (CardanoFeatureFlag (..)) import Cardano.Network.ConsensusMode (ConsensusMode (..)) import Cardano.Network.PeerSelection.Bootstrap (UseBootstrapPeers) import Cardano.Network.PeerSelection.LocalRootPeers 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 6ae1c4d0d4..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 @@ -142,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 @@ -169,7 +168,7 @@ run = withRegistry \registry -> do -- Finally, idle. atomically $ modifyTVar (cschState hdl) $ \s -> - ChainSyncState + s { csCandidate = csCandidate s , csLatestSlot = csLatestSlot s , csIdling = True @@ -223,6 +222,7 @@ mkTestChainSyncClientHandle frag = do { csCandidate = frag , csIdling = False , csLatestSlot = pure $ AF.headSlot frag + , csNodeToNodeVersion = maxBound } varJumping <- newTVar $ Disengaged DisengagedDone varJumpInfo <- newTVar Nothing 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 0c0d46c4ee..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 @@ -385,6 +385,7 @@ bracketChainSyncClient { csCandidate = AF.Empty AF.AnchorGenesis , csLatestSlot = SNothing , csIdling = False + , csNodeToNodeVersion = version } withCSJCallbacks :: 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/State.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Inbound/State.hs index 83d8d26c8f..58402da64f 100644 --- 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 @@ -24,6 +24,7 @@ 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 (..) @@ -39,7 +40,12 @@ import Ouroboros.Consensus.Util.IOLike -- NOTE: 'blk' is not needed for now, but we keep it for future use. data ObjectDiffusionInboundState blk = ObjectDiffusionInboundState { odisIdling :: !Bool - -- ^ Whether we have received all objects from a peer + -- ^ 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 @@ -49,8 +55,12 @@ deriving anyclass instance ) => NoThunks (ObjectDiffusionInboundState blk) -initObjectDiffusionInboundState :: ObjectDiffusionInboundState blk -initObjectDiffusionInboundState = ObjectDiffusionInboundState{odisIdling = True} +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 @@ -101,12 +111,13 @@ data ObjectDiffusionInboundStateView m = ObjectDiffusionInboundStateView 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 handles peer body = do - odiState <- newTVarIO initObjectDiffusionInboundState +bracketObjectDiffusionInbound version handles peer body = do + odiState <- newTVarIO (initObjectDiffusionInboundState version) bracket (acquireContext odiState) releaseContext body where acquireContext odiState = atomically $ do 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 -------------------------------------------------------------------------------} From ee039a1ce724690aab847de9ceeba64d8dcc70a4 Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Mon, 13 Oct 2025 10:40:42 +0200 Subject: [PATCH 26/43] Introduce O.C.Node.GSM.PeerState --- .../ouroboros-consensus-diffusion.cabal | 3 + .../Ouroboros/Consensus/Node/GSM/PeerState.hs | 78 +++++++++++++++++++ 2 files changed, 81 insertions(+) create mode 100644 ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/GSM/PeerState.hs diff --git a/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal b/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal index 0caddc634b..93eed1cb9d 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 @@ -98,8 +99,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/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) From f2e90d63d91f5f1d0c881147e569c867e69b3ba4 Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Mon, 13 Oct 2025 11:39:03 +0200 Subject: [PATCH 27/43] Enhance GSM view with PerasCertDiffusion information Conflicts: ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Inbound.hs --- .../Ouroboros/Consensus/Network/NodeToNode.hs | 35 ++++++++---- .../Ouroboros/Consensus/NodeKernel.hs | 56 ++++++++++++++----- .../MiniProtocol/ObjectDiffusion/Inbound.hs | 28 +++++++++- .../MiniProtocol/ObjectDiffusion/Smoke.hs | 10 ++++ 4 files changed, 101 insertions(+), 28 deletions(-) diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs index c96dc97e61..5868a75ca7 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 @@ -71,6 +71,10 @@ 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 @@ -214,6 +218,7 @@ data Handlers m addr blk = Handlers , hPerasCertDiffusionClient :: NodeToNodeVersion -> ControlMessageSTM m -> + ObjectDiffusionInboundStateView m -> ConnectionId addr -> PerasCertDiffusionInboundPipelined blk m () , hPerasCertDiffusionServer :: @@ -316,7 +321,7 @@ mkHandlers (mapTxSubmissionMempoolReader txForgetValidated $ getMempoolReader getMempool) (getMempoolWriter getMempool) version - , hPerasCertDiffusionClient = \version controlMessageSTM peer -> + , hPerasCertDiffusionClient = \version controlMessageSTM state peer -> objectDiffusionInbound (contramap (TraceLabelPeer peer) (Node.perasCertDiffusionInboundTracer tracers)) ( perasCertDiffusionMaxFifoLength miniProtocolParameters @@ -326,6 +331,7 @@ mkHandlers (makePerasCertPoolWriterFromChainDB $ getChainDB) version controlMessageSTM + state , hPerasCertDiffusionServer = \version peer -> objectDiffusionOutbound (contramap (TraceLabelPeer peer) (Node.perasCertDiffusionOutboundTracer tracers)) @@ -871,17 +877,22 @@ mkApps kernel rng Tracers{..} mkCodecs ByteLimits{..} chainSyncTimeouts lopBucke } channel = do labelThisThread "PerasCertDiffusionClient" - ((), trailing) <- - runPipelinedPeerWithLimits - (TraceLabelPeer them `contramap` tPerasCertDiffusionTracer) - (cPerasCertDiffusionCodec (mkCodecs version)) - blPerasCertDiffusion - timeLimitsObjectDiffusion - channel - ( objectDiffusionInboundPeerPipelined - (hPerasCertDiffusionClient version controlMessageSTM them) - ) - return (NoInitiatorResult, trailing) + 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 -> 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 94618f9ebd..19056ff638 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 @@ -50,7 +50,7 @@ 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 @@ -82,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 (..) @@ -175,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 @@ -235,6 +246,7 @@ initNodeKernel args@NodeKernelArgs { registry , cfg + , featureFlags , tracers , chainDB , initChainDB @@ -257,6 +269,7 @@ initNodeKernel , mempool , peerSharingRegistry , varChainSyncHandles + , varPerasCertDiffusionHandles , varGsmState } = st @@ -275,24 +288,34 @@ initNodeKernel GSM.GsmView { GSM.antiThunderingHerd = Just gsmAntiThunderingHerd , GSM.getCandidateOverSelection = do - weights <- ChainDB.getPerasWeightSnapshot chainDB - pure $ \(headers, _lst) state -> - case AF.intersectionPoint headers (csCandidate state) of - Nothing -> GSM.CandidateDoesNotIntersect - Just{} -> - GSM.WhetherCandidateIsBetter $ -- precondition requires intersection - preferAnchoredCandidate - (configBlock cfg) - (forgetFingerprint weights) - headers - (csCandidate state) - , GSM.peerIsIdle = csIdling + 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.getPeerStates = traverse (readTVar . cschState) =<< cschcMap varChainSyncHandles + , GSM.getPeerStates = + mkGsmPeerStates + varChainSyncHandles + varPerasCertDiffusionHandles , GSM.getCurrentSelection = do headers <- ChainDB.getCurrentChainWithTime chainDB extLedgerState <- ChainDB.getCurrentLedger chainDB @@ -369,6 +392,7 @@ initNodeKernel , getFetchMode = readFetchMode blockFetchInterface , getGsmState = readTVar varGsmState , getChainSyncHandles = varChainSyncHandles + , getPerasCertDiffusionHandles = varPerasCertDiffusionHandles , getPeerSharingRegistry = peerSharingRegistry , getTracers = tracers , setBlockForging = \a -> atomically . LazySTM.putTMVar blockForgingVar $! a @@ -419,6 +443,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 @@ -457,6 +483,8 @@ initInternalState newTVarIO gsmState varChainSyncHandles <- atomically newChainSyncClientHandleCollection + varPerasCertDiffusionHandles <- atomically newObjectDiffusionInboundHandleCollection + mempool <- openMempool registry 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 index f72299d0fe..9253f95638 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Inbound.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Inbound.hs @@ -38,7 +38,11 @@ import Data.Word (Word64) import GHC.Generics (Generic) import Network.TypedProtocol.Core (N (Z), Nat (..), natToInt) import NoThunks.Class (NoThunks (..)) +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.Consensus.Util.NormalForm.Invariant (noThunksInvariant) import Ouroboros.Network.ControlMessage import Ouroboros.Network.NodeToNode.Version (NodeToNodeVersion) @@ -63,6 +67,8 @@ data TraceObjectDiffusionInbound objectId object TraceObjectDiffusionInboundRecvControlMessage ControlMessage | TraceObjectDiffusionInboundCanRequestMoreObjects Int | TraceObjectDiffusionInboundCannotRequestMoreObjects Int + | TraceObjectDiffusionInboundStartedIdling + | TraceObjectDiffusionInboundStoppedIdling deriving (Eq, Show) data ObjectDiffusionInboundError @@ -132,13 +138,15 @@ objectDiffusionInbound :: ObjectPoolWriter objectId object m -> NodeToNodeVersion -> ControlMessageSTM m -> + ObjectDiffusionInboundStateView m -> ObjectDiffusionInboundPipelined objectId object m () objectDiffusionInbound tracer (maxFifoLength, maxNumIdsToReq, maxNumObjectsToReq) ObjectPoolWriter{..} _version - controlMessageSTM = + controlMessageSTM + state = ObjectDiffusionInboundPipelined $! checkState initialInboundSt & go Zero where @@ -252,6 +260,13 @@ objectDiffusionInbound -- blocking call. traceWith tracer $ TraceObjectDiffusionInboundCannotRequestMoreObjects (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 $ + TraceObjectDiffusionInboundStartedIdling pure $! checkState st & goReqObjectIdsBlocking -- We have pipelined some requests, so there are some replies in flight. @@ -400,7 +415,16 @@ objectDiffusionInbound (numToAckOnNextReq st) numIdsToRequest ( \neCollectedIds -> - checkState st' & goCollect Zero (CollectObjectIds numIdsToRequest (NonEmpty.toList neCollectedIds)) + WithEffect $ 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 $ + TraceObjectDiffusionInboundStoppedIdling + pure $ + checkState st' & goCollect Zero (CollectObjectIds numIdsToRequest (NonEmpty.toList neCollectedIds)) ) goReqObjectsAndObjectIdsPipelined :: 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 index d2f21c9b66..8e12f01d6d 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/Smoke.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/Smoke.hs @@ -31,11 +31,15 @@ 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 (..) @@ -257,6 +261,11 @@ prop_smoke_object_diffusion controlMessage <- uncheckedNewTVarM Continue let + inboundState = + ObjectDiffusionInboundStateView + { odisvIdling = Idling.noIdling + } + inbound = objectDiffusionInbound tracer @@ -267,6 +276,7 @@ prop_smoke_object_diffusion inboundPoolWriter nodeToNodeVersion (readTVar controlMessage) + inboundState outbound = objectDiffusionOutbound From d5a82bb7864c346590179ee6362dfcfe73b52f36 Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Wed, 15 Oct 2025 09:21:38 +0200 Subject: [PATCH 28/43] Define WithArrivalTime combinator --- .../BlockchainTime/WallClock/Types.hs | 26 +++++++++++++++++++ 1 file changed, 26 insertions(+) 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) From 50bcedec226d2f5bf43aa864767558512950d8f2 Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Wed, 15 Oct 2025 12:14:51 +0200 Subject: [PATCH 29/43] Tweak and extend Peras cert field projection typeclasses --- .../Consensus/Block/SupportsPeras.hs | 32 ++++++++++++------- 1 file changed, 21 insertions(+), 11 deletions(-) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs index 030ab9d7e2..4e73af6213 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs @@ -3,8 +3,8 @@ {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -38,6 +38,7 @@ 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 (..)) @@ -166,20 +167,29 @@ makePerasCfg _ = { perasCfgWeightBoost = boostPerCert } -class StandardHash blk => HasPerasCert cert blk where - getPerasCert :: cert blk -> PerasCert blk +class StandardHash blk => HasPerasCert cert blk | cert -> blk where + getPerasCert :: cert -> PerasCert blk -instance StandardHash blk => HasPerasCert PerasCert blk where +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 where +instance StandardHash blk => HasPerasCert (ValidatedPerasCert blk) blk where getPerasCert = vpcCert -getPerasCertRound :: HasPerasCert cert blk => cert blk -> PerasRoundNo -getPerasCertRound = pcCertRound . getPerasCert +instance HasPerasCert cert blk => HasPerasCert (WithArrivalTime cert) blk where + getPerasCert = getPerasCert . forgetArrivalTime -getPerasCertBoostedBlock :: HasPerasCert cert blk => cert blk -> Point blk -getPerasCertBoostedBlock = pcCertBoostedBlock . getPerasCert +class HasPerasCertBoost cert blk | cert -> blk where + getPerasCertBoost :: cert -> PerasWeight + +instance HasPerasCertBoost (ValidatedPerasCert blk) blk where + getPerasCertBoost = vpcCertBoost -getPerasCertBoost :: ValidatedPerasCert blk -> PerasWeight -getPerasCertBoost = vpcCertBoost +instance HasPerasCertBoost cert blk => HasPerasCertBoost (WithArrivalTime cert) blk where + getPerasCertBoost = getPerasCertBoost . forgetArrivalTime From 437f9725e705dc9b00a14d2b0a46444dcfa054eb Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Wed, 15 Oct 2025 12:25:09 +0200 Subject: [PATCH 30/43] Wrap validated Peras certificates with arrival time Conflicts: ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasCert.hs ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/API.hs ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/Model.hs --- .../Ouroboros/Consensus/Network/NodeToNode.hs | 3 +- .../Ouroboros/Consensus/Node.hs | 4 ++ .../Ouroboros/Consensus/NodeKernel.hs | 1 + .../Test/ThreadNet/Network.hs | 1 + .../ObjectDiffusion/ObjectPool/PerasCert.hs | 43 ++++++++++++++----- .../Consensus/Storage/ChainDB/API.hs | 5 ++- .../Storage/ChainDB/Impl/ChainSel.hs | 3 +- .../Consensus/Storage/ChainDB/Impl/Types.hs | 5 ++- .../Consensus/Storage/PerasCertDB/API.hs | 7 ++- .../Consensus/Storage/PerasCertDB/Impl.hs | 7 +-- .../Test/Util/Orphans/ToExpr.hs | 5 +++ .../ObjectDiffusion/PerasCert/Smoke.hs | 36 +++++++++++++--- .../Test/Ouroboros/Storage/ChainDB/Model.hs | 5 ++- .../Ouroboros/Storage/ChainDB/StateMachine.hs | 41 ++++++++++++------ .../Test/Ouroboros/Storage/Orphans.hs | 10 +++++ .../Ouroboros/Storage/PerasCertDB/Model.hs | 9 ++-- .../Storage/PerasCertDB/StateMachine.hs | 38 +++++++++++----- 17 files changed, 164 insertions(+), 59 deletions(-) diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs index 5868a75ca7..964a823c53 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 @@ -269,6 +269,7 @@ mkHandlers , keepAliveRng , miniProtocolParameters , getDiffusionPipeliningSupport + , systemTime } NodeKernel { getChainDB @@ -328,7 +329,7 @@ mkHandlers , 10 -- TODO: see https://github.com/tweag/cardano-peras/issues/97 , 10 -- TODO: see https://github.com/tweag/cardano-peras/issues/97 ) - (makePerasCertPoolWriterFromChainDB $ getChainDB) + (makePerasCertPoolWriterFromChainDB systemTime getChainDB) version controlMessageSTM state 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 fc7242de91..4c9d062b7d 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 @@ -580,6 +580,7 @@ runWith RunNodeArgs{..} encAddrNtN decAddrNtN LowLevelRunNodeArgs{..} = llrnFeatureFlags rnTraceConsensus btime + systemTime (InFutureCheck.realHeaderInFutureCheck llrnMaxClockSkew systemTime) historicityCheck chainDB @@ -858,6 +859,7 @@ mkNodeKernelArgs :: 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 -> @@ -878,6 +880,7 @@ mkNodeKernelArgs featureFlags tracers btime + systemTime chainSyncFutureCheck chainSyncHistoricityCheck chainDB @@ -897,6 +900,7 @@ mkNodeKernelArgs , cfg , featureFlags , btime + , systemTime , chainDB , initChainDB = nodeInitChainDB , chainSyncFutureCheck 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 19056ff638..e9d74bc897 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 @@ -210,6 +210,7 @@ data NodeKernelArgs m addrNTN addrNTC blk = NodeKernelArgs , 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 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 6bd6d9bde4..7af3bedbe9 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 @@ -1047,6 +1047,7 @@ runThreadNetwork , cfg = pInfoConfig , featureFlags = mempty , btime + , systemTime , chainDB , initChainDB = nodeInitChainDB , chainSyncFutureCheck = diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasCert.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasCert.hs index 1e9e966341..a7cccb4ee6 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasCert.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasCert.hs @@ -11,9 +11,12 @@ module Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.PerasCert , makePerasCertPoolWriterFromChainDB ) where +import Control.Monad ((>=>)) import qualified Data.Map as Map 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 @@ -52,13 +55,13 @@ makePerasCertPoolReaderFromCertDB perasCertDB = makePerasCertPoolWriterFromCertDB :: (StandardHash blk, IOLike m) => - PerasCertDB m blk -> ObjectPoolWriter PerasRoundNo (PerasCert blk) m -makePerasCertPoolWriterFromCertDB perasCertDB = + SystemTime m -> + PerasCertDB m blk -> + ObjectPoolWriter PerasRoundNo (PerasCert blk) m +makePerasCertPoolWriterFromCertDB systemTime perasCertDB = ObjectPoolWriter { opwObjectId = getPerasCertRound - , opwAddObjects = \certs -> do - validatePerasCerts certs - >>= mapM_ (PerasCertDB.addCert perasCertDB) + , opwAddObjects = addPerasCerts systemTime (PerasCertDB.addCert perasCertDB) , opwHasObject = do certSnapshot <- PerasCertDB.getCertSnapshot perasCertDB pure $ PerasCertDB.containsCert certSnapshot @@ -72,13 +75,13 @@ makePerasCertPoolReaderFromChainDB chainDB = makePerasCertPoolWriterFromChainDB :: (StandardHash blk, IOLike m) => - ChainDB m blk -> ObjectPoolWriter PerasRoundNo (PerasCert blk) m -makePerasCertPoolWriterFromChainDB chainDB = + SystemTime m -> + ChainDB m blk -> + ObjectPoolWriter PerasRoundNo (PerasCert blk) m +makePerasCertPoolWriterFromChainDB systemTime chainDB = ObjectPoolWriter { opwObjectId = getPerasCertRound - , opwAddObjects = \certs -> do - validatePerasCerts certs - >>= mapM_ (ChainDB.addPerasCertAsync chainDB) + , opwAddObjects = addPerasCerts systemTime (ChainDB.addPerasCertAsync chainDB) , opwHasObject = do certSnapshot <- ChainDB.getPerasCertSnapshot chainDB pure $ PerasCertDB.containsCert certSnapshot @@ -106,3 +109,23 @@ validatePerasCerts certs = do 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/Storage/ChainDB/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs index 8b89764c2c..99d5d46e1e 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 @@ -81,6 +81,7 @@ 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 (..) ) @@ -396,7 +397,7 @@ data ChainDB m blk = ChainDB , getStatistics :: m (Maybe Statistics) -- ^ Get statistics from the LedgerDB, in particular the number of entries -- in the tables. - , addPerasCertAsync :: ValidatedPerasCert blk -> m (AddPerasCertPromise m) + , addPerasCertAsync :: WithArrivalTime (ValidatedPerasCert blk) -> m (AddPerasCertPromise m) -- ^ Asynchronously insert a certificate to the DB. If this leads to a fork to -- be weightier than our current selection, this will trigger a fork switch. , getPerasWeightSnapshot :: STM m (WithFingerprint (PerasWeightSnapshot blk)) @@ -537,7 +538,7 @@ newtype AddPerasCertPromise m = AddPerasCertPromise -- impossible). } -addPerasCertSync :: IOLike m => ChainDB m blk -> ValidatedPerasCert blk -> m () +addPerasCertSync :: IOLike m => ChainDB m blk -> WithArrivalTime (ValidatedPerasCert blk) -> m () addPerasCertSync chainDB cert = waitPerasCertProcessed =<< addPerasCertAsync chainDB cert 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 5278133580..0559fbecb0 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 @@ -45,6 +45,7 @@ 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 @@ -328,7 +329,7 @@ addPerasCertAsync :: forall m blk. (IOLike m, HasHeader blk) => ChainDbEnv m blk -> - ValidatedPerasCert blk -> + WithArrivalTime (ValidatedPerasCert blk) -> m (AddPerasCertPromise m) addPerasCertAsync CDB{cdbTracer, cdbChainSelQueue} = addPerasCertToQueue (TraceAddPerasCertEvent >$< cdbTracer) cdbChainSelQueue 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 3336ba527f..482f0968f7 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 @@ -94,6 +94,7 @@ 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 (..)) @@ -553,7 +554,7 @@ data ChainSelMessage m blk ChainSelAddBlock !(BlockToAdd m blk) | -- | Add a Peras certificate ChainSelAddPerasCert - !(ValidatedPerasCert blk) + !(WithArrivalTime (ValidatedPerasCert blk)) -- | Used for 'AddPerasCertPromise'. !(StrictTMVar m ()) | -- | Reprocess blocks that have been postponed by the LoE. @@ -609,7 +610,7 @@ addPerasCertToQueue :: (IOLike m, StandardHash blk) => Tracer m (TraceAddPerasCertEvent blk) -> ChainSelQueue m blk -> - ValidatedPerasCert blk -> + WithArrivalTime (ValidatedPerasCert blk) -> m (AddPerasCertPromise m) addPerasCertToQueue tracer ChainSelQueue{varChainSelQueue} cert = do varProcessed <- newEmptyTMVarIO diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/API.hs index 873ebe29f9..6d992b4b42 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/API.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/API.hs @@ -17,12 +17,13 @@ import Data.Map (Map) 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 :: ValidatedPerasCert blk -> m AddPerasCertResult + { addCert :: WithArrivalTime (ValidatedPerasCert blk) -> m AddPerasCertResult -- ^ Add a Peras certificate to the database. The result indicates whether -- the certificate was actually added, or if it was already present. , getWeightSnapshot :: STM m (WithFingerprint (PerasWeightSnapshot blk)) @@ -46,7 +47,9 @@ data AddPerasCertResult = AddedPerasCertToDB | PerasCertAlreadyInDB data PerasCertSnapshot blk = PerasCertSnapshot { containsCert :: PerasRoundNo -> Bool -- ^ Do we have the certificate for this round? - , getCertsAfter :: PerasCertTicketNo -> Map PerasCertTicketNo (ValidatedPerasCert blk) + , getCertsAfter :: + PerasCertTicketNo -> + Map PerasCertTicketNo (WithArrivalTime (ValidatedPerasCert blk)) -- ^ Get certificates after the given ticket number (excluded). -- The result is a map of ticket numbers to validated certificates. } diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs index e8738ad0b7..c6ea5ee38f 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs @@ -32,6 +32,7 @@ import qualified Data.Set as Set 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 @@ -152,7 +153,7 @@ implAddCert :: , StandardHash blk ) => PerasCertDbEnv m blk -> - ValidatedPerasCert blk -> + WithArrivalTime (ValidatedPerasCert blk) -> m AddPerasCertResult implAddCert env cert = do traceWith pcdbTracer $ AddingPerasCert roundNo boostedPt @@ -255,13 +256,13 @@ implGarbageCollect PerasCertDbEnv{pcdbVolatileState} slot = -- -- INVARIANT: See 'invariantForPerasVolatileCertState'. data PerasVolatileCertState blk = PerasVolatileCertState - { pvcsCerts :: !(Map PerasRoundNo (ValidatedPerasCert blk)) + { 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 (ValidatedPerasCert blk)) + , pvcsCertsByTicket :: !(Map PerasCertTicketNo (WithArrivalTime (ValidatedPerasCert blk))) -- ^ The certificates by 'PerasCertTicketNo'. -- -- INVARIANT: In sync with 'pvcsCerts'. 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 e5560f70f8..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 @@ -127,6 +130,8 @@ 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/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasCert/Smoke.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasCert/Smoke.hs index 72ac5217f7..68ce4e37f9 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasCert/Smoke.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasCert/Smoke.hs @@ -15,6 +15,12 @@ import qualified Data.List.NonEmpty as NE import qualified Data.Map as Map 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 @@ -24,7 +30,7 @@ import Ouroboros.Consensus.Storage.PerasCertDB.API ) import qualified Ouroboros.Consensus.Storage.PerasCertDB.API as PerasCertDB import qualified Ouroboros.Consensus.Storage.PerasCertDB.Impl as PerasCertDB -import Ouroboros.Consensus.Util.IOLike +import Ouroboros.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 @@ -77,9 +83,24 @@ instance Arbitrary (Point blk) => Arbitrary (PerasCert blk) where 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 -> [PerasCert blk] -> m (PerasCertDB m blk) -newCertDB perasCfg certs = do + (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 @@ -88,7 +109,7 @@ newCertDB perasCfg certs = do { vpcCert = cert , vpcCertBoost = perasCfgWeightBoost perasCfg } - result <- PerasCertDB.addCert db validatedCert + result <- PerasCertDB.addCert db =<< addArrivalTime systemTime validatedCert case result of AddedPerasCertToDB -> pure () PerasCertAlreadyInDB -> throwIO (userError "Expected AddedPerasCertToDB, but cert was already in DB") @@ -123,11 +144,12 @@ prop_smoke protocolConstants (ListWithUniqueIds certs) = , m [PerasCert TestBlock] ) mkPoolInterfaces = do - outboundPool <- newCertDB perasTestCfg certs - inboundPool <- newCertDB perasTestCfg [] + systemTime <- mockSystemTime + outboundPool <- newCertDB perasTestCfg systemTime certs + inboundPool <- newCertDB perasTestCfg systemTime [] let outboundPoolReader = makePerasCertPoolReaderFromCertDB outboundPool - inboundPoolWriter = makePerasCertPoolWriterFromCertDB inboundPool + inboundPoolWriter = makePerasCertPoolWriterFromCertDB systemTime inboundPool getAllInboundPoolContent = do snap <- atomically $ PerasCertDB.getCertSnapshot inboundPool let rawContent = 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 910c7e1130..22cff44b75 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 @@ -104,6 +104,7 @@ import qualified Data.Set as Set import Data.TreeDiff 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 @@ -148,7 +149,7 @@ data Model blk = Model -- ^ The VolatileDB , immutableDbChain :: Chain blk -- ^ The ImmutableDB - , perasCerts :: Map PerasRoundNo (ValidatedPerasCert blk) + , perasCerts :: Map PerasRoundNo (WithArrivalTime (ValidatedPerasCert blk)) , cps :: CPS.ChainProducerState blk , currentLedger :: ExtLedgerState blk EmptyMK , initLedger :: ExtLedgerState blk EmptyMK @@ -445,7 +446,7 @@ addPerasCert :: forall blk. (LedgerSupportsProtocol blk, LedgerTablesAreTrivial (ExtLedgerState blk)) => TopLevelConfig blk -> - ValidatedPerasCert blk -> + WithArrivalTime (ValidatedPerasCert blk) -> Model blk -> Model blk addPerasCert cfg cert m 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 7e0bd33edc..ae13975a3e 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 @@ -97,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 @@ -189,7 +195,7 @@ data Cmd blk it flr = -- | 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 (ValidatedPerasCert blk) (Persistent [blk]) + AddPerasCert (WithArrivalTime (ValidatedPerasCert blk)) (Persistent [blk]) | GetCurrentChain | GetTipBlock | GetTipHeader @@ -1090,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 @@ -1137,21 +1148,23 @@ generator loe genBlock m@Model{..} = [ (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 - ( ValidatedPerasCert - { vpcCert = - PerasCert - { pcCertRound = roundNo - , pcCertBoostedBlock = blockPoint blk - } - , vpcCertBoost = boost - } - ) - seenBlks + pure $ AddPerasCert validatedCert seenBlks genBounds :: Gen (StreamFrom blk, StreamTo blk) genBounds = 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/Model.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/Model.hs index 9808ffe21c..29f916b7a2 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/Model.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/Model.hs @@ -19,13 +19,14 @@ 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 (ValidatedPerasCert blk) + { certs :: Set (WithArrivalTime (ValidatedPerasCert blk)) , open :: Bool } deriving Generic @@ -43,15 +44,15 @@ closeDB _ = Model{open = False, certs = Set.empty} addCert :: StandardHash blk => - Model blk -> ValidatedPerasCert blk -> Model blk + Model blk -> WithArrivalTime (ValidatedPerasCert blk) -> Model blk addCert model@Model{certs} cert | certs `hasRoundNo` cert = model | otherwise = model{certs = Set.insert cert certs} hasRoundNo :: StandardHash blk => - Set (ValidatedPerasCert blk) -> - ValidatedPerasCert blk -> + Set (WithArrivalTime (ValidatedPerasCert blk)) -> + WithArrivalTime (ValidatedPerasCert blk) -> Bool hasRoundNo certs cert = (getPerasCertRound cert) `Set.member` (Set.map getPerasCertRound certs) diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs index 4e64ad18fe..d930acb466 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs @@ -9,6 +9,7 @@ {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} @@ -23,12 +24,21 @@ import Control.Tracer (nullTracer) import Data.Function ((&)) 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 @@ -60,7 +70,7 @@ instance StateModel Model where data Action Model a where OpenDB :: Action Model () CloseDB :: Action Model () - AddCert :: ValidatedPerasCert TestBlock -> Action Model AddPerasCertResult + AddCert :: WithArrivalTime (ValidatedPerasCert TestBlock) -> Action Model AddPerasCertResult GetWeightSnapshot :: Action Model (PerasWeightSnapshot TestBlock) GarbageCollect :: SlotNo -> Action Model () @@ -74,19 +84,25 @@ instance StateModel Model where ] | 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 <- genRoundNo boostedBlock <- genPoint - pure $ - AddCert - ValidatedPerasCert - { vpcCert = - PerasCert - { pcCertRound = roundNo - , pcCertBoostedBlock = boostedBlock - } - , vpcCertBoost = perasCfgWeightBoost perasTestCfg - } + systemTime <- genSystemTime + let validatedCert = + ValidatedPerasCert + { vpcCert = + PerasCert + { pcCertRound = roundNo + , pcCertBoostedBlock = boostedBlock + } + , vpcCertBoost = perasCfgWeightBoost perasTestCfg + } + AddCert <$> addArrivalTime systemTime validatedCert -- Generators are heavily skewed toward collisions, to get equivocating certificates -- and certificates boosting the same block From a38b664d9fb3335b981a5efeb4d9f1909aa864e7 Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Wed, 29 Oct 2025 13:59:28 +0100 Subject: [PATCH 31/43] Revert "Peras.SelectView: use fragment length instead of tip `BlockNo`" This reverts commit 591445ee8f12604bfd7ec6e910cc1da3c76ff96d. --- .../Ouroboros/Consensus/Peras/SelectView.hs | 16 +++++----------- 1 file changed, 5 insertions(+), 11 deletions(-) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/SelectView.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/SelectView.hs index ae7b8d9eb5..04e4eed8ea 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/SelectView.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/SelectView.hs @@ -2,7 +2,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} @@ -21,7 +20,6 @@ module Ouroboros.Consensus.Peras.SelectView ) where import Data.Function (on) -import Data.Word (Word64) import Ouroboros.Consensus.Block import Ouroboros.Consensus.Peras.Weight import Ouroboros.Consensus.Protocol.Abstract @@ -39,12 +37,8 @@ import qualified Ouroboros.Network.AnchoredFragment as AF -- as the fragments might not intersect, and so some blocks after their -- intersection (and hence their weight boost) are unknown. 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. + { wsvBlockNo :: !BlockNo + -- ^ The 'BlockNo' at the tip of a fragment. , wsvWeightBoost :: !PerasWeight -- ^ The weight boost of a fragment (w.r.t. a particular anchor). , wsvTiebreaker :: TiebreakerView proto @@ -58,11 +52,11 @@ deriving stock instance Eq (TiebreakerView proto) => Eq (WeightedSelectView prot -- 'WeightedSelectView's obtained from fragments with different anchors? -- Something ST-trick like? --- | The total weight, ie the sum of 'wsvLength' and 'wsvBoostedWeight'. +-- | The total weight, ie the sum of 'wsvBlockNo' 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 + PerasWeight (unBlockNo (wsvBlockNo wsv)) <> wsvWeightBoost wsv instance Ord (TiebreakerView proto) => Ord (WeightedSelectView proto) where compare = @@ -100,7 +94,7 @@ weightedSelectView bcfg weights = \case frag@(_ AF.:> (getHeader1 -> hdr)) -> NonEmptyFragment WeightedSelectView - { wsvLength = fromIntegral @Int @Word64 $ AF.length frag + { wsvBlockNo = blockNo hdr , wsvWeightBoost = weightBoostOfFragment weights frag , wsvTiebreaker = tiebreakerView bcfg hdr } From b51669db6dfad7bbfec2c49e0e0338cf17d6df3b Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Wed, 29 Oct 2025 14:35:51 +0100 Subject: [PATCH 32/43] Disable EBB generation in ChainDB q-s-m tests when k>2 --- .../Test/Ouroboros/Storage/ChainDB/StateMachine.hs | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) 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 ae13975a3e..8779a13f2f 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 @@ -1608,7 +1608,16 @@ genBlk chunkInfo Model{..} = noSavedGapBlocks = Map.null savedGapBlocks withoutGapBlocks = fmap (,Persistent []) - modelSupportsEBBs = ImmutableDB.chunkInfoSupportsEBBs chunkInfo + k = unNonZero (maxRollbacks (configSecurityParam (unOpaque modelConfig))) + + modelSupportsEBBs = + ImmutableDB.chunkInfoSupportsEBBs chunkInfo + -- NOTE: we disable the generation of EBBs entirely when k>2 to avoid + -- triggering an edge case caused by a mismatch between the model and + -- actual the implementation. For more information, see: + -- https://github.com/IntersectMBO/ouroboros-consensus/issues/1745 + && k <= 2 + canContainEBB = const modelSupportsEBBs -- TODO: we could be more precise genBody :: Gen TestBody genBody = do From 5da78b61cb76623b5ea1fe43cca994e2cb5bc47d Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Mon, 27 Oct 2025 09:58:29 +0100 Subject: [PATCH 33/43] Simplify HasPerasCertX field accessors Conflicts: ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasCert.hs ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasCert/Smoke.hs --- .../Consensus/Block/SupportsPeras.hs | 55 ++++++++++++------- .../ObjectDiffusion/ObjectPool/PerasCert.hs | 14 +++-- .../Storage/ChainDB/Impl/ChainSel.hs | 2 +- .../Consensus/Storage/ChainDB/Impl/Types.hs | 2 +- .../Consensus/Storage/PerasCertDB/Impl.hs | 2 +- .../ObjectDiffusion/PerasCert/Smoke.hs | 3 +- .../Ouroboros/Storage/PerasCertDB/Model.hs | 3 +- 7 files changed, 51 insertions(+), 30 deletions(-) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs index 4e73af6213..bcc0e752b2 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs @@ -19,10 +19,9 @@ module Ouroboros.Consensus.Block.SupportsPeras , PerasCfg (..) , ValidatedPerasCert (..) , makePerasCfg - , HasPerasCert (..) - , getPerasCertRound - , getPerasCertBoostedBlock - , getPerasCertBoost + , HasPerasCertRound (..) + , HasPerasCertBoostedBlock (..) + , HasPerasCertBoost (..) -- * Ouroboros Peras round length , PerasRoundLength (..) @@ -167,29 +166,47 @@ makePerasCfg _ = { perasCfgWeightBoost = boostPerCert } -class StandardHash blk => HasPerasCert cert blk | cert -> blk where - getPerasCert :: cert -> PerasCert blk +-- | Extract the certificate round from a Peras certificate container +class HasPerasCertRound cert where + getPerasCertRound :: cert -> PerasRoundNo -getPerasCertRound :: HasPerasCert cert blk => cert -> PerasRoundNo -getPerasCertRound = pcCertRound . getPerasCert +instance HasPerasCertRound (PerasCert blk) where + getPerasCertRound = pcCertRound -getPerasCertBoostedBlock :: HasPerasCert cert blk => cert -> Point blk -getPerasCertBoostedBlock = pcCertBoostedBlock . getPerasCert +instance HasPerasCertRound (ValidatedPerasCert blk) where + getPerasCertRound = getPerasCertRound . vpcCert -instance StandardHash blk => HasPerasCert (PerasCert blk) blk where - getPerasCert = id +instance + HasPerasCertRound cert => + HasPerasCertRound (WithArrivalTime cert) + where + getPerasCertRound = getPerasCertRound . forgetArrivalTime + +-- | Extract the boosted block point from a Peras certificate container +class HasPerasCertBoostedBlock cert blk | cert -> blk where + getPerasCertBoostedBlock :: cert -> Point blk -instance StandardHash blk => HasPerasCert (ValidatedPerasCert blk) blk where - getPerasCert = vpcCert +instance HasPerasCertBoostedBlock (PerasCert blk) blk where + getPerasCertBoostedBlock = pcCertBoostedBlock -instance HasPerasCert cert blk => HasPerasCert (WithArrivalTime cert) blk where - getPerasCert = getPerasCert . forgetArrivalTime +instance HasPerasCertBoostedBlock (ValidatedPerasCert blk) blk where + getPerasCertBoostedBlock = getPerasCertBoostedBlock . vpcCert -class HasPerasCertBoost cert blk | cert -> blk where +instance + HasPerasCertBoostedBlock cert blk => + HasPerasCertBoostedBlock (WithArrivalTime cert) blk + where + getPerasCertBoostedBlock = getPerasCertBoostedBlock . forgetArrivalTime + +-- | Extract the certificate boost from a Peras certificate container +class HasPerasCertBoost cert where getPerasCertBoost :: cert -> PerasWeight -instance HasPerasCertBoost (ValidatedPerasCert blk) blk where +instance HasPerasCertBoost (ValidatedPerasCert blk) where getPerasCertBoost = vpcCertBoost -instance HasPerasCertBoost cert blk => HasPerasCertBoost (WithArrivalTime cert) blk where +instance + HasPerasCertBoost cert => + HasPerasCertBoost (WithArrivalTime cert) + where getPerasCertBoost = getPerasCertBoost . forgetArrivalTime diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasCert.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasCert.hs index a7cccb4ee6..fa70be56a7 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasCert.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasCert.hs @@ -16,7 +16,11 @@ import qualified Data.Map as Map import GHC.Exception (throw) import Ouroboros.Consensus.Block import Ouroboros.Consensus.BlockchainTime (WithArrivalTime) -import Ouroboros.Consensus.BlockchainTime.WallClock.Types (SystemTime (..), addArrivalTime) +import Ouroboros.Consensus.BlockchainTime.WallClock.Types + ( SystemTime (..) + , WithArrivalTime (..) + , addArrivalTime + ) import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API import Ouroboros.Consensus.Storage.ChainDB.API (ChainDB) import qualified Ouroboros.Consensus.Storage.ChainDB.API as ChainDB @@ -29,7 +33,7 @@ import qualified Ouroboros.Consensus.Storage.PerasCertDB.API as PerasCertDB import Ouroboros.Consensus.Util.IOLike makePerasCertPoolReaderFromSnapshot :: - (IOLike m, StandardHash blk) => + IOLike m => STM m (PerasCertSnapshot blk) -> ObjectPoolReader PerasRoundNo (PerasCert blk) PerasCertTicketNo m makePerasCertPoolReaderFromSnapshot getCertSnapshot = @@ -40,7 +44,7 @@ makePerasCertPoolReaderFromSnapshot getCertSnapshot = certSnapshot <- getCertSnapshot pure $ take (fromIntegral limit) $ - [ (ticketNo, getPerasCertRound cert, pure (getPerasCert cert)) + [ (ticketNo, getPerasCertRound cert, pure (vpcCert (forgetArrivalTime cert))) | (ticketNo, cert) <- Map.toAscList $ PerasCertDB.getCertsAfter certSnapshot lastKnown @@ -48,7 +52,7 @@ makePerasCertPoolReaderFromSnapshot getCertSnapshot = } makePerasCertPoolReaderFromCertDB :: - (IOLike m, StandardHash blk) => + IOLike m => PerasCertDB m blk -> ObjectPoolReader PerasRoundNo (PerasCert blk) PerasCertTicketNo m makePerasCertPoolReaderFromCertDB perasCertDB = makePerasCertPoolReaderFromSnapshot (PerasCertDB.getCertSnapshot perasCertDB) @@ -68,7 +72,7 @@ makePerasCertPoolWriterFromCertDB systemTime perasCertDB = } makePerasCertPoolReaderFromChainDB :: - (IOLike m, StandardHash blk) => + IOLike m => ChainDB m blk -> ObjectPoolReader PerasRoundNo (PerasCert blk) PerasCertTicketNo m makePerasCertPoolReaderFromChainDB chainDB = makePerasCertPoolReaderFromSnapshot (ChainDB.getPerasCertSnapshot chainDB) 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 0559fbecb0..a032a268d6 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 @@ -327,7 +327,7 @@ addBlockAsync CDB{cdbTracer, cdbChainSelQueue} = addPerasCertAsync :: forall m blk. - (IOLike m, HasHeader blk) => + IOLike m => ChainDbEnv m blk -> WithArrivalTime (ValidatedPerasCert blk) -> m (AddPerasCertPromise m) 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 482f0968f7..71f836f487 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 @@ -607,7 +607,7 @@ addBlockToAdd tracer (ChainSelQueue{varChainSelQueue, varChainSelPoints}) punish -- | Add a Peras certificate to the background queue. addPerasCertToQueue :: - (IOLike m, StandardHash blk) => + IOLike m => Tracer m (TraceAddPerasCertEvent blk) -> ChainSelQueue m blk -> WithArrivalTime (ValidatedPerasCert blk) -> diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs index c6ea5ee38f..90277d4a0c 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs @@ -222,7 +222,7 @@ implGetCertSnapshot PerasCertDbEnv{pcdbVolatileState} = implGarbageCollect :: forall m blk. - (IOLike m, StandardHash blk) => + IOLike m => PerasCertDbEnv m blk -> SlotNo -> m () implGarbageCollect PerasCertDbEnv{pcdbVolatileState} slot = -- No need to update the 'Fingerprint' as we only remove certificates that do diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasCert/Smoke.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasCert/Smoke.hs index 68ce4e37f9..8779ea0947 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasCert/Smoke.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasCert/Smoke.hs @@ -18,6 +18,7 @@ import Ouroboros.Consensus.Block.SupportsPeras import Ouroboros.Consensus.BlockchainTime.WallClock.Types ( RelativeTime (..) , SystemTime (..) + , WithArrivalTime (..) , addArrivalTime , systemTimeCurrent ) @@ -155,6 +156,6 @@ prop_smoke protocolConstants (ListWithUniqueIds certs) = let rawContent = Map.toAscList $ PerasCertDB.getCertsAfter snap (PerasCertDB.zeroPerasCertTicketNo) - pure $ getPerasCert . snd <$> rawContent + pure $ vpcCert . forgetArrivalTime . snd <$> rawContent return (outboundPoolReader, inboundPoolWriter, getAllInboundPoolContent) diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/Model.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/Model.hs index 29f916b7a2..8e48d8b91f 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/Model.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/Model.hs @@ -50,7 +50,6 @@ addCert model@Model{certs} cert | otherwise = model{certs = Set.insert cert certs} hasRoundNo :: - StandardHash blk => Set (WithArrivalTime (ValidatedPerasCert blk)) -> WithArrivalTime (ValidatedPerasCert blk) -> Bool @@ -66,7 +65,7 @@ getWeightSnapshot Model{certs} = | cert <- Set.toList certs ] -garbageCollect :: StandardHash blk => SlotNo -> Model blk -> Model blk +garbageCollect :: SlotNo -> Model blk -> Model blk garbageCollect slot model@Model{certs} = model{certs = Set.filter keepCert certs} where From 3c34b719a8a0f3f68f7fe42227b8aaec015fd8a7 Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Mon, 27 Oct 2025 10:05:57 +0100 Subject: [PATCH 34/43] Add onPerasRoundNo helper and Num instance --- .../Ouroboros/Consensus/Block/SupportsPeras.hs | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs index bcc0e752b2..a1a468ee8b 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs @@ -13,6 +13,7 @@ module Ouroboros.Consensus.Block.SupportsPeras ( PerasRoundNo (..) + , onPerasRoundNo , PerasWeight (..) , BlockSupportsPeras (..) , PerasCert (..) @@ -31,6 +32,7 @@ module Ouroboros.Consensus.Block.SupportsPeras import Codec.Serialise (Serialise (..)) import Codec.Serialise.Decoding (decodeListLenOf) import Codec.Serialise.Encoding (encodeListLen) +import Data.Coerce (coerce) import Data.Monoid (Sum (..)) import Data.Proxy (Proxy (..)) import Data.Word (Word64) @@ -45,7 +47,7 @@ import Quiet (Quiet (..)) newtype PerasRoundNo = PerasRoundNo {unPerasRoundNo :: Word64} deriving Show via Quiet PerasRoundNo deriving stock Generic - deriving newtype (Enum, Eq, Ord, NoThunks, Serialise) + deriving newtype (Enum, Eq, Ord, Num, Bounded, NoThunks, Serialise) instance Condense PerasRoundNo where condense = show . unPerasRoundNo @@ -53,6 +55,12 @@ instance Condense PerasRoundNo where instance ShowProxy PerasRoundNo where showProxy _ = "PerasRoundNo" +-- | Lift a binary operation on 'Word64' to 'PerasRoundNo' +onPerasRoundNo :: + (Word64 -> Word64 -> Word64) -> + (PerasRoundNo -> PerasRoundNo -> PerasRoundNo) +onPerasRoundNo = coerce + newtype PerasWeight = PerasWeight {unPerasWeight :: Word64} deriving Show via Quiet PerasWeight deriving stock Generic From a7d50e3c7badb77b1366bdbe7e331ba1e5f2b4da Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Mon, 27 Oct 2025 10:11:52 +0100 Subject: [PATCH 35/43] Add explainable boolean predicate evaluator --- ouroboros-consensus/ouroboros-consensus.cabal | 2 + .../Ouroboros/Consensus/Util/Pred.hs | 234 ++++++++++++++++++ .../test/consensus-test/Main.hs | 2 + .../Test/Consensus/Util/Pred.hs | 123 +++++++++ 4 files changed, 361 insertions(+) create mode 100644 ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Pred.hs create mode 100644 ouroboros-consensus/test/consensus-test/Test/Consensus/Util/Pred.hs diff --git a/ouroboros-consensus/ouroboros-consensus.cabal b/ouroboros-consensus/ouroboros-consensus.cabal index 434cc3e8d2..7fce5117eb 100644 --- a/ouroboros-consensus/ouroboros-consensus.cabal +++ b/ouroboros-consensus/ouroboros-consensus.cabal @@ -308,6 +308,7 @@ library Ouroboros.Consensus.Util.NormalForm.StrictMVar Ouroboros.Consensus.Util.NormalForm.StrictTVar Ouroboros.Consensus.Util.Orphans + Ouroboros.Consensus.Util.Pred Ouroboros.Consensus.Util.RedundantConstraints Ouroboros.Consensus.Util.STM Ouroboros.Consensus.Util.Time @@ -676,6 +677,7 @@ test-suite consensus-test Test.Consensus.MiniProtocol.ObjectDiffusion.Smoke Test.Consensus.Peras.WeightSnapshot Test.Consensus.Util.MonadSTM.NormalForm + Test.Consensus.Util.Pred Test.Consensus.Util.Versioned build-depends: diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Pred.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Pred.hs new file mode 100644 index 0000000000..8e4ab1dbc6 --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Pred.hs @@ -0,0 +1,234 @@ +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneDeriving #-} + +-- | Self-explaining boolean predicates +-- +-- These can be used to provide detailed counterexamples or witnesses for +-- boolean predicates that evaluate to 'False' or 'True', respectively. +-- +-- NOTE: to keep this as simple as possible, we do not perform any boolean +-- simplifications (e.g., double negations, or De Morgan's laws) on the +-- predicates while evauating them. This can be added later if needed. +module Ouroboros.Consensus.Util.Pred + ( Pred (..) + , Evidence + , evalPred + , Explainable (..) + , ExplanationMode (..) + , ShowExplain (..) + , explainShallow + , explainDeep + ) +where + +import Data.Bifunctor (bimap) +import Data.Typeable (Typeable, cast) + +{------------------------------------------------------------------------------- + Self-explaining boolean predicates +-------------------------------------------------------------------------------} + +data Pred tag where + -- | Tag a predicate with some metadata + (:=) :: !tag -> !(Pred tag) -> Pred tag + -- | A concrete boolean value + Bool :: !Bool -> Pred tag + -- | Boolean negation + Not :: !(Pred tag) -> Pred tag + -- | Greater-than comparison + (:>:) :: (Typeable a, Ord a, Show a) => !a -> !a -> Pred tag + -- | Less-than-or-equal comparison + (:<=:) :: (Typeable a, Ord a, Show a) => !a -> !a -> Pred tag + -- | Equality comparison + (:==:) :: (Typeable a, Eq a, Show a) => !a -> !a -> Pred tag + -- | Conjunction + (:/\:) :: !(Pred tag) -> !(Pred tag) -> Pred tag + -- | Disjunction + (:\/:) :: !(Pred tag) -> !(Pred tag) -> Pred tag + +deriving instance Show tag => Show (Pred tag) + +instance Eq tag => Eq (Pred tag) where + (t1 := p1) == (t2 := p2) = + t1 == t2 && p1 == p2 + Bool b1 == Bool b2 = + b1 == b2 + Not p1 == Not p2 = + p1 == p2 + (a1 :>: b1) == (a2 :>: b2) + | Just (a2', b2') <- cast (a2, b2) = + a1 == a2' && b1 == b2' + (a1 :<=: b1) == (a2 :<=: b2) + | Just (a2', b2') <- cast (a2, b2) = + a1 == a2' && b1 == b2' + (a1 :==: b1) == (a2 :==: b2) + | Just (a2', b2') <- cast (a2, b2) = + a1 == a2' && b1 == b2' + (a1 :/\: b1) == (a2 :/\: b2) = + a1 == a2 && b1 == b2 + (a1 :\/: b1) == (a2 :\/: b2) = + a1 == a2 && b1 == b2 + _ == _ = + False + +infixr 2 := + +infixr 3 :\/: + +infixr 4 :/\: + +infixr 5 `Not` + +infix 5 :>: + +infix 5 :<=: + +infix 5 :==: + +-- | Sufficient evidence to show that a predicate is either true or false +type Evidence a = Pred a + +-- | Evaluate a predicate, yielding either a counterexample or a witness. +-- +-- The returned value contains the minimum (modulo conjunction/disjunction +-- short circuiting) evidence needed to explain the outcome. +-- +-- Some examples: +-- +-- >>> data P = A | B | C deriving Show +-- >>> a = A := Bool True -- a ~ True +-- >>> b = B := 2+2 :==: 5 -- b ~ False +-- >>> c = C := 10 :>: 5 -- c ~ True +-- +-- >>> evalPred $ a :/\: c -- success because both a~True and c~True +-- Right ((A := Bool True) :/\: (C := 10 :>: 5)) +-- +-- >>> evalPred $ a :\/: b -- success because a~True, short-circuits +-- Right (A := Bool True) +-- +-- >>> evalPred $ a :/\: b :/\: c -- failure because b~False, short-circuits +-- Left (B := 4 :==: 5) +-- +-- >>> evalPred $ (b :\/: a) :/\: (b :\/: c) -- success because of a~True and c~True +-- Right ((A := Bool True) :/\: (C := 10 :>: 5)) +-- +-- >>> evalPred $ b :\/: (Not c) -- failure because both b~False and c~True +-- Left ((B := 4 :==: 5) :\/: Not (C := 10 :>: 5)) +-- +-- >>> evalPred $ Not (a :/\: b) -- success because b~False +-- Right (Not (B := 4 :==: 5)) +-- +-- >>> evalPred $ Not (a :/\: c) -- failure because both a~True and c~True +-- Left (Not ((A := Bool True) :/\: (C := 10 :>: 5))) +evalPred :: Pred tag -> Either (Evidence tag) (Evidence tag) +evalPred = \case + tag := p' -> + lift (tag :=) id p' + p@(Bool b) -> + boolean b p + Not p' -> + lift Not negation p' + p@(a :>: b) -> + boolean (a > b) p + p@(a :<=: b) -> + boolean (a <= b) p + p@(a :==: b) -> + boolean (a == b) p + a :/\: b -> + case evalPred a of + Left a' -> Left a' -- short-circuit + Right a' -> + case evalPred b of + Right b' -> Right (a' :/\: b') + Left b' -> Left b' + a :\/: b -> + case evalPred a of + Right a' -> Right a' -- short-circuit + Left a' -> + case evalPred b of + Right b' -> Right b' + Left b' -> Left (a' :\/: b') + where + boolean b p + | b = Right p + | otherwise = Left p + + lift f g p = bimap f f (g (evalPred p)) + + negation = either Right Left + +{------------------------------------------------------------------------------- + Explainable type class +-------------------------------------------------------------------------------} + +-- | Explanation mode +-- +-- Used to control whether we want to continue explaining terms beyond tags +-- * Shallow: only explain tags +-- * Deep: explain full predicates +data ExplanationMode = Shallow | Deep + deriving (Show, Eq) + +-- | Provides a human-readable explanation for a value +class Explainable a where + explain :: ExplanationMode -> a -> String + explain = explainPrec 0 + + explainPrec :: Int -> ExplanationMode -> a -> String + explainPrec _ = explain + + {-# MINIMAL (explain | explainPrec) #-} + +-- | Shallow explanation +explainShallow :: Explainable a => a -> String +explainShallow = explain Shallow + +-- | Deep explanation +explainDeep :: Explainable a => a -> String +explainDeep = explain Deep + +-- | Default 'Explainable' instance via 'Show' to be used with 'deriving via' +newtype ShowExplain a = ShowExplain a + deriving stock Show + +instance Show a => Explainable (ShowExplain a) where + explain _ (ShowExplain a) = show a + +deriving via ShowExplain Bool instance Explainable Bool + +instance Explainable a => Explainable (Pred a) where + explainPrec prec mode = \case + tag := p -> + case mode of + Shallow -> + explainShallow tag + Deep -> + parensIf (prec > 1) $ + explainShallow tag <> " := " <> explainPrec 2 mode p + Bool b -> + explain mode b + Not p -> + parensIf (prec > 4) $ + "not " <> explainPrec 5 mode p + a :>: b -> + parensIf (prec > 4) $ + show a <> " > " <> show b + a :<=: b -> + parensIf (prec > 4) $ + show a <> " <= " <> show b + a :==: b -> + parensIf (prec > 4) $ + show a <> " == " <> show b + a :/\: b -> + parensIf (prec > 3) $ + explainPrec 4 mode a <> " and " <> explainPrec 3 mode b + a :\/: b -> + parensIf (prec > 2) $ + explainPrec 3 mode a <> " or " <> explainPrec 2 mode b + where + parensIf :: Bool -> String -> String + parensIf True s = "(" <> s <> ")" + parensIf False s = s diff --git a/ouroboros-consensus/test/consensus-test/Main.hs b/ouroboros-consensus/test/consensus-test/Main.hs index 79d681213a..2a05dd2350 100644 --- a/ouroboros-consensus/test/consensus-test/Main.hs +++ b/ouroboros-consensus/test/consensus-test/Main.hs @@ -20,6 +20,7 @@ import qualified Test.Consensus.MiniProtocol.ObjectDiffusion.PerasCert.Smoke (te 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.Pred (tests) import qualified Test.Consensus.Util.Versioned (tests) import Test.Tasty import Test.Util.TestEnv @@ -51,6 +52,7 @@ tests = , Test.Consensus.Peras.WeightSnapshot.tests , Test.Consensus.Util.MonadSTM.NormalForm.tests , Test.Consensus.Util.Versioned.tests + , Test.Consensus.Util.Pred.tests , testGroup "HardFork" [ testGroup diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Util/Pred.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Util/Pred.hs new file mode 100644 index 0000000000..62da378e28 --- /dev/null +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/Util/Pred.hs @@ -0,0 +1,123 @@ +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE RankNTypes #-} + +-- | Tests for self-explaning boolean predcates +module Test.Consensus.Util.Pred (tests) where + +import Ouroboros.Consensus.Util.Pred +import Test.Tasty +import Test.Tasty.HUnit + +tests :: TestTree +tests = + testGroup + "Pred" + [ -- Basic tests ensuring that predicates produce the right evidence. + testGroup + "evalPred" + [ p `proves` p + , q `refutes` q + , r `proves` r + , Not p `refutes` Not p + , Not q `proves` Not q + , Not r `refutes` Not r + , p :/\: r `proves` p :/\: r + , q `refutes` p :/\: q + , q `refutes` p :/\: q :/\: r + , p `proves` p :\/: q + , p `proves` q :\/: p + , p :/\: r `proves` (p :\/: q) :/\: (q :\/: r) + ] + , -- Basic explanation rendering tests. + -- + -- NOTE: we can't easily test equality/inequality of explanations without + -- turning these test into an annoying change detector (see [1]) but we + -- still _can_ test some specific case regarding operator precedence and + -- distributivity that should always hold regardless of implementation. + -- + -- [1]: https://testing.googleblog.com/2015/01/testing-on-toilet-change-detector-tests.html + testGroup + "explain" + $ concat + [ [ eq_explain mode (p :/\: q :\/: r) ((p :/\: q) :\/: r) + , eq_explain mode (p :\/: q :/\: r) (p :\/: (q :/\: r)) + , neq_explain mode (p :/\: q :\/: r) (p :/\: (q :\/: r)) + , neq_explain mode (p :\/: q :/\: r) ((p :\/: q) :/\: r) + , neq_explain mode (Not (p :/\: q)) (Not p :/\: q) + , neq_explain mode (Not (p :\/: q)) (Not p :\/: q) + , neq_explain mode (P := Bool True :/\: Bool False) ((P := Bool True) :/\: Bool False) + , neq_explain mode (P := Bool True :\/: Bool False) ((P := Bool True) :\/: Bool False) + ] + | mode <- [Shallow, Deep] + ] + ] + +{------------------------------------------------------------------------------- + Setup +-------------------------------------------------------------------------------} + +data Prop = P | Q | R + deriving stock (Show, Eq) + deriving Explainable via ShowExplain Prop + +p :: Pred Prop -- ~ True +p = P := Bool True + +q :: Pred Prop -- ~ False +q = Q := (5 :<=: (3 :: Int)) + +r :: Pred Prop -- ~ True +r = R := Not (4 :<=: (2 :: Int)) + +test_evalPred :: String -> Pred Prop -> Either (Evidence Prop) (Evidence Prop) -> TestTree +test_evalPred name predicate expected = + testCase name $ + case evalPred predicate of + Left ce -> Left ce @?= expected + Right w -> Right w @?= expected + +proves :: Pred Prop -> Evidence Prop -> TestTree +evidence `proves` predicate = + test_evalPred + (explainDeep evidence <> " ⊢ " <> explainShallow predicate <> " => ⊤") + predicate + (Right evidence) + +infix 1 `proves` + +refutes :: Pred Prop -> Evidence Prop -> TestTree +evidence `refutes` predicate = + test_evalPred + (explainDeep evidence <> " ⊢ " <> explainShallow predicate <> " => ⊥") + predicate + (Left evidence) + +infix 1 `refutes` + +eq_explain :: (Show a, Explainable a) => ExplanationMode -> a -> a -> TestTree +eq_explain mode x y = + testCase ("explain " <> show mode <> " " <> show x <> " == explain " <> show mode <> " " <> show y) $ + assertEqual + "Expected equal explanations:" + (explain mode x) + (explain mode y) + +neq_explain :: (Show a, Explainable a) => ExplanationMode -> a -> a -> TestTree +neq_explain mode x y = + testCase ("explain " <> show mode <> " " <> show x <> " /= explain " <> show mode <> " " <> show y) $ + assertNotEqual + "Expected different explanations:" + (explain mode x) + (explain mode y) + +-- Surprising this is not already in 'tasty-hunit' +assertNotEqual :: (Eq a, Show a) => String -> a -> a -> IO () +assertNotEqual preface expected actual + | actual /= expected = return () + | otherwise = assertFailure msg + where + msg = + (if null preface then "" else preface <> "\n") + <> "\n but got: " + <> show actual From a754eae8d7256968a725072adbfd556082b6d19e Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Mon, 27 Oct 2025 10:15:53 +0100 Subject: [PATCH 36/43] Introduce O.C.Peras.Params --- ouroboros-consensus/ouroboros-consensus.cabal | 1 + .../Ouroboros/Consensus/Peras/Params.hs | 67 +++++++++++++++++++ 2 files changed, 68 insertions(+) create mode 100644 ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Params.hs diff --git a/ouroboros-consensus/ouroboros-consensus.cabal b/ouroboros-consensus/ouroboros-consensus.cabal index 7fce5117eb..42ee65e844 100644 --- a/ouroboros-consensus/ouroboros-consensus.cabal +++ b/ouroboros-consensus/ouroboros-consensus.cabal @@ -206,6 +206,7 @@ library Ouroboros.Consensus.Node.Run Ouroboros.Consensus.Node.Serialisation Ouroboros.Consensus.NodeId + Ouroboros.Consensus.Peras.Params Ouroboros.Consensus.Peras.SelectView Ouroboros.Consensus.Peras.Weight Ouroboros.Consensus.Protocol.Abstract diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Params.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Params.hs new file mode 100644 index 0000000000..f6d1d841f0 --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Params.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- | Peras protocol parameters +module Ouroboros.Consensus.Peras.Params + ( PerasIgnoranceRounds (..) + , PerasCooldownRounds (..) + , PerasBlockMinSlots (..) + , PerasCertArrivalThreshold (..) + , PerasParams (..) + ) +where + +import Data.Word (Word64) +import GHC.Generics (Generic) +import Ouroboros.Consensus.Util.IOLike (NoThunks) +import Quiet (Quiet (..)) + +{------------------------------------------------------------------------------- + Protocol parameters +-------------------------------------------------------------------------------} + +-- | Number of rounds for which to ignore certificates after entering a +-- cooldown period. +newtype PerasIgnoranceRounds + = PerasIgnoranceRounds {unPerasIgnoranceRounds :: Word64} + deriving Show via Quiet PerasIgnoranceRounds + deriving stock Generic + deriving newtype (Enum, Eq, Ord, NoThunks) + +-- | Minimum number of rounds to wait before voting again after a cooldown +-- period starts. +newtype PerasCooldownRounds + = PerasCooldownRounds {unPerasCooldownRounds :: Word64} + deriving Show via Quiet PerasCooldownRounds + deriving stock Generic + deriving newtype (Enum, Eq, Ord, NoThunks) + +-- | Minimum age (in slots) of a block to be voted on at the beginning of a +-- Peras round. +newtype PerasBlockMinSlots + = PerasBlockMinSlots {unPerasBlockMinSlots :: Word64} + deriving Show via Quiet PerasBlockMinSlots + deriving stock Generic + deriving newtype (Enum, Eq, Ord, NoThunks) + +-- | Maximum number of slots to after the start of a round to consider a +-- certificate for voting. +newtype PerasCertArrivalThreshold + = PerasCertArrivalThreshold {unPerasCertArrivalThreshold :: Word64} + deriving Show via Quiet PerasCertArrivalThreshold + deriving stock Generic + deriving newtype (Enum, Eq, Ord, NoThunks) + +{------------------------------------------------------------------------------- + Protocol parameters bundle +-------------------------------------------------------------------------------} + +data PerasParams = PerasParams + { perasIgnoranceRounds :: PerasIgnoranceRounds + , perasCooldownRounds :: PerasCooldownRounds + , perasBlockMinSlots :: PerasBlockMinSlots + , perasCertArrivalThreshold :: PerasCertArrivalThreshold + } + deriving (Show, Generic, NoThunks) From 3688bc3dd79d561b55912dcdfb6b0df7be1e61dd Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Tue, 28 Oct 2025 09:31:53 +0100 Subject: [PATCH 37/43] Move geometric into Test.Util.QuickCheck --- .../Test/Util/QuickCheck.hs | 19 +++++++++++++++++++ .../Ouroboros/Storage/ChainDB/StateMachine.hs | 8 -------- 2 files changed, 19 insertions(+), 8 deletions(-) diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/QuickCheck.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/QuickCheck.hs index c22361a64d..723f4d6229 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/QuickCheck.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/QuickCheck.hs @@ -23,6 +23,9 @@ module Test.Util.QuickCheck , frequency' , oneof' + -- * Sampling from distributions + , geometric + -- * Comparing maps , isSubmapOfBy @@ -308,3 +311,19 @@ frequency' xs0 = lift (choose (1, tot)) >>= (`pick` xs0) oneof' :: (MonadTrans t, Monad (t Gen)) => [t Gen a] -> t Gen a oneof' [] = error "QuickCheck.oneof used with empty list" oneof' gs = lift (chooseInt (0, length gs - 1)) >>= (gs !!) + +{------------------------------------------------------------------------------- + Sampling from distributions +-------------------------------------------------------------------------------} + +-- NOTE: if more advanced sampling is required, consider using 'mwc-random': +-- https://hackage.haskell.org/package/mwc-random + +-- | Sample from a geometric distribution +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 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 8779a13f2f..029a168a68 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 @@ -1740,14 +1740,6 @@ genSecurityParam = . 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 From eef954f672f8eb168395cdb70ceaf87413b537ed Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Mon, 27 Oct 2025 10:16:13 +0100 Subject: [PATCH 38/43] Add pure Peras Voting rules With the currently selected generation sizes, we hit the different voting rules in a somewhat decent proportion, even against randomly generated functions as part of the PerasVotingView interface. ouroboros-consensus Peras Peras voting rules isPerasVotingAllowed: OK (1.55s) +++ OK, passed 10000 tests. Actual result (10000 in total): 60.29% NoVoteReason(VR-1A or VR-2A) 20.90% NoVoteReason(VR-1A or VR-2B) 9.60% VoteReason(VR-2A and VR-2B) 4.93% VoteReason(VR-1A and VR-1B) 2.67% NoVoteReason(VR-1B or VR-2A) 1.61% NoVoteReason(VR-1B or VR-2B) Should vote according to model (10000 in total): 85.47% False 14.53% True VR-(1A|1B|2A|2B) (10000 in total): 21.30% (False,True,False,False) 21.24% (False,False,False,False) 10.63% (False,False,True,False) 10.27% (False,True,True,False) 8.99% (False,False,False,True) 8.76% (False,True,False,True) 4.67% (False,True,True,True) 4.26% (False,False,True,True) 1.93% (True,False,False,False) 1.77% (True,True,False,False) 1.71% (True,True,True,False) 1.61% (True,False,True,False) 0.75% (True,True,True,True) 0.74% (True,False,False,True) 0.70% (True,True,False,True) 0.67% (True,False,True,True) VR-1A (10000 in total): 90.12% False 9.88% True VR-1B (10000 in total): 50.07% False 49.93% True VR-2A (10000 in total): 65.43% False 34.57% True VR-2B (10000 in total): 70.46% False 29.54% True --- ouroboros-consensus/ouroboros-consensus.cabal | 2 + .../Ouroboros/Consensus/Peras/Voting.hs | 398 ++++++++++++++++++ .../test/consensus-test/Main.hs | 7 +- .../Test/Consensus/Peras/Voting.hs | 318 ++++++++++++++ 4 files changed, 724 insertions(+), 1 deletion(-) create mode 100644 ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting.hs create mode 100644 ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Voting.hs diff --git a/ouroboros-consensus/ouroboros-consensus.cabal b/ouroboros-consensus/ouroboros-consensus.cabal index 42ee65e844..c4a684f94b 100644 --- a/ouroboros-consensus/ouroboros-consensus.cabal +++ b/ouroboros-consensus/ouroboros-consensus.cabal @@ -208,6 +208,7 @@ library Ouroboros.Consensus.NodeId Ouroboros.Consensus.Peras.Params Ouroboros.Consensus.Peras.SelectView + Ouroboros.Consensus.Peras.Voting Ouroboros.Consensus.Peras.Weight Ouroboros.Consensus.Protocol.Abstract Ouroboros.Consensus.Protocol.BFT @@ -676,6 +677,7 @@ test-suite consensus-test Test.Consensus.MiniProtocol.LocalStateQuery.Server Test.Consensus.MiniProtocol.ObjectDiffusion.PerasCert.Smoke Test.Consensus.MiniProtocol.ObjectDiffusion.Smoke + Test.Consensus.Peras.Voting Test.Consensus.Peras.WeightSnapshot Test.Consensus.Util.MonadSTM.NormalForm Test.Consensus.Util.Pred diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting.hs new file mode 100644 index 0000000000..0f5bb03804 --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Voting.hs @@ -0,0 +1,398 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeOperators #-} + +-- | Pure Peras voting rules +-- +-- This module implements the Peras voting rules in a pure fasion, along with +-- the necessary inpure machinery to retrieve their inputs. These rules are +-- translated as verbatim as possible from: +-- +-- https://github.com/cardano-foundation/CIPs/blob/master/CIP-0140/README.md#rules-for-voting-in-a-round +module Ouroboros.Consensus.Peras.Voting + ( PerasVotingView (..) + , mkPerasVotingView + , isPerasVotingAllowed + , PerasVotingRule (..) + , VoteReason (..) + , NoVoteReason (..) + , perasVR1A + , perasVR1B + , perasVR2A + , perasVR2B + , perasVR1 + , perasVR2 + , perasVotingRules + ) +where + +import Cardano.Slotting.Slot (WithOrigin) +import Data.Bifunctor (bimap) +import Data.Typeable (Typeable) +import Ouroboros.Consensus.Block (WithOrigin (..)) +import Ouroboros.Consensus.Block.Abstract + ( GetHeader (..) + , Header + , SlotNo (..) + , StandardHash + , castPoint + , succWithOrigin + ) +import Ouroboros.Consensus.Block.SupportsPeras + ( HasPerasCertRound (..) + , PerasRoundNo (..) + , ValidatedPerasCert + , getPerasCertBoostedBlock + , getPerasCertRound + , onPerasRoundNo + ) +import Ouroboros.Consensus.BlockchainTime.WallClock.Types + ( WithArrivalTime (..) + ) +import Ouroboros.Consensus.HardFork.History.EraParams (fromPerasEnabled) +import qualified Ouroboros.Consensus.HardFork.History.Qry as HF +import qualified Ouroboros.Consensus.HardFork.History.Summary as HF +import Ouroboros.Consensus.Peras.Params + ( PerasBlockMinSlots (..) + , PerasCertArrivalThreshold (..) + , PerasCooldownRounds (..) + , PerasIgnoranceRounds (..) + , PerasParams (..) + ) +import Ouroboros.Consensus.Util.Pred + ( Evidence + , Explainable (..) + , ExplanationMode (..) + , Pred (..) + , evalPred + ) +import Ouroboros.Network.AnchoredFragment (AnchoredFragment) +import qualified Ouroboros.Network.AnchoredFragment as AF + +{------------------------------------------------------------------------------- + Voting interface +-------------------------------------------------------------------------------} + +-- | Interface needed to evaluate the Peras voting rules +data PerasVotingView cert = PerasVotingView + { perasParams :: !PerasParams + -- ^ Peras protocol parameters. + , currRoundNo :: !PerasRoundNo + -- ^ The current Peras round number. + , latestCertSeen :: !(WithOrigin cert) + -- ^ The most recent certificate seen by the voter. + , latestCertOnChain :: !(WithOrigin cert) + -- ^ The most recent certificate present in some chain. + , certRoundStart :: cert -> SlotNo + -- ^ Get the slot number at the start of the Peras round of a certificate. + , arrivalSlot :: cert -> SlotNo + -- ^ Get the arrival slot number of a certificate + , candidateExtendsCert :: cert -> Bool + -- ^ Does the candidate block extend the one boosted by a certificate? + } + +-- | Construct a 'PerasVotingView'. +-- +-- NOTE: this assumes that the client code computes all the needed inputs +-- within the same STM transaction, or the results may be inconsistent. +mkPerasVotingView :: + ( cert ~ WithArrivalTime (ValidatedPerasCert blk) + , StandardHash blk + , Typeable blk + , GetHeader blk + ) => + PerasParams -> + PerasRoundNo -> + WithOrigin cert -> + WithOrigin cert -> + AnchoredFragment (Header blk) -> + HF.Summary blks -> + PerasVotingView cert +mkPerasVotingView + perasParams + currRoundNo + latestCertSeen + latestCertOnChain + currChain + summary = + PerasVotingView + { perasParams = perasParams + , currRoundNo = currRoundNo + , latestCertSeen = latestCertSeen + , latestCertOnChain = latestCertOnChain + , certRoundStart = certRoundStart + , arrivalSlot = arrivalSlot + , candidateExtendsCert = candidateExtendsCert + } + where + -- Run a pure query with the given summary + pureQuery = flip HF.runQueryPure summary + + -- The Peras block minium slots parameter (L). + _L = SlotNo (unPerasBlockMinSlots (perasBlockMinSlots perasParams)) + + -- Candidate block slot, i.e., that of the block that's at least + -- 'blockMinSlots' (L) old from the start of the current round. + -- + -- NOTE: here we need make sure that the result doesn't underflow. + candidateSlot + | currRoundStart >= _L = currRoundStart - _L + | otherwise = SlotNo 0 + where + currRoundStart = roundStart currRoundNo + + -- The prefix of our current chain leading to the candidate block. + chainAtCandidate = fst (AF.splitAtSlot candidateSlot currChain) + + -- The slot number at the start of a Peras round. + -- + -- NOTE: this might throw a 'PastHorizonException' if the caller is not + -- is not prepared to start voting. + roundStart roundNo = slotNo + where + (slotNo, _) = + pureQuery (fromPerasEnabledOrFail <$> HF.perasRoundNoToSlot roundNo) + + fromPerasEnabledOrFail = + fromPerasEnabled + (error "mkPerasVotingView: Peras is disabled in the current era") + + -- A slightly safer version of 'roundStart' that works with certificates. + -- + -- NOTE: Instead of using 'roundStart' directly, this makes it more + -- harder for the user of the voting interface to accidentally pass a + -- 'PerasRoundNo' that triggers the 'PastHorizonException', as the + -- existence of a certificate _should_ imply that Peras was enabled + -- at the time the certificate was issued. + certRoundStart = roundStart . getPerasCertRound + + -- The arrival slot number of a certificate. + -- + -- NOTE: this might throw a 'PastHorizonException' if the caller does not + -- ensure that the arrival time is within the current realizable horizon. + arrivalSlot cert = slotNo + where + (slotNo, _, _) = + pureQuery (HF.wallclockToSlot (getArrivalTime cert)) + + -- Does the candidate block extend the one boosted by a certificate? + -- + -- This can be trivially tested by checking whether the certificate is + -- within the bounds of the chain prefix leading to the candidate block. + -- + -- NOTE: in the case of an extremely old certificate boosting a block + -- beyond the immutable prefix, this could incorrectly return false even + -- if the voting candidate technically extends the certificate point. + -- However, this a boring case that we can safely ignore. Conversely, + -- the case of a certificate that's too new to be voted for is covered + -- by using the approriate prefix of our current chain. + candidateExtendsCert cert = + AF.withinFragmentBounds certBoostedBlockHeader chainAtCandidate + where + certBoostedBlockHeader = castPoint (getPerasCertBoostedBlock cert) + +-- | Reason for voting being disallowed +newtype NoVoteReason = NoVoteReason (Evidence PerasVotingRule) + deriving (Show, Explainable) + +-- | Reason for voting being allowed +newtype VoteReason = VoteReason (Evidence PerasVotingRule) + deriving (Show, Explainable) + +-- | Evaluate whether voting is allowed or not according to the voting rules +isPerasVotingAllowed :: + HasPerasCertRound cert => + PerasVotingView cert -> + Either NoVoteReason VoteReason +isPerasVotingAllowed pvv = + bimap NoVoteReason VoteReason $ + evalPred (perasVotingRules pvv) + +{------------------------------------------------------------------------------- + Voting rules +-------------------------------------------------------------------------------} + +-- | Voting rules +-- +-- Each constructor corresponds to a voting rule as per CIP-0140. +-- +-- * VR1x correspond to the "happy" path, i.e., when nodes proceed to vote +-- normally, whereas +-- * VR2x correspond to the "cool-down" path, i.e., when nodes are exiting a +-- cool-down period. +data PerasVotingRule = VR1A | VR1B | VR2A | VR2B + deriving (Show, Eq) + +instance Explainable PerasVotingRule where + explain Shallow = \case + VR1A -> "VR-1A" + VR1B -> "VR-1B" + VR2A -> "VR-2A" + VR2B -> "VR-2B" + explain Deep = \case + VR1A -> + "voter has seen the certificate for the previous round in time" + VR1B -> + "the block being voted upon extends the most recently certified block" + VR2A -> + "the last certificate seen is sufficiently old" + VR2B -> + "the last certificate on chain is exactly one or more cooldown periods old" + +-- | VR-1A: the voter has seen the certificate for the previous round, and the +-- certificate was received in the first X slots after the start of the round. +perasVR1A :: + HasPerasCertRound cert => + PerasVotingView cert -> + Pred PerasVotingRule +perasVR1A + PerasVotingView + { perasParams + , currRoundNo + , latestCertSeen + , arrivalSlot + , certRoundStart + } = + VR1A := vr1a1 :/\: vr1a2 + where + -- The latest certificate seen is from the previous round + -- + -- NOTE: 'succWithOrigin' handles the 'Origin' case (i.e. when we have + -- never seen a certificate before) correctly by returning 0, as this is + -- the only round number that should satisfy this equality when we are + -- bootstrapping the voting process. In other words, we should be able to + -- start voting from round 0 even if we have never seen a certificate + -- before, but failing to do so should trigger a cooldown period + -- immediately after. + vr1a1 = + currRoundNo :==: succWithOrigin (getPerasCertRound <$> latestCertSeen) + + -- The latest certificate seen was received within X slots from the start + -- of the round + vr1a2 = + case latestCertSeen of + -- We have seen a certificate ==> check its arrival time + NotOrigin cert -> arrivalSlot cert :<=: certRoundStart cert + _X + -- We have never seen a certificate ==> vacuously true + Origin -> Bool True + + _X = + SlotNo $ + unPerasCertArrivalThreshold $ + perasCertArrivalThreshold perasParams + +-- | VR-1B: the block being voted upon extends the most recently certified one. +perasVR1B :: + PerasVotingView cert -> + Pred PerasVotingRule +perasVR1B + PerasVotingView + { latestCertSeen + , candidateExtendsCert + } = + VR1B := vr1b + where + -- The block being voted upon extends the most recently certified one + vr1b = + case latestCertSeen of + -- We have seen a certificate ==> check that it extends our chain + NotOrigin cert -> Bool (candidateExtendsCert cert) + -- We have never seen a certificate ==> vacuously true + Origin -> Bool True + +-- | VR-2A: the last certificate a party has seen is from a round at least R +-- rounds previously. This enforces the chain-healing period that must occur +-- before leaving a cool-down period. +perasVR2A :: + HasPerasCertRound cert => + PerasVotingView cert -> + Pred PerasVotingRule +perasVR2A + PerasVotingView + { perasParams + , currRoundNo + , latestCertSeen + } = + VR2A := vr2a + where + vr2a = + -- NOTE: we use 'succWithOrigin' and '-1' to handle the 'Origin' case + -- (i.e. when we have never seen a certificate before) correctly, + -- treating the 'Origin' certificate as being from round -1. + (succWithOrigin (getPerasCertRound <$> latestCertSeen) - 1 + _R) + :<=: currRoundNo + + _R = + PerasRoundNo $ + unPerasIgnoranceRounds $ + perasIgnoranceRounds $ + perasParams + +-- | VR-2B: the last certificate included in a party's current chain is from a +-- round exactly c⋅K rounds ago for some c ∈ ℕ with c ≥ 0. This enforces chain +-- quality and common prefix before leaving a cool-down period. +perasVR2B :: + HasPerasCertRound cert => + PerasVotingView cert -> + Pred PerasVotingRule +perasVR2B + PerasVotingView + { perasParams + , currRoundNo + , latestCertOnChain + } = + VR2B := vr2b + where + vr2b = + case latestCertOnChain of + -- There is a certificate on chain ==> we must check its round number + NotOrigin cert -> + -- The certificate comes from a round older than the current one + (currRoundNo :>: getPerasCertRound cert) + -- The certificate round is c⋅K rounds away from the current one + :/\: (currRoundNo `rmod` _K :==: getPerasCertRound cert `rmod` _K) + -- There is no certificate on chain ==> check if we are recovering + -- from an initial cooldown after having initially failed to + -- reach a quorum during bootstrapping. + -- + -- NOTE: '_K - 1' here is treating the 'Origin' certificate as being + -- from round -1. + Origin -> currRoundNo `rmod` _K :==: _K - 1 + + rmod = onPerasRoundNo mod + + _K = + PerasRoundNo $ + unPerasCooldownRounds $ + perasCooldownRounds $ + perasParams + +-- | Both VR-1A and VR-1B hold, which is the situation typically occurring when +-- the voting has regularly occurred in preceding rounds. +perasVR1 :: + HasPerasCertRound cert => + PerasVotingView cert -> + Pred PerasVotingRule +perasVR1 pvv = + perasVR1A pvv :/\: perasVR1B pvv + +-- | Both VR-2A and VR-2B hold, which is the situation typically occurring when +-- the chain is about to exit a cool-down period. +perasVR2 :: + HasPerasCertRound cert => + PerasVotingView cert -> + Pred PerasVotingRule +perasVR2 pvv = + perasVR2A pvv :/\: perasVR2B pvv + +-- | Voting is allowed if either VR-1A and VR-1B hold, or VR-2A and VR-2B hold. +perasVotingRules :: + HasPerasCertRound cert => + PerasVotingView cert -> + Pred PerasVotingRule +perasVotingRules pvv = + perasVR1 pvv :\/: perasVR2 pvv diff --git a/ouroboros-consensus/test/consensus-test/Main.hs b/ouroboros-consensus/test/consensus-test/Main.hs index 2a05dd2350..2775745a44 100644 --- a/ouroboros-consensus/test/consensus-test/Main.hs +++ b/ouroboros-consensus/test/consensus-test/Main.hs @@ -18,6 +18,7 @@ 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.Voting (tests) import qualified Test.Consensus.Peras.WeightSnapshot (tests) import qualified Test.Consensus.Util.MonadSTM.NormalForm (tests) import qualified Test.Consensus.Util.Pred (tests) @@ -49,7 +50,11 @@ tests = , Test.Consensus.Mempool.Fairness.tests , Test.Consensus.Mempool.StateMachine.tests ] - , Test.Consensus.Peras.WeightSnapshot.tests + , testGroup + "Peras" + [ Test.Consensus.Peras.Voting.tests + , Test.Consensus.Peras.WeightSnapshot.tests + ] , Test.Consensus.Util.MonadSTM.NormalForm.tests , Test.Consensus.Util.Versioned.tests , Test.Consensus.Util.Pred.tests diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Voting.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Voting.hs new file mode 100644 index 0000000000..5fb5e4bb95 --- /dev/null +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/Voting.hs @@ -0,0 +1,318 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | Test that the Peras voting rules can correctly decide when to vote. +module Test.Consensus.Peras.Voting (tests) where + +import GHC.Generics (Generic) +import GHC.Word (Word64) +import Ouroboros.Consensus.Block.Abstract + ( SlotNo (..) + , WithOrigin (..) + , succWithOrigin + ) +import Ouroboros.Consensus.Block.SupportsPeras + ( HasPerasCertRound (..) + , PerasRoundNo (..) + , getPerasCertRound + , onPerasRoundNo + ) +import Ouroboros.Consensus.BlockchainTime + ( RelativeTime (..) + ) +import Ouroboros.Consensus.Peras.Params + ( PerasBlockMinSlots (..) + , PerasCertArrivalThreshold (..) + , PerasCooldownRounds (..) + , PerasIgnoranceRounds (..) + , PerasParams (..) + ) +import Ouroboros.Consensus.Peras.Voting + ( PerasVotingView (..) + , isPerasVotingAllowed + ) +import Ouroboros.Consensus.Util.Pred (explainShallow) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck + ( Arbitrary (..) + , CoArbitrary + , Fun (..) + , Function + , Gen + , Positive (..) + , Property + , Small (..) + , Testable (..) + , applyFun + , choose + , counterexample + , frequency + , tabulate + , testProperty + ) +import Test.Util.Orphans.Arbitrary (genNominalDiffTime50Years) +import Test.Util.QuickCheck (geometric) +import Test.Util.TestEnv (adjustQuickCheckTests) + +{------------------------------------------------------------------------------- + Tests +-------------------------------------------------------------------------------} + +tests :: TestTree +tests = + adjustQuickCheckTests (* 100) $ + testGroup + "Peras voting rules" + [ testProperty "isPerasVotingAllowed" prop_isPerasVotingAllowed + ] + +{------------------------------------------------------------------------------- + Model conformance test property +-------------------------------------------------------------------------------} + +-- | A simplified model of the Peras voting rules, used to compare against the +-- real implementation. The main difference is that this model computes the +-- result of the predicate directly over the inputs, rather than using the +-- 'Pred' combinators to produce evidence in either direction. +-- +-- NOTE: this predicate could be lifted directly from the agda specification. +isPerasVotingAllowedModel :: + PerasVotingView TestCert -> + ( -- Should we vote according to the model? + Bool + , -- The individual voting rules that were applied + (Bool, Bool, Bool, Bool) + ) +isPerasVotingAllowedModel + PerasVotingView + { perasParams + , currRoundNo + , latestCertSeen + , latestCertOnChain + , certRoundStart + , arrivalSlot + , candidateExtendsCert + } = + ( vr1a && vr1b || vr2a && vr2b + , (vr1a, vr1b, vr2a, vr2b) + ) + where + vr1a = + vr1a1 && vr1a2 + vr1a1 = + currRoundNo == succWithOrigin (getPerasCertRound <$> latestCertSeen) + vr1a2 = + case latestCertSeen of + NotOrigin cert -> + arrivalSlot cert <= certRoundStart cert + _X + Origin -> True + vr1b = + case latestCertSeen of + NotOrigin cert -> candidateExtendsCert cert + Origin -> True + vr2a = + (succWithOrigin (getPerasCertRound <$> latestCertSeen) - 1 + _R) + <= currRoundNo + + vr2b = + case latestCertOnChain of + NotOrigin cert -> + (currRoundNo > getPerasCertRound cert) + && (currRoundNo `rmod` _K == getPerasCertRound cert `rmod` _K) + Origin -> currRoundNo `rmod` _K == _K - 1 + + _X = + SlotNo $ + unPerasCertArrivalThreshold $ + perasCertArrivalThreshold $ + perasParams + _R = + PerasRoundNo $ + unPerasIgnoranceRounds $ + perasIgnoranceRounds $ + perasParams + _K = + PerasRoundNo $ + unPerasCooldownRounds $ + perasCooldownRounds $ + perasParams + + rmod = onPerasRoundNo mod + +-- | Test that the Peras voting rules can correctly decide when to vote based +-- on a simplified model that doesn't use anything fancy to evaluate the rules. +prop_isPerasVotingAllowed :: PerasVotingView' TestCert -> Property +prop_isPerasVotingAllowed pvv' = do + -- Unpack the generated Peras voting view + let pvv = toPerasVotingView pvv' + -- Determine whether we should vote according to the model + let (shouldVote, votingRules@(vr1a, vr1b, vr2a, vr2b)) = + isPerasVotingAllowedModel pvv + -- Some helper functions to report success/failure + let chain = flip (foldr ($)) . reverse + let ok desc = + chain + [ tabulate "VR-1A" [show vr1a] + , tabulate "VR-1B" [show vr1b] + , tabulate "VR-2A" [show vr2a] + , tabulate "VR-2B" [show vr2b] + , tabulate "VR-(1A|1B|2A|2B)" [show votingRules] + , tabulate "Should vote according to model" [show shouldVote] + , tabulate "Actual result" [desc] + ] + $ property True + let failure desc = + counterexample desc $ + property False + -- Now check that the real implementation agrees with the model + case isPerasVotingAllowed pvv of + Right voteReason + | shouldVote -> + ok $ "VoteReason(" <> explainShallow voteReason <> ")" + | otherwise -> + failure $ "Expected not to vote, but got: " <> show voteReason + Left noVoteReason + | not shouldVote -> + ok $ "NoVoteReason(" <> explainShallow noVoteReason <> ")" + | otherwise -> + failure $ "Expected to vote, but got: " <> show noVoteReason + +{------------------------------------------------------------------------------- + Arbitrary helpers +-------------------------------------------------------------------------------} + +-- * Peras round numbers + +genPerasRoundNo :: Gen PerasRoundNo +genPerasRoundNo = do + Positive (Small n) <- arbitrary + pure (PerasRoundNo n) + +-- * Peras parameters + +-- NOTE: we use a geometric distribution to bias towards smaller values. +-- This increases the chance of covering all the voting rules more evenly, +-- while still allowing for larger values to be generated occasionally. +-- +-- Moreover, geometric(0.5) + 1 means that: +-- - 50% chance of being 1 +-- - 25% chance of being 2 +-- - 12.5% chance of being 3 +-- ... and so on +genPerasParams :: Gen PerasParams +genPerasParams = do + _L <- fromIntegral . (+ 1) <$> geometric 0.5 + _X <- fromIntegral . (+ 1) <$> geometric 0.5 + _R <- fromIntegral . (+ 1) <$> geometric 0.5 + _K <- fromIntegral . (+ 1) <$> geometric 0.5 + pure + PerasParams + { perasBlockMinSlots = PerasBlockMinSlots _L + , perasCertArrivalThreshold = PerasCertArrivalThreshold _X + , perasIgnoranceRounds = PerasIgnoranceRounds _R + , perasCooldownRounds = PerasCooldownRounds _K + } + +-- * Mocked certificate type + +-- NOTE: we could also use the real 'WithArrivalTime (ValidatedPerasCert blk)' +-- here. However, this one is much easier to derive a 'Function' instance for, +-- so we can actually generate the methods needed by 'PerasVotingView'. + +data TestCert + = TestCert + { tcArrivalTime :: RelativeTime + , tcRoundNo :: PerasRoundNo + } + deriving (Show, Eq, Generic) + +instance HasPerasCertRound TestCert where + getPerasCertRound = tcRoundNo + +-- | Generate a test certificate +-- +-- NOTE: to improve the probabilities of covering all the paths in the code, +-- we generate certificates relative to a given Peras round (the current one). +genTestCert :: PerasRoundNo -> Gen TestCert +genTestCert roundNo = do + arrivalTime <- RelativeTime <$> genNominalDiffTime50Years + offset <- choose @Integer (-3, 2) + -- NOTE: here we need to be careful not to underflow the round number or we + -- will get an exception later on when trying to evaluate 'succ maxBound' + let roundNo' = + PerasRoundNo $ + fromIntegral $ + max 0 $ + toInteger (unPerasRoundNo roundNo) + offset + pure $ + TestCert + { tcArrivalTime = arrivalTime + , tcRoundNo = roundNo' + } + +genWithOrigin :: Gen a -> Gen (WithOrigin a) +genWithOrigin gen = frequency [(1, pure Origin), (9, NotOrigin <$> gen)] + +-- * Peras voting views + +-- | A version of 'PerasVotingView' with all functions lifted to 'Fun' +data PerasVotingView' cert = PerasVotingView' + { perasParams' :: PerasParams + , currRoundNo' :: PerasRoundNo + , latestCertSeen' :: WithOrigin cert + , latestCertOnChain' :: WithOrigin cert + , arrivalSlot' :: Fun cert (Small Word64) + , certRoundStart' :: Fun cert (Small Word64) + , candidateExtendsCert' :: Fun cert Bool + } + deriving (Show, Generic) -- the whole reason to have this type + +instance Arbitrary (PerasVotingView' TestCert) where + arbitrary = do + roundNo <- genPerasRoundNo + PerasVotingView' + <$> genPerasParams + <*> pure roundNo + <*> genWithOrigin (genTestCert roundNo) + <*> genWithOrigin (genTestCert roundNo) + <*> arbitrary + <*> arbitrary + <*> arbitrary + + -- NOTE: arbitrary functions can only be shown after shrinking them first + shrink pvv' = + [ pvv' + { arrivalSlot' = arrivalSlot' + , certRoundStart' = certRoundStart' + , candidateExtendsCert' = candidateExtendsCert' + } + | arrivalSlot' <- shrink (arrivalSlot' pvv') + , certRoundStart' <- shrink (certRoundStart' pvv') + , candidateExtendsCert' <- shrink (candidateExtendsCert' pvv') + ] + +toPerasVotingView :: PerasVotingView' TestCert -> PerasVotingView TestCert +toPerasVotingView pvv' = + PerasVotingView + { perasParams = perasParams' pvv' + , currRoundNo = currRoundNo' pvv' + , latestCertSeen = latestCertSeen' pvv' + , latestCertOnChain = latestCertOnChain' pvv' + , arrivalSlot = SlotNo . getSmall <$> applyFun (arrivalSlot' pvv') + , certRoundStart = SlotNo . getSmall <$> applyFun (certRoundStart' pvv') + , candidateExtendsCert = applyFun (candidateExtendsCert' pvv') + } + +-- * Orphan instances needed for 'Function' constraints + +instance Function RelativeTime +instance Function PerasRoundNo +instance Function TestCert + +instance CoArbitrary RelativeTime +instance CoArbitrary PerasRoundNo +instance CoArbitrary TestCert From 9e0d3db5a4f906d1fce9ad1552727cbd37d4c606 Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Wed, 29 Oct 2025 10:14:29 +0100 Subject: [PATCH 39/43] Store previous epoch nonce in PraosState --- .../golden/cardano/disk/ChainDepState_Babbage | Bin 372 -> 374 bytes .../golden/cardano/disk/ChainDepState_Conway | Bin 403 -> 405 bytes .../cardano/disk/ChainDepState_Dijkstra | Bin 434 -> 436 bytes .../cardano/disk/ExtLedgerState_Babbage | Bin 1062 -> 1064 bytes .../golden/cardano/disk/ExtLedgerState_Conway | Bin 1699 -> 1701 bytes .../cardano/disk/ExtLedgerState_Dijkstra | Bin 1825 -> 1827 bytes .../Ouroboros/Consensus/Protocol/Praos.hs | 26 +++++++++++++----- .../Protocol/Serialisation/Generators.hs | 1 + 8 files changed, 20 insertions(+), 7 deletions(-) diff --git a/ouroboros-consensus-cardano/golden/cardano/disk/ChainDepState_Babbage b/ouroboros-consensus-cardano/golden/cardano/disk/ChainDepState_Babbage index 3bc6eaac885800f5f1b8eb0fabab59681f170b0c..2e06ac93cf4aa1346a99ec7b1c931741423f2e73 100644 GIT binary patch delta 22 bcmeyu^o?o4e8!H63woFu872oXs(>&6Ywrj5 delta 15 Xcmeyy^o41{e8%>P3wkE&F?s+1IZFm@ diff --git a/ouroboros-consensus-cardano/golden/cardano/disk/ChainDepState_Conway b/ouroboros-consensus-cardano/golden/cardano/disk/ChainDepState_Conway index 5043da9e145a6a9d9676cf5834dd47f9ac7d3a87..760307285a4749f2f4ed0f2c6283a5b02b163783 100644 GIT binary patch delta 18 acmbQtJe7IEKE{rT`+Jxg874C_dH?`H@CHHv delta 15 XcmbQrJehgIKF0Qm`+FucGI{_2Ffs+c diff --git a/ouroboros-consensus-cardano/golden/cardano/disk/ChainDepState_Dijkstra b/ouroboros-consensus-cardano/golden/cardano/disk/ChainDepState_Dijkstra index 8745a735ad11111d74404736a355100d5dff5a9b..64bfb1dc43fd531d6019573e103b75cb054715c3 100644 GIT binary patch delta 18 acmdnQyoGtfUB-@y_j;Hb873<*dH?`P6$ae^ delta 15 XcmdnOyoq_jUB>o__j)EPFnRz0HRA?Z diff --git a/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Babbage b/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Babbage index 622ee470ffed81a6ab3e1e364f2899cb2ec655b0..e1cb075b826f387453cd45895ec48a903d70cbd8 100644 GIT binary patch delta 24 gcmZ3+v4UemATw)66C>lIiLc})moR5dzQgPV0Balw-v9sr delta 24 gcmZ3%v5aFwATw)w6C>lIiLc})moR5de!%Pj0Bafu-~a#s diff --git a/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Conway b/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Conway index 1d2b0c3c12cd92022d0827ede068bd448dd3fcd5..74fe8bc5754d646432047d745a1b988197a3e6f2 100644 GIT binary patch delta 20 ccmZ3?yOejsIabDw$>&*nm>L--3$l3t08rir*8l(j delta 17 ZcmZ3=yO?*wIabE@$>&*nCJVB8002Fo22%h4 diff --git a/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Dijkstra b/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Dijkstra index 563a4897c6cea24d29792667e8db97561abad6e2..a57ec35d1a051ec9bfb5207deb824e6b6ff974fb 100644 GIT binary patch delta 20 bcmZ3;x0r8(4;y30WM8%(rbdRz{cIipMU@6o delta 17 YcmZ3?w~%jx4;y3qWM8(P$^C2|05xI-%>V!Z diff --git a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs index 772f3c2550..547e9e54aa 100644 --- a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs +++ b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs @@ -279,6 +279,8 @@ data PraosState = PraosState -- ^ Candidate nonce , praosStateEpochNonce :: !Nonce -- ^ Epoch nonce + , praosStatePreviousEpochNonce :: !Nonce + -- ^ Previous epoch nonce , praosStateLabNonce :: !Nonce -- ^ Nonce constructed from the hash of the previous block , praosStateLastEpochBlockNonce :: !Nonce @@ -303,17 +305,19 @@ instance Serialise PraosState where , praosStateEvolvingNonce , praosStateCandidateNonce , praosStateEpochNonce + , praosStatePreviousEpochNonce , praosStateLabNonce , praosStateLastEpochBlockNonce } = encodeVersion 0 $ mconcat - [ CBOR.encodeListLen 7 + [ CBOR.encodeListLen 8 , toCBOR praosStateLastSlot , toCBOR praosStateOCertCounters , toCBOR praosStateEvolvingNonce , toCBOR praosStateCandidateNonce , toCBOR praosStateEpochNonce + , toCBOR praosStatePreviousEpochNonce , toCBOR praosStateLabNonce , toCBOR praosStateLastEpochBlockNonce ] @@ -323,7 +327,7 @@ instance Serialise PraosState where [(0, Decode decodePraosState)] where decodePraosState = do - enforceSize "PraosState" 7 + enforceSize "PraosState" 8 PraosState <$> fromCBOR <*> fromCBOR @@ -332,6 +336,7 @@ instance Serialise PraosState where <*> fromCBOR <*> fromCBOR <*> fromCBOR + <*> fromCBOR data instance Ticked PraosState = TickedPraosState { tickedPraosStateChainDepState :: PraosState @@ -423,11 +428,13 @@ instance PraosCrypto c => ConsensusProtocol (Praos c) where -- Updating the chain dependent state for Praos. -- -- If we are not in a new epoch, then nothing happens. If we are in a new - -- epoch, we do two things: + -- epoch, we do three things: -- - Update the epoch nonce to the combination of the candidate nonce and the -- nonce derived from the last block of the previous epoch. - -- - Update the "last block of previous epoch" nonce to the nonce derived from - -- the last applied block. + -- - Store the current epoch nonce as the "previous epoch" nonce. This is + -- needed by Peras to be able to validate slightly old certificates. + -- - Update the "last block of previous epoch" nonce to the nonce derived + -- from the last applied block. tickChainDepState PraosConfig{praosEpochInfo} lv @@ -450,7 +457,10 @@ instance PraosCrypto c => ConsensusProtocol (Praos c) where { praosStateEpochNonce = praosStateCandidateNonce st ⭒ praosStateLastEpochBlockNonce st - , praosStateLastEpochBlockNonce = praosStateLabNonce st + , praosStatePreviousEpochNonce = + praosStateEpochNonce st + , praosStateLastEpochBlockNonce = + praosStateLabNonce st } else st @@ -758,7 +768,8 @@ instance TranslateProto (TPraos c) (Praos c) where , praosStateOCertCounters = Map.mapKeysMonotonic coerce certCounters , praosStateEvolvingNonce = evolvingNonce , praosStateCandidateNonce = candidateNonce - , praosStateEpochNonce = SL.ticknStateEpochNonce csTickn + , praosStateEpochNonce = epochNonce + , praosStatePreviousEpochNonce = epochNonce -- same as current epoch nonce , praosStateLabNonce = csLabNonce , praosStateLastEpochBlockNonce = SL.ticknStatePrevHashNonce csTickn } @@ -767,6 +778,7 @@ instance TranslateProto (TPraos c) (Praos c) where tpraosStateChainDepState tpState SL.PrtclState certCounters evolvingNonce candidateNonce = csProtocol + epochNonce = SL.ticknStateEpochNonce csTickn {------------------------------------------------------------------------------- Util diff --git a/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Consensus/Protocol/Serialisation/Generators.hs b/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Consensus/Protocol/Serialisation/Generators.hs index a88e986783..3b3cf99494 100644 --- a/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Consensus/Protocol/Serialisation/Generators.hs +++ b/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Consensus/Protocol/Serialisation/Generators.hs @@ -81,3 +81,4 @@ instance Arbitrary PraosState where <*> arbitrary <*> arbitrary <*> arbitrary + <*> arbitrary From c009de8aec74a32fdfc03796920bf648c3019073 Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Mon, 3 Nov 2025 10:26:31 +0100 Subject: [PATCH 40/43] Store most recent cert in the PerasCertDB --- .../Consensus/Storage/PerasCertDB/API.hs | 8 +++++++ .../Consensus/Storage/PerasCertDB/Impl.hs | 24 ++++++++++++++++--- .../Ouroboros/Storage/PerasCertDB/Model.hs | 19 +++++++++++---- .../Storage/PerasCertDB/StateMachine.hs | 12 ++++++++++ 4 files changed, 56 insertions(+), 7 deletions(-) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/API.hs index 6d992b4b42..ab0f0b35b1 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/API.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/API.hs @@ -35,6 +35,14 @@ data PerasCertDB m blk = PerasCertDB -- 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) + , getLatestCertSeen :: STM m (Maybe (WithArrivalTime (ValidatedPerasCert blk))) + -- ^ Get the certificate with the highest round number that has been added to + -- the db since it has been opened. This certificate is not affected by garbage + -- collection, but it's forgotten when the db is closed. + -- + -- NOTE: having seen a certificate is a precondition to start voting in every + -- round except for the first one (at origin). As a consequence, only caught-up + -- nodes can actively participate in the Peras protocol for now. , garbageCollect :: SlotNo -> m () -- ^ Garbage-collect state older than the given slot number. , closeDB :: m () diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs index 90277d4a0c..1ac06a222b 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs @@ -79,6 +79,7 @@ openDB args = do { addCert = getEnv1 h implAddCert , getWeightSnapshot = getEnvSTM h implGetWeightSnapshot , getCertSnapshot = getEnvSTM h implGetCertSnapshot + , getLatestCertSeen = getEnvSTM h implGetLatestCertSeen , garbageCollect = getEnv1 h implGarbageCollect , closeDB = implCloseDB h } @@ -170,18 +171,22 @@ implAddCert env cert = do if Map.member roundNo pvcsCerts then pure PerasCertAlreadyInDB else do + let pvcsCerts' = Map.insert roundNo cert pvcsCerts let pvcsLastTicketNo' = succ pvcsLastTicketNo writeTVar pcdbVolatileState $ WithFingerprint PerasVolatileCertState { pvcsCerts = - Map.insert roundNo cert pvcsCerts + 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' + , pvcsLastTicketNo = + pvcsLastTicketNo' + , pvcsLatestCertSeen = + snd <$> Map.lookupMax pvcsCerts' } (succ fp) pure AddedPerasCertToDB @@ -220,6 +225,14 @@ implGetCertSnapshot PerasCertDbEnv{pcdbVolatileState} = snd $ Map.split ticketNo pvcsCertsByTicket } +implGetLatestCertSeen :: + IOLike m => + PerasCertDbEnv m blk -> STM m (Maybe (WithArrivalTime (ValidatedPerasCert blk))) +implGetLatestCertSeen PerasCertDbEnv{pcdbVolatileState} = + readTVar pcdbVolatileState + <&> forgetFingerprint + <&> pvcsLatestCertSeen + implGarbageCollect :: forall m blk. IOLike m => @@ -236,12 +249,14 @@ implGarbageCollect PerasCertDbEnv{pcdbVolatileState} slot = , pvcsWeightByPoint , pvcsLastTicketNo , pvcsCertsByTicket + , pvcsLatestCertSeen } = PerasVolatileCertState { pvcsCerts = Map.filter keepCert pvcsCerts , pvcsWeightByPoint = prunePerasWeightSnapshot slot pvcsWeightByPoint , pvcsCertsByTicket = Map.filter keepCert pvcsCertsByTicket , pvcsLastTicketNo = pvcsLastTicketNo + , pvcsLatestCertSeen = pvcsLatestCertSeen } where keepCert cert = @@ -269,6 +284,9 @@ data PerasVolatileCertState blk = PerasVolatileCertState , pvcsLastTicketNo :: !PerasCertTicketNo -- ^ The most recent 'PerasCertTicketNo' (or 'zeroPerasCertTicketNo' -- otherwise). + , pvcsLatestCertSeen :: !(Maybe (WithArrivalTime (ValidatedPerasCert blk))) + -- ^ The certificate with the highest round number that has been added to the + -- db since it has been opened. } deriving stock (Show, Generic) deriving anyclass NoThunks @@ -281,6 +299,7 @@ initialPerasVolatileCertState = , pvcsWeightByPoint = emptyPerasWeightSnapshot , pvcsCertsByTicket = Map.empty , pvcsLastTicketNo = zeroPerasCertTicketNo + , pvcsLatestCertSeen = Nothing } (Fingerprint 0) @@ -305,7 +324,6 @@ invariantForPerasVolatileCertState pvcs = do <> " > " <> show pvcsLastTicketNo where - PerasVolatileCertState _ _ _ _keep = forgetFingerprint pvcs PerasVolatileCertState { pvcsCerts , pvcsWeightByPoint diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/Model.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/Model.hs index 8e48d8b91f..a455d4ac27 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/Model.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/Model.hs @@ -11,6 +11,7 @@ module Test.Ouroboros.Storage.PerasCertDB.Model , closeDB , addCert , getWeightSnapshot + , getLatestCertSeen , garbageCollect , hasRoundNo ) where @@ -19,14 +20,16 @@ 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.BlockchainTime.WallClock.Types (WithArrivalTime, forgetArrivalTime) import Ouroboros.Consensus.Peras.Weight ( PerasWeightSnapshot , mkPerasWeightSnapshot ) +import Ouroboros.Consensus.Util (safeMaximumOn) data Model blk = Model { certs :: Set (WithArrivalTime (ValidatedPerasCert blk)) + , latestCertSeen :: Maybe (WithArrivalTime (ValidatedPerasCert blk)) , open :: Bool } deriving Generic @@ -34,20 +37,23 @@ data Model blk = Model deriving instance StandardHash blk => Show (Model blk) initModel :: Model blk -initModel = Model{open = False, certs = Set.empty} +initModel = Model{open = False, certs = Set.empty, latestCertSeen = Nothing} openDB :: Model blk -> Model blk openDB model = model{open = True} closeDB :: Model blk -> Model blk -closeDB _ = Model{open = False, certs = Set.empty} +closeDB _ = Model{open = False, certs = Set.empty, latestCertSeen = Nothing} addCert :: StandardHash blk => Model blk -> WithArrivalTime (ValidatedPerasCert blk) -> Model blk addCert model@Model{certs} cert | certs `hasRoundNo` cert = model - | otherwise = model{certs = Set.insert cert certs} + | otherwise = model{certs = certs', latestCertSeen = safeMaximumOn roundNo (Set.toList certs')} + where + certs' = Set.insert cert certs + roundNo = getPerasCertRound . forgetArrivalTime hasRoundNo :: Set (WithArrivalTime (ValidatedPerasCert blk)) -> @@ -65,6 +71,11 @@ getWeightSnapshot Model{certs} = | cert <- Set.toList certs ] +getLatestCertSeen :: + Model blk -> Maybe (WithArrivalTime (ValidatedPerasCert blk)) +getLatestCertSeen Model{latestCertSeen} = + latestCertSeen + garbageCollect :: SlotNo -> Model blk -> Model blk garbageCollect slot model@Model{certs} = model{certs = Set.filter keepCert certs} diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs index d930acb466..f2df9d557d 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs @@ -72,6 +72,7 @@ instance StateModel Model where CloseDB :: Action Model () AddCert :: WithArrivalTime (ValidatedPerasCert TestBlock) -> Action Model AddPerasCertResult GetWeightSnapshot :: Action Model (PerasWeightSnapshot TestBlock) + GetLatestCertSeen :: Action Model (Maybe (WithArrivalTime (ValidatedPerasCert TestBlock))) GarbageCollect :: SlotNo -> Action Model () arbitraryAction _ (Model model) @@ -80,6 +81,7 @@ instance StateModel Model where [ (1, pure $ Some CloseDB) , (20, Some <$> genAddCert) , (20, pure $ Some GetWeightSnapshot) + , (10, pure $ Some GetLatestCertSeen) , (5, Some . GarbageCollect . SlotNo <$> arbitrary) ] | otherwise = pure $ Some OpenDB @@ -128,6 +130,7 @@ instance StateModel Model where CloseDB -> Model.closeDB model AddCert cert -> Model.addCert model cert GetWeightSnapshot -> model + GetLatestCertSeen -> model GarbageCollect slot -> Model.garbageCollect slot model precondition (Model model) = \case @@ -140,6 +143,7 @@ instance StateModel Model where where p cert' = getPerasCertRound cert /= getPerasCertRound cert' || cert == cert' GetWeightSnapshot -> True + GetLatestCertSeen -> True GarbageCollect _slot -> True deriving stock instance Show (Action Model a) @@ -162,6 +166,9 @@ instance RunModel Model (StateT (PerasCertDB IO TestBlock) IO) where GetWeightSnapshot -> do perasCertDB <- get lift $ atomically $ forgetFingerprint <$> PerasCertDB.getWeightSnapshot perasCertDB + GetLatestCertSeen -> do + perasCertDB <- get + lift $ atomically $ PerasCertDB.getLatestCertSeen perasCertDB GarbageCollect slot -> do perasCertDB <- get lift $ PerasCertDB.garbageCollect perasCertDB slot @@ -177,6 +184,11 @@ instance RunModel Model (StateT (PerasCertDB IO TestBlock) IO) where counterexamplePost $ "Model: " <> show expected counterexamplePost $ "SUT: " <> show actual pure $ expected == actual + postcondition (Model model, _) GetLatestCertSeen _ actual = do + let expected = Model.getLatestCertSeen model + counterexamplePost $ "Model: " <> show expected + counterexamplePost $ "SUT: " <> show actual + pure $ expected == actual postcondition _ _ _ _ = pure True monitoring (Model model, _) (AddCert cert) _ _ prop = From f462de1d46faf4127cfe26379692870f9e6295d9 Mon Sep 17 00:00:00 2001 From: Thomas BAGREL Date: Mon, 10 Nov 2025 16:12:32 +0100 Subject: [PATCH 41/43] Move current ObjectDiffusion implementation to `Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.V1` --- .../Ouroboros/Consensus/Network/NodeToNode.hs | 4 ++-- .../Ouroboros/Consensus/Node/GSM/PeerState.hs | 2 +- .../Ouroboros/Consensus/NodeKernel.hs | 2 +- ouroboros-consensus/ouroboros-consensus.cabal | 4 ++-- .../ObjectDiffusion/{Inbound.hs => Inbound/V1.hs} | 4 ++-- .../MiniProtocol/ObjectDiffusion/Inbound/{ => V1}/State.hs | 2 +- .../Consensus/MiniProtocol/ObjectDiffusion/PerasCert.hs | 4 ++-- .../Test/Consensus/MiniProtocol/ObjectDiffusion/Smoke.hs | 4 ++-- 8 files changed, 13 insertions(+), 13 deletions(-) rename ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/{Inbound.hs => Inbound/V1.hs} (99%) rename ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Inbound/{ => V1}/State.hs (99%) 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 964a823c53..66b82f8271 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 @@ -70,8 +70,8 @@ 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 +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.V1 (objectDiffusionInbound) +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.V1.State ( ObjectDiffusionInboundStateView , bracketObjectDiffusionInbound ) 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 index defc3abe33..ce092dad15 100644 --- 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 @@ -17,7 +17,7 @@ import Ouroboros.Consensus.MiniProtocol.ChainSync.Client.State , ChainSyncClientHandleCollection (..) , ChainSyncState (..) ) -import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.State +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.V1.State ( ObjectDiffusionInboundHandle (..) , ObjectDiffusionInboundHandleCollection (..) , ObjectDiffusionInboundState (..) 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 e9d74bc897..f1b4a426c4 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 @@ -82,7 +82,7 @@ import Ouroboros.Consensus.MiniProtocol.ChainSync.Client.HistoricityCheck import Ouroboros.Consensus.MiniProtocol.ChainSync.Client.InFutureCheck ( SomeHeaderInFutureCheck ) -import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.State +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.V1.State ( ObjectDiffusionInboundHandleCollection (..) , newObjectDiffusionInboundHandleCollection ) diff --git a/ouroboros-consensus/ouroboros-consensus.cabal b/ouroboros-consensus/ouroboros-consensus.cabal index c4a684f94b..674c296858 100644 --- a/ouroboros-consensus/ouroboros-consensus.cabal +++ b/ouroboros-consensus/ouroboros-consensus.cabal @@ -191,8 +191,8 @@ 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.Inbound.V1 + Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.V1.State Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.PerasCert Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Outbound 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/V1.hs similarity index 99% rename from ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Inbound.hs rename to ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Inbound/V1.hs index 9253f95638..e19eb43302 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Inbound.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Inbound/V1.hs @@ -11,7 +11,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -module Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound +module Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.V1 ( objectDiffusionInbound , TraceObjectDiffusionInbound (..) , ObjectDiffusionInboundError (..) @@ -38,7 +38,7 @@ import Data.Word (Word64) import GHC.Generics (Generic) import Network.TypedProtocol.Core (N (Z), Nat (..), natToInt) import NoThunks.Class (NoThunks (..)) -import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.State +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.V1.State ( ObjectDiffusionInboundStateView (..) ) import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API 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/V1/State.hs similarity index 99% rename from ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Inbound/State.hs rename to ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Inbound/V1/State.hs index 58402da64f..3aa84c3915 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Inbound/State.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Inbound/V1/State.hs @@ -6,7 +6,7 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} -module Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.State +module Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.V1.State ( ObjectDiffusionInboundState (..) , initObjectDiffusionInboundState , ObjectDiffusionInboundHandle (..) 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 index 5c024618b0..c86cef1707 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/PerasCert.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/PerasCert.hs @@ -14,8 +14,8 @@ module Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.PerasCert ) where import Ouroboros.Consensus.Block -import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound -import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.State +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.V1 +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.V1.State import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Outbound import Ouroboros.Consensus.Storage.PerasCertDB.API 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 index 8e12f01d6d..3553b8cc68 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/Smoke.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/Smoke.hs @@ -28,10 +28,10 @@ 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 +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.V1 ( objectDiffusionInbound ) -import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.State +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.V1.State ( ObjectDiffusionInboundStateView (..) ) import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API From 53fd6f7900cd4403b5cb2be0ee219079b0a2e6ca Mon Sep 17 00:00:00 2001 From: Thomas BAGREL Date: Mon, 10 Nov 2025 16:16:39 +0100 Subject: [PATCH 42/43] Experimental implementation of ObjectDiffusion V2 (Inbound side) --- ouroboros-consensus/ouroboros-consensus.cabal | 7 + .../ObjectDiffusion/Inbound/V2.hs | 209 +++++++++ .../ObjectDiffusion/Inbound/V2.md | 194 ++++++++ .../ObjectDiffusion/Inbound/V2/Decision.hs | 408 ++++++++++++++++ .../ObjectDiffusion/Inbound/V2/Registry.hs | 363 +++++++++++++++ .../ObjectDiffusion/Inbound/V2/State.hs | 438 ++++++++++++++++++ .../ObjectDiffusion/Inbound/V2/Types.hs | 298 ++++++++++++ 7 files changed, 1917 insertions(+) create mode 100644 ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Inbound/V2.hs create mode 100644 ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Inbound/V2.md create mode 100644 ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Inbound/V2/Decision.hs create mode 100644 ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Inbound/V2/Registry.hs create mode 100644 ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Inbound/V2/State.hs create mode 100644 ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Inbound/V2/Types.hs diff --git a/ouroboros-consensus/ouroboros-consensus.cabal b/ouroboros-consensus/ouroboros-consensus.cabal index 674c296858..7de0ecce2d 100644 --- a/ouroboros-consensus/ouroboros-consensus.cabal +++ b/ouroboros-consensus/ouroboros-consensus.cabal @@ -193,6 +193,11 @@ library Ouroboros.Consensus.MiniProtocol.LocalTxSubmission.Server Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.V1 Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.V1.State + Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.V2 + Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.V2.Decision + Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.V2.Registry + Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.V2.State + Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.V2.Types Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.PerasCert Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Outbound @@ -354,6 +359,8 @@ library primitive, psqueues ^>=0.2.3, quiet ^>=0.2, + random, + random-shuffle, rawlock ^>=0.1.1, resource-registry ^>=0.1, semialign >=1.1, diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Inbound/V2.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Inbound/V2.hs new file mode 100644 index 0000000000..f750434853 --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Inbound/V2.hs @@ -0,0 +1,209 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.V2 + ( -- * ObjectDiffusion Inbound client + objectDiffusionInbound + + -- * PeerStateAPI + , withObjectDiffusionInboundPeer + , PeerStateAPI + + -- * Supporting types + , module V2 + , PeerDecisionChannelsVar + , newPeerDecisionChannelsVar + , DecisionPolicy (..) + ) where + +import Control.Concurrent.Class.MonadSTM (MonadSTM, atomically) +import Control.Monad.Class.MonadThrow +import Control.Tracer (Tracer, traceWith) +import Data.List.NonEmpty qualified as NonEmpty +import Data.Set qualified as Set +import Network.TypedProtocol +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.V2.Registry +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.V2.Types as V2 +import Ouroboros.Network.ControlMessage (ControlMessage (..), ControlMessageSTM) +import Ouroboros.Network.Protocol.ObjectDiffusion.Inbound + +-- | A object-diffusion inbound side (client). +-- +-- The steps are as follow +-- 1. Block on next decision from the decision logic +-- 2. Handle any available reply (`goCollect`) +-- 3. Request new objects if possible (`goReqObjects`) +-- 4. Request new ids (also responsible for ack) (`goReqIds`) +-- 5. Signal psaOnDecisionCompleted (as part of `goReqIds{Blocking,NonBlocking}`) +-- And loop again +-- +-- The architecture/code org of this module should make sure we don't go again +-- into `goIdle` until `psaOnDecisionCompleted` has been called +-- +-- NOTE: each `go____` function is responsible for calling the next one in order +-- to continue the protocol. +-- E.g. `goReqObjects` will call `goReqIds` whatever the outcome of its logic is. +objectDiffusionInbound :: + forall objectId object m. + ( MonadThrow m + , MonadSTM m + ) => + Tracer m (TraceObjectDiffusionInbound objectId object) -> + ControlMessageSTM m -> + PeerStateAPI m objectId object -> + ObjectDiffusionInboundPipelined objectId object m () +objectDiffusionInbound + tracer + controlMessageSTM + PeerStateAPI + { psaReadDecision + , psaOnDecisionCompleted + , psaOnRequestIds + , psaOnRequestObjects + , psaOnReceiveIds + , psaOnReceiveObjects + } = + ObjectDiffusionInboundPipelined $ goIdle Zero + where + goIdle :: forall (n :: N). Nat n -> InboundStIdle n objectId object m () + goIdle n = WithEffect $ do + ctrlMsg <- atomically controlMessageSTM + traceWith tracer $ TraceObjectDiffusionInboundReceivedControlMessage 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 -> do + -- Block on next decision. + decision <- psaReadDecision + traceWith tracer (TraceObjectDiffusionInboundReceivedDecision decision) + pure $ goCollect n decision + + -- \| Block until all replies of pipelined requests have been received, then + -- sends `MsgDone` to terminate the protocol. + terminateAfterDrain :: + Nat n -> InboundStIdle n objectId object m () + terminateAfterDrain = \case + Zero -> WithEffect $ do + traceWith tracer TraceObjectDiffusionInboundTerminated + pure $ SendMsgDone () + Succ n -> CollectPipelined Nothing $ \_ignoredMsg -> terminateAfterDrain n + + -- \| Handle potential available replies before continuing with `goReqObjects`. + -- + -- If there are no pipelined requests, this will directly call `goReqObjects`. + -- If there are pipelined requests, it will collect as many replies as + -- possible before continuing with `goReqObjects` once no more replies are + -- immediately available. + goCollect :: Nat n -> PeerDecision objectId object -> InboundStIdle n objectId object m () + goCollect Zero decision = + goReqObjects Zero decision + goCollect (Succ n) decision = + CollectPipelined + (Just $ goReqObjects (Succ n) decision) + ( \case + CollectObjectIds numIdsRequested ids -> WithEffect $ do + psaOnReceiveIds numIdsRequested ids + pure $ goCollect n decision + CollectObjects _objectIds objects -> WithEffect $ do + -- TODO: We could try to validate objects here, i.e. + -- as early as possible, instead of validating them when adding + -- them to the ObjectPool, in order to pivot away from + -- adversarial peers as soon as possible. + psaOnReceiveObjects objects + pure $ goCollect n decision + ) + + -- \| Request objects, if the set of ids of objects to request in the + -- decision is non-empty. + -- Regardless, it will ultimately call `goReqIds`. + goReqObjects :: + Nat n -> + PeerDecision objectId object -> + InboundStIdle n objectId object m () + goReqObjects n decision = do + let objectIds = rodObjectsToReqIds (pdReqObjects decision) + if Set.null objectIds + then + goReqIds n decision + else WithEffect $ do + psaOnRequestObjects objectIds + pure $ + SendMsgRequestObjectsPipelined + (Set.toList objectIds) + (goReqIds (Succ n) decision) + + -- \| Request objectIds, either in a blocking or pipelined fashion depending + -- on the decision's `ridCanPipelineIdsRequests` flag. + -- In both cases, once done, we will ultimately call `psaOnDecisionCompleted` + -- and return to `goIdle`. + goReqIds :: + forall (n :: N). + Nat n -> + PeerDecision objectId object -> + InboundStIdle n objectId object m () + goReqIds n decision = do + let canPipelineIdRequests = ridCanPipelineIdsRequests (pdReqIds decision) + if canPipelineIdRequests + then goReqIdsPipelined n decision + else case n of + Zero -> goReqIdsBlocking decision + Succ{} -> error "Impossible to have pipelined requests when we have no known unacknowledged objectIds" + + -- \| Request objectIds in a blocking fashion if the number to request in the + -- decision is non-zero. + -- Regardless, it will ultimately call `psaOnDecisionCompleted` and return to + -- `goIdle`. + goReqIdsBlocking :: + PeerDecision objectId object -> + InboundStIdle Z objectId object m () + goReqIdsBlocking decision = WithEffect $ do + let numIdsToAck = ridNumIdsToAck (pdReqIds decision) + let numIdsToReq = ridNumIdsToReq (pdReqIds decision) + if numIdsToReq == 0 + then do + psaOnDecisionCompleted + pure $ goIdle Zero + else do + psaOnRequestIds numIdsToAck numIdsToReq + psaOnDecisionCompleted + pure $ + SendMsgRequestObjectIdsBlocking + numIdsToAck + numIdsToReq + ( \objectIds -> WithEffect $ do + psaOnReceiveIds numIdsToReq (NonEmpty.toList objectIds) + pure $ goIdle Zero + ) + + -- \| Request objectIds in a pipelined fashion if the number to request in the + -- decision is non-zero. + -- Regardless, it will ultimately call `psaOnDecisionCompleted` and return to + -- `goIdle`. + goReqIdsPipelined :: + forall (n :: N). + Nat n -> + PeerDecision objectId object -> + InboundStIdle n objectId object m () + goReqIdsPipelined n decision = WithEffect $ do + let numIdsToAck = ridNumIdsToAck (pdReqIds decision) + let numIdsToReq = ridNumIdsToReq (pdReqIds decision) + if numIdsToReq == 0 + then do + psaOnDecisionCompleted + pure $ goIdle n + else do + psaOnRequestIds numIdsToAck numIdsToReq + psaOnDecisionCompleted + pure $ + SendMsgRequestObjectIdsPipelined + numIdsToAck + numIdsToReq + (goIdle (Succ n)) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Inbound/V2.md b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Inbound/V2.md new file mode 100644 index 0000000000..1c095a07e2 --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Inbound/V2.md @@ -0,0 +1,194 @@ +# Object Diffusion Inbound Mini-Protocol V2 + +This document describes the inner workings of the inbound side of the `ObjectDiffusion` mini-protocol. A broad description of the whole protocol can be found in section 2.5 of [this document](https://tweag.github.io/cardano-peras/peras-design.pdf). + +- [Object Diffusion Inbound Mini-Protocol V2](#object-diffusion-inbound-mini-protocol-v2) + - [General architecture](#general-architecture) + - [Inbound peer loop](#inbound-peer-loop) + - [Peer state description and lifecycle](#peer-state-description-and-lifecycle) + - [Acknowledgement behavior](#acknowledgement-behavior) + - [Download attribution process in `makeDecisions`](#download-attribution-process-in-makedecisions) + - [On peer disconnection](#on-peer-disconnection) + - [Differences with TxSubmission V2 inbound mini-protocol](#differences-with-txsubmission-v2-inbound-mini-protocol) + +## General architecture + +In `ObjectDiffusion` V2 (only the inbound side changes compared to V1), each connection to an outbound peer is no longer considered in isolation. Instead, there is a global state `peerStates :: Map peerAddr (PeerState objectId object)` made individual `PeerState`s (defined in `Types.hs`) that each track the state of a given connection. Further on, we denote _an instance of the inbound protocol connected to a specific outbound peer_ simply as _an inbound peer_. + +A `PeerState` holds the state of the interaction with the distant outbound peer, which is described in more details in [this section](#fields-of-peerstate-and-their-lifecycle). + +The global state is read periodically from a dedicated _decision_ thread (defined in `Registry.hs` and `Decision.hs`), and for each inbound peer computes a `PeerDecision` (defined in `Types.hs`) that indicates what the inbound peer should do next. The decision is made of two parts, `ReqIdsDecision` and `ReqObjectsDecision`. + +The `ReqIdsDecision` gives the necessary information for the inbound peer to request new IDs from the outbound peer, and is made of the following fields: + +- `ridIdsToReq`: number of new IDs to request from the outbound peer +- `ridIdsToAck`: number of IDs that the peer should ack in its next request for IDs. Note that if `ridIdsToReq` is zero, then no request for IDs will be sent, and thus no acknowledgment will happen despite `ridIdsToAck` being non-zero (we might change the decision process in the future to get rid of this non-intuitive case). +- `ridCanPipelineIdsReq`: a flag indicating whether the peer can pipeline its requests for IDs (instead of making a blocking call). + +The `ReqObjectsDecision` gives the necessary information for the inbound peer to request new objects from the outbound peer, and is made of the following field: + +- `rodObjectsToReqIds`: the set of IDs of the objects that the inbound peer should request from the outbound peer. + +An inbound peer (defined in `V2.hs`) has no direct access to the state, neither in write nor read fashion. It only has access to a monadic API `PeerStateAPI` defined in `Registry.hs`. This API has 2 decisions-related callbacks, and 4 state-mutating callbacks. It should follow the decision and call the state-mutating callbacks accordingly to keep the global state consistent with the actions taken. + +**Decision-related callbacks:** + +- `psaReadDecision` that allows the inbound peer to read the current `PeerDecision` made for itself by the last round of the decision logic. This will block if a new decision is not yet available for this peer. +- `psaOnDecisionCompleted` that allows the inbound peer to signal that it has executed the last decision it read, and that the decision logic should now compute a new decision for this peer + +For that, we wrap the `PeerDecision` in a `PeerDecisioStatus` type that has three variants: `DecisionUnread`, `DecisionBeingActedUpon` and `DecisionCompleted`. Only `DecisionUnread` and `DecisionBeingActedUpon` have a payload of type `PeerDecision`. + +When the status for a peer is of variant `DecisionBeingActedUpon`, the global-state decision logic will not update the decision for this peer (it is locked, or "busy"). + +**State-mutating callbacks:** + +These are the callbacks that the inbound peer must call when it takes the corresponding actions that has been dictated by the decision it read. These callbacks will update the corresponding peer state in the global state. For reference, the fields of this state are documented in [this section](#fields-of-decisionpeerstate-and-their-lifecycle). + +- `psaOnRequestIds` (corresponding to `onRequestIds` from `State.hs`) that must be called when emitting a request for a non-zero amount of new IDs (that will also acks previously received IDs that we no longer care about). Under the hood, `onRequestIds` will increase the `psNumIdsInFlight` count by the requested number of IDs, and remove the acked IDs from `psOutstandingFifo` and `psObjectsAvailableIds`. +- `psaOnReceiveIds` (corresponding to `onReceiveIds` from `State.hs`) that must be called after receiving new IDs from the outbound peer. Under the hood, `onReceiveIds` will decrease the `psNumIdsInFlight` count by **the number of IDs that were requested in the request corresponding to this reply** (it might be more than the number of received IDs), and add the received IDs to `psOutstandingFifo` and `psObjectsAvailableIds`. +- `psaOnRequestObjects` (corresponding to `onRequestObjects` from `State.hs`) that must be called when emitting a request for a non-zero amount of new objects. Under the hood, `onRequestObjects` will remove the requested IDs from `psObjectsAvailableIds` and add them to `psObjectsInflightIds`. +- `psaOnReceiveObjects` (corresponding to `onReceiveObjects` from `State.hs`) that must be called when receiving objects from the outbound peer. Under the hood, `onReceiveObjects` will remove the received IDs from `psObjectsInflightIds`, and add the received objects to `dpsOwtPool`, and call the `submitObjectsToPool` subroutine that will actually insert the objects into the object pool when the lock can be acquired (at which point the objects are removed from `dpsOwtPool`) + +NOTE: Protocol error-handling (e.g. making sure the outbound peer has sent the correct information) is done by the callback themselves, so the inbound peer doesn't have to check anything before calling these state-mutating callbacks. Preconditions that should hold, but don't due to implementation errors, are tested with `assert` throughout the code. This ensures a modicum of correctness as long as the code is sufficiently tested. + +## Inbound peer loop + +The inbound peer performs a loop where each iteration starts with (blocking on) reading a new decision, and ends with signaling that the decision has been executed. It should not return to the start of the loop too early, i.e., before it has taken all the actions dictated by the decision, as the decision logic considers that once a decision has been read, it is effectively "busy in" and will be performed. So in each iteration, the inbound peer should do the following steps in order: + +1. Read the current decision via `psaReadDecision` +2. Then try to read any available reply from the outbound peer if there have been pipelined requests in previous rounds. It should process the reply accordingly, and call either `psaOnReceiveIds` or `psaOnReceiveObjects` as needed +3. Then request objects (if any) as per `rodObjectsToReqIds`, and call `psaOnRequestObjects` accordingly +4. Then request IDs (if any) as per `ridIdsToReq` (acking `ridIdsToAck` as a side-effect), and call `psaOnRequestIds` accordingly +5. Call `psaOnDecisionExecuted` to signal that a new decision should be made for this peer + +In the implementation, steps 2, 3, 4 are performed by the `goCollect`, `goReqIds` and `goReqObjects` functions in `V2.hs` that each call the next one in sequence as needed. + +NOTE: The decision logic doesn't assume that we will first request objects, then only (request and) acknowledge IDs. Consequently, the decision logic won't ever ask to request objects whose IDs would be acknowledged in that same round. + +## Peer state description and lifecycle + +The following diagram indicates when and by whom fields of the `PeerState` of an inbound peer are modified. + +Fields of `PeerState` are represented as rounded rectangles, while callbacks/functions are represented as diamond shapes. The entry point of the diagram is the `makeDecisions / psaReadDecision` node, that dictates the actions to be taken by the inbound peer, that are then reflected through the `onRequestIds` and `onRequestObjects` callbacks. + +Normal arrows `->` take their source from a function, and points towards a field that is modified by this function. The label on the arrow indicates, by the sign, whether something is added _or_ removed from the field, and also the nature of the value (count, ids, objects) being added or removed. + +Arrows with rounded head show an external input of data, i.e. when the inbound peer actually receives data from the outbound peer. + +```mermaid +%%{init: {"flowchart": {"htmlLabels": true}} }%% +flowchart TD + A(psNumIdsInFlight) + B(psOutstandingFifo) + C(psObjectsAvailableIds) + D(psObjectsInflightIds) + F(psObjectsOwtPool) + + EA{onRequestIds} + EA-->|+count| A + EA -->|"`-ids (ack)`"| B + EA -->|"`-ids (non-downloaded only, ack)`"| C + + EB{onReceiveIds} + EB -->|-count| A + EB -->|+ids| B + IN1@{ shape: lin-cyl, label: "ids" } --o EB + EB -->|+ids| C + + EC{onRequestObjects} + EC -->|"`-ids (selected for download only)`"| C + EC -->|+ids| D + + ED{onReceiveObjects} + ED -->|-ids| D + IN2@{ shape: lin-cyl, label: "objects" } --o ED + ED -->|+objects| F + + EE{makeDecisions / psaReadDecision} + EA ~~~ EE + EC ~~~ EE + EE -.-o|ridIdsToAck + ridIdsToReq + ridCanPipelineIdsReq| EA + EE -.-o|rodObjectsToReqIds| EC + + EG{Added to pool} + EG -->|-objects| F +``` + +### Fields of `PeerState` and their lifecycle + +- `psNumIdsInFlight`: The cumulative number of object IDs we have asked in requests that have not yet been replied to. We need to track this to ensure we don't ask the outbound peer to keep available more objects at a given time than the protocol defined limit (see `dpMaxNumObjectsOutstanding` in `Policy.hs`). This count is incremented in `onRequestIds` by the number of requested IDs, and decremented in `onReceiveIds` by **the same number of requested IDs** when the reply is received. E.g., if we request 10 IDs, then we increment the count by 10; and if later the outbound peer replies with only 7 IDs (because it had only 7 available), we still decrement the count by 10. +- `psOutstandingFifo`: IDs of the objects that the outbound peer has available for us, and which we have not yet acknowledged. This is kept in the order in which the outbound peer gave them to us. It is also the order in which we acknowledge them (because acknowledgment, as in TX-submission, is made by sending the length of the prefix of the FIFO that we no longer care about, instead of providing the IDs as a set). IDs are added to this FIFO in `onReceiveIds`, and removed from this FIFO in `onRequestIds` when we acknowledge (i.e. drop) a prefix of the FIFO. +- `psObjectsAvailableIds`: Set of IDs of the objects that can be requested to the outbound peer, and have not yet been requested or downloaded. This is a subset of `psOutstandingFifo`. IDs are added to this set in `onReceiveIds`. They can be removed from this set in two ways: + - when some objects are requested by their IDs in `onRequestObjects`, the corresponding IDs are removed from `psObjectsAvailableIds` + - for the IDs that were voluntarily not requested (e.g. because we already have obtained them through other peers), they are removed from `psObjectsAvailableIds` when we acknowledge a prefix of the FIFO that contains them +- `psObjectsInflightIds`: The IDs of objects that have been requested to the outbound peer, but have not yet been received. IDs are added to this set in `onRequestObjects` (at the moment they are removed from `psObjectsAvailableIds`), and removed from this set in `onReceiveObjects` (at the moment the corresponding objects are added to `psObjectsOwtPool`). In ObjectDiffusion, we must receive exactly the objects that we requested, so there is no way for some items in this set to stay here indefinitely +- `psObjectsOwtPool`: A map of IDs to objects that have been received, and are on their way to the `ObjectPool`. As we have many inbound peers in parallel, we cannot directly insert objects into the pool when we receive them; instead, we should wait to obtain the pool lock. So we store the received objects here in the meantime, and the subroutine `submitObjectsToPool` (launched by `onReceiveObjects`) will acquire the lock and insert them into the pool when possible, and thus remove them from `psObjectsOwtPool` at that moment. + +## Acknowledgement behavior + +The ID of an object is eligible for acknowledgement from a given inbound peer when: + +- The corresponding object has been downloaded from its direct outbound peer, and is currently in `psObjectsOwtPool` of **this** inbound peer +- The corresponding object is already in the pool (either obtained through other inbound peers, or previously downloaded and inserted by this inbound peer) + +So even if the validation of a received object is done at the moment the object is added to pool, there won't be any issue. Take the example of an object that is rejected by the pool (because it has invalid cryptographic signature, for example). In this case: + +- the inbound peer that submitted the object to pool might have acked it already at the moment the object is rejected by the pool, but the rejection indicates that the outbound peer which sent us the object is adversarial, and we should disconnect from it anyway. So there is no harm done by having acked the object to the adversarial outbound peer, as we won't want to re-download this object from it again (or any other object whatsoever). +- any other inbound peer that has this ID available from its outbound peer won't be able to ack it because this ID isn't in **their** `psObjectsOwtPool`, and is not in the pool either, so we will be able to download it from these other peers until we find a valid one. + +As in TxSubmission, acknowledgement is done by indicating to the outbound peer the length of the (longest) prefix of the oustanding FIFO that we no longer care about (i.e. for which all IDs are eligible to acknowledgment by the definition above). The field `psOutstandingFifo` on the inbound peer is supposed to mirror exactly the state of the FIFO of the outbound peer, bar eventual discrepancies due to in-flight information. + +## Download attribution process in `makeDecisions` + +When making decisions, we first divide the peers in two groups: + +- Those who are currently executing a decision, i.e., those for which the status in the decision channel is of variant `DecisionBeingActedUpon`. These are further called _busy peers_. +- Those who are not currently executing a decision, i.e., those for which the status in the decision channel is of variant `DecisionUnread` or `DecisionCompleted`. The former are the ones who didn't have time to read the previous decision yet, so it makes sense to recompute a more up-to-date decision for them. The latter are the ones who have completed executing the previous decision, so it also makes sense to compute a new decision for them. These two categories of peers are further called _pending peers_. + +The rest of the decision logic will only aim to compute new decisions for the pending peers, while busy peers will keep their current decision until they complete executing it. But we need a few information from busy peers to drive the decision for pending peers. + +The first step is to pre-compute which acknowledgment each pending peer will make on its next request for IDs, and how many IDs they should request. This is done by the `makeReqIdsAndAckDecisions` function in `Decision.hs`, that produces `ReqIdsDecision`s (i.e. the first component of a `PeerDecision`). + +Then we decide which objects should be downloaded from which pending peer in the `makeReqObjectsDecisions` function. + +More concretely, we list from each peer which are the interesting available objects, i.e. the objects that match this two criteria: + +- They are not already in the pool +- They are available from the peer, and won't be acked by the peer on its next request for IDs according to the decision computed by `makeReqIdsAndAckDecisions` at the previous step (NOTE: theoretically, this second condition is redundant with other constraints and invariants of the current implementation). + +Then we "reverse" this mapping to obtain a map of object IDs to the set of pending peers that have the corresponding interesting objects available (according to the criteria above), further called _potential providers_. + +Now, we consider how many copies of each object are already in the process of being acquired. We count as "in the process of being acquired" any object that is either: + +- in `dpsObjectsInFlightIds` of any pending peer +- in `dpsObjectsInFlightIds` **or** in `rodObjectsToReqIds` of any busy peer (because we consider that a busy peer will execute its decision to completion, even if `onRequestObjects`, that adds items to `dpsObjectsInFlightIds`, hasn't been called yet by it) +- in `psObjectsOwtPool` of any peer + +For each object, sequentially, we then try to select as many providers as the difference between the redundancy target (`dpTargetObjectRedundancy` in `Policy.hs`) and the number of copies of this object already in the process of being acquired. But we also make sure, when selecting providers, that we don't go beyond the limit of objects in flight for each potential provider, and that we don't go beyond the limit of total objects in flight for our node too (defined by `dpMaxNumObjectsInflightPerPeer` and `dpMaxNumObjectsInflightTotal` in `Policy.hs`). For the computation of total number of objects in flight, we consider objects already in flight from all peers, plus the objects that are going to be requested from busy peers according to their current decision. + +The result is a map from pending peers to the set of object IDs that should be requested from them; this forms a `ReqObjectsDecision`. We join the `ReqIdsDecision` and `ReqObjectsDecision` of each peer to form the final `PeerDecision` of each pending peer, that are then propagated to the peers through their decision channels (in `Registry.hs`). + +At the moment, the algorithm is eager towards securing the target number of copies for each object, at the detriment of object coverage and peer load balancing. Future improvements could be made to address this if needed. + +NOTE: the decision logic doesn't make any changes to the global state; it only reads it. All changes to the global state are made by the inbound peers through the `PeerStateAPI` callbacks. + +## On peer disconnection + +The inbound peers are registered in the global state and decision channels map through a `bracket` function in `Registry.hs`. When a peer disconnects, the corresponding entry in the decision channels map and global state are automatically removed. + +As the global state is only a map of per-peer states at the moment, this means that we don't need to take any other particular action to clean up the global state following the disconnection of a peer. + +Any error protocol-wise (e.g. receiving invalid data from the outbound peer) or receiving objects that are rejected by the pool (e.g. if they don't have valid cryptographic signatures) should throw an exception, that will automatically lead to disconnection (and thus triggering cleanup). + +Following a peer disconnection, the next round of decision-logic will readjust accordingly. For example, if some object was in the process of being downloaded from the disconnected peer, the next round of the decision logic will see that we have fewer copies in the process of being acquired than before, and thus will ask other providers to download it. + +## Differences with TxSubmission V2 inbound mini-protocol + +Although both mini-protocol inbound implementations share the same general structure (global state and global decision thread, with peer registering through a bracket function, peer interacting through an API with the global state), there are some major differences in the implementation: + +- ObjectDiffusion decision process doesn't modify the global state at all, unlike TxSubmission one. This is true for acknowledgment computation too (that is part of decision making). Instead, all modifications to the global state are made by the inbound peers through the `PeerStateAPI` callbacks. This makes the decision logic more straighforward +- ObjectDiffusion decision process doesn't pre-filter peers based on their individual `PeerState` to know whether or not we should generate a decision for them. Instead, we use the different variants of `PeerDecisionStatus` (updated through the `psaReadDecision` and `psaOnDecisionCompleted` callbacks), to know whether or not we should compute a new decision for a peer. The conditions on which we compute a new decision are also different: we compute a new decision for a peer if it is not currently executing a decision (i.e. its status is of variant `DecisionUnread` or `DecisionCompleted`), instead of checking various fields of its `PeerState`. +- ObjectDiffusion relies on `opwHasObject` method of the `ObjectPoolWrapper` to know whether or not an object is already in the pool, instead of tracking this information in the global state with a retention delay. This simplifies the global state and implementation a lot, but depends on the implementation of the `ObjectPoolWriter` to provide a fairly cost-efficient implementation for `opwHasObject`, as it is called often. +- Similarly, ObjectDiffusion gets rid of many global maps that were slightly redundant with information already present in each peer's state, as the only time we need to use these maps are during decision-making. So for the time being, we recompute the specific parts of this global view that we need at each round of decision-making, instead of maintaining them up-to-date at all times. We might need to revisit this later for performance purposes if needed. +- ObjectDiffusion also doesn't have a concept of ranking/scoring for peers, as an invalid object must lead to immediate disconnection. So the decision logic doesn't need to consider peer quality when attributing downloads. +- In ObjectDiffusion, the global state is not modified directly outside of `State.hs` (and `Registry.hs` when registering/unregistering peers). diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Inbound/V2/Decision.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Inbound/V2/Decision.hs new file mode 100644 index 0000000000..29e59abb7c --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Inbound/V2/Decision.hs @@ -0,0 +1,408 @@ +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.V2.Decision (makeDecisions) where + +import Control.Exception (assert) +import Data.Foldable qualified as Foldable +import Data.Map.Merge.Strict qualified as Map +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Sequence.Strict (StrictSeq) +import Data.Sequence.Strict qualified as StrictSeq +import Data.Set (Set) +import Data.Set qualified as Set +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.V2.State +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.V2.Types +import Ouroboros.Network.Protocol.ObjectDiffusion.Type +import System.Random (StdGen) +import System.Random.Shuffle (shuffle') + +strictSeqToSet :: Ord a => StrictSeq a -> Set a +strictSeqToSet = Set.fromList . Foldable.toList + +newtype Pending a = Pending a +newtype Busy a = Busy a + +splitPeerStates :: + Ord peerAddr => + Map peerAddr (PeerState objectId object) -> + Map peerAddr (PeerDecisionStatus objectId object) -> + ( Pending (Map peerAddr (PeerState objectId object)) + , Busy (Map peerAddr (PeerState objectId object, Set objectId)) + ) +splitPeerStates peerStates peerDecisions = + let peerStatesAndDecisions = Map.intersectionWith (,) peerStates peerDecisions + (pending, busy) = + Map.mapEither + ( \(state, status) -> + case status of + PeerDecisionBeingActedUpon decision -> + Right (state, rodObjectsToReqIds (pdReqObjects decision)) + _ -> Left state + ) + peerStatesAndDecisions + in (Pending pending, Busy busy) + +-- | Make download decisions. +makeDecisions :: + forall peerAddr objectId object. + ( Ord peerAddr + , Ord objectId + ) => + DecisionContext peerAddr objectId object -> + -- | New decisions + Map peerAddr (PeerDecision objectId object) +makeDecisions + DecisionContext + { dcRng + , dcHasObject + , dcDecisionPolicy + , dcPeerStates + , dcPrevDecisions + } = + let + (pendingPeersStates, busyPeerStatesAndObjectToReqIds) = + splitPeerStates dcPeerStates dcPrevDecisions + -- We do it in two steps, because computing the acknowledgment tell which + -- objects from psObjectsAvailableIds sets of each peer won't actually be + -- available anymore (as soon as we ack them), so that the makeReqObjectsDecisions + -- function can take this into account. + (reqIdsDecisions, peerToIdsToAck) = + makeReqIdsAndAckDecisions dcHasObject dcDecisionPolicy pendingPeersStates + reqObjectsDecisions = + makeReqObjectsDecisions + dcRng + dcHasObject + dcDecisionPolicy + pendingPeersStates + busyPeerStatesAndObjectToReqIds + peerToIdsToAck + in + Map.intersectionWith + PeerDecision + reqObjectsDecisions + reqIdsDecisions + +-- | The ids to ack are the longest prefix of outstandingFifo of each peer that +-- match the following criteria: +-- * either the object is owt pool for the peer who has downloaded it +-- * or the object is already in pool +makeReqIdsAndAckDecisions :: + forall peerAddr objectId object. + Ord objectId => + (objectId -> Bool) -> + DecisionPolicy -> + Pending (Map peerAddr (PeerState objectId object)) -> + ( Map peerAddr (ReqIdsDecision objectId object) + , Map peerAddr (Set objectId) + ) +makeReqIdsAndAckDecisions + poolHasObject + DecisionPolicy{dpMaxNumObjectIdsReq, dpMaxNumObjectsOutstanding} + (Pending pendingPeerStates) = + let + reqIdsAndAckDecisions = makeReqIdsAndAckDecision <$> pendingPeerStates + in + ( fst <$> reqIdsAndAckDecisions + , snd <$> reqIdsAndAckDecisions + ) + where + makeReqIdsAndAckDecision :: + PeerState objectId object -> + (ReqIdsDecision objectId object, Set objectId) + makeReqIdsAndAckDecision + PeerState + { psOutstandingFifo + , psObjectsOwtPool + , psNumIdsInflight + } = + let + -- we isolate the longest prefix of outstandingFifo that matches our ack + -- criteria (see above in computeAck doc) + (idsToAck, psOutstandingFifo') = + StrictSeq.spanl + (\objectId -> poolHasObject objectId || objectId `Map.member` psObjectsOwtPool) + psOutstandingFifo + + futureFifoSizeOnOutboundPeer :: NumObjectIdsReq = + -- the new known fifo state after we ack the idsToAck + (fromIntegral $ StrictSeq.length psOutstandingFifo') + -- plus the number of ids that we have already requested but we didn't + -- receive yet that the outbound peer might consequently already have + -- added to its fifo + + psNumIdsInflight + + ridNumIdsToReq = + (fromIntegral dpMaxNumObjectsOutstanding - futureFifoSizeOnOutboundPeer) + `min` dpMaxNumObjectIdsReq + + ridNumIdsToAck = + -- in the case where ridNumIdsToReq == 0, we know we actually won't be + -- able to ack anything because we won't emit a request, and acknowledgment + -- is done at the same time as the request for ids + let numIdsToAck = fromIntegral $ StrictSeq.length idsToAck + in assert (not (ridNumIdsToReq == 0 && numIdsToAck > 0)) $ + numIdsToAck + + ridCanPipelineIdsRequests = not . StrictSeq.null $ psOutstandingFifo' + + reqIdsDecision = + ReqIdsDecision + { ridNumIdsToAck + , ridNumIdsToReq + , ridCanPipelineIdsRequests + } + in + (reqIdsDecision, strictSeqToSet idsToAck) + +-- | Order peers randomly based on the provided RNG. +-- We do that to avoid biasing the decision logic towards the peers that +-- would happen to be first in the map default ordering, as that could +-- be exploited by an adversary. +orderPeers :: + StdGen -> + Map peerAddr (PeerState objectId object) -> + [(peerAddr, PeerState objectId object)] +orderPeers rng peerStates = + let peerPairs = Map.toList peerStates + in shuffle' peerPairs (length peerPairs) rng + +data DownloadPickState peerAddr objectId + = DownloadPickState + { totalNumObjectsToReq :: !NumObjectsReq + , objectMultiplicity :: ObjectMultiplicity + , reqObjectsDecisions :: Map peerAddr (Set objectId) + } + +makeReqObjectsDecisions :: + forall peerAddr objectId object. + ( Ord peerAddr + , Ord objectId + ) => + StdGen -> + (objectId -> Bool) -> + DecisionPolicy -> + Pending (Map peerAddr (PeerState objectId object)) -> + -- | Busy peers and the set of ids of objects they are currently requesting + Busy (Map peerAddr (PeerState objectId object, Set objectId)) -> + -- | map from peer to the set of ids that will be acked for that peer on next + -- requestIds. We should treat these ids as not available anymore for the + -- purpose of picking objects to request + Map peerAddr (Set objectId) -> + Map peerAddr (ReqObjectsDecision objectId object) +makeReqObjectsDecisions + rng + poolHasObject + DecisionPolicy + { dpMaxNumObjectsInflightPerPeer + , dpMaxNumObjectsInflightTotal + , dpTargetObjectRedundancy + } + (Pending pendingPeerStates) + (Busy busyPeerStatesAndObjectToReqIds) + peerToIdsToAck = + ReqObjectsDecision <$> decisions + where + -- We order the peers that are not currently executing a decision + orderedPendingPeers = orderPeers rng pendingPeerStates + + -- We want to map each objectId to the sorted list of peers that can provide it + -- For each peer we also indicate how many objects it has in flight at the moment + -- We filter out here the objects that are already in pool. + -- TODO: we may want to consider using a Seq instead of a list when we'll care + -- about performance. + objectsToSortedProviders :: Map objectId [(peerAddr, NumObjectsReq)] + objectsToSortedProviders = + -- We iterate over each peer and the corresponding available ids + -- and turn the map "inside-out" + Foldable.foldl' + ( \accMap (peerAddr, PeerState{psObjectsAvailableIds, psObjectsInflightIds}) -> + let + -- ids that will be acked for this peer won't be available anymore, + -- so we should not consider them in the decision logic + -- + -- TODO: this is quite redundant, because ack can only be made when + -- the object is already in the pool (in which case it would have + -- been filtered out anyway in next step) or when the object is in + -- psObjectsOwtPool of this peer (in which case it shouldn't be + -- anymore in psObjectsAvailableIds) + idsToAckForThisPeer = + Map.findWithDefault + (error "invariant violated: peer must be in peerToIdsToAck map") + peerAddr + peerToIdsToAck + -- we should also remove objects that are already in the pool + interestingAndAvailableObjectIds = + Set.filter (not . poolHasObject) $ + psObjectsAvailableIds `Set.difference` idsToAckForThisPeer + in + -- we iterate over interestingAndAvailableObjectIds and add the + -- peer to the list of providers for each object it can provide + Foldable.foldl' + ( \accMap' objectId -> + Map.insertWith + (++) + objectId + [(peerAddr, fromIntegral $ Set.size psObjectsInflightIds)] + accMap' + ) + accMap + interestingAndAvailableObjectIds + ) + Map.empty + orderedPendingPeers + + -- For busy peers, we should consider that the objects in pdObjectsToReqIds + -- will be requested soon, so we should consider them as inflight for the + -- purpose of picking objects to request for other peers + objectsInFlightMultiplicitiesOfBusyPeers = + Map.foldl' + ( \accMap (PeerState{psObjectsInflightIds}, pdObjectsToReqIds) -> + Foldable.foldl' + (\accMap' objectId -> Map.insertWith (+) objectId 1 accMap') + accMap + (Set.union psObjectsInflightIds pdObjectsToReqIds) + ) + Map.empty + busyPeerStatesAndObjectToReqIds + -- Finally, we add to the previous map the objects that are currently + -- inflight from peers for which we will make a decision in this round + objectsInFlightMultiplicities = + Map.foldl' + ( \accMap (PeerState{psObjectsInflightIds}) -> + Foldable.foldl' + (\accMap' objectId -> Map.insertWith (+) objectId 1 accMap') + accMap + psObjectsInflightIds + ) + objectsInFlightMultiplicitiesOfBusyPeers + pendingPeerStates + + totalNumObjectsInflight :: NumObjectsReq + totalNumObjectsInflight = fromIntegral $ Map.foldl' (+) 0 objectsInFlightMultiplicities + + objectsOwtPoolMultiplicities = + Map.foldl' + ( \accMap (PeerState{psObjectsOwtPool}) -> + Foldable.foldl' + (\accMap' objectId -> Map.insertWith (+) objectId 1 accMap') + accMap + (Map.keys psObjectsOwtPool) + ) + Map.empty + (Map.union (fst <$> busyPeerStatesAndObjectToReqIds) pendingPeerStates) + + -- We also want to know for each objects how many peers have it in the + -- inflight or owtPool, meaning that we should receive them soon. + -- We should also add here the objects that are in the pdObjectsToReqIds of + -- each peer decision for busy peers, if these ids are not already in + -- dpsObjectsInflight or psObjectsOwtPool of this peer + objectsExpectedSoonMultiplicities :: Map objectId ObjectMultiplicity + objectsExpectedSoonMultiplicities = + Map.unionWith + (+) + objectsInFlightMultiplicities + objectsOwtPoolMultiplicities + + -- Now we join objectsToSortedProviders and objectsExpectedSoonMultiplicities + -- maps on objectId for easy fold + objectsToProvidersAndExpectedMultiplicities :: + Map objectId ([(peerAddr, NumObjectsReq)], ObjectMultiplicity) + objectsToProvidersAndExpectedMultiplicities = + Map.merge + -- if an objectId is missing from objectsExpectedSoonMultiplicities, + -- then its expected multiplicity is 0 + (Map.mapMissing $ \_ providers -> (providers, 0)) + -- if an objectId is missing from objectsToSortedProviders, then we + -- don't care about it + Map.dropMissing + -- Combine in a tuple the list of providers and the expected multiplicity + ( Map.zipWithMatched $ \_ providers expectedMultiplicity -> + (providers, expectedMultiplicity) + ) + objectsToSortedProviders + objectsExpectedSoonMultiplicities + + -- NOW HERE TAKE PLACE THE ACTUAL DECISION LOGIC AND ATTRIBUTION OF OBJECTS TO PEERS + + -- The current decision logic is greedy on objects, so it will try to request as + -- many copies of the same object as possible, meaning we will have optimal + -- coverage of the first objects, but might not request some other objects at + -- all if they are (only) provided by peers that are already saturated. + + -- Now we compute the actual attribution of downloads for peers + DownloadPickState{reqObjectsDecisions = decisions} = + -- We iterate over each objectId and the corresponding (providers, expectedMult) + Map.foldlWithKey' + ( \st objectId (providers, expectedMultiplicity) -> + -- reset the objectMultiplicity counter for each new objectId + let st' = st{objectMultiplicity = 0} + in -- We iterate over the list of providers, and pick them or not + -- according to the current state. + -- When a peer is selected as a provider for this objectId, we + -- insert the objectId in the peer's set in reqObjectsDecisions + -- (inside St), so the result of the filtering of providers is + -- part of the final St state + Foldable.foldl' + (conditionallyPickProviders objectId expectedMultiplicity) + st' + providers + ) + DownloadPickState + { totalNumObjectsToReq = 0 + , objectMultiplicity = 0 + , reqObjectsDecisions = Map.empty + } + objectsToProvidersAndExpectedMultiplicities + + -- This function decides whether or not we should select a given peer as + -- provider for the current objectId. It takes into account if we are + -- expecting to obtain the object from other sources (either inflight/owt + -- pool already, or if the object will be requested from already selected + -- peers in this given round) + conditionallyPickProviders :: + objectId -> + ObjectMultiplicity -> + DownloadPickState peerAddr objectId -> + (peerAddr, NumObjectsReq) -> + DownloadPickState peerAddr objectId + conditionallyPickProviders + objectId + expectedMultiplicity + st@DownloadPickState + { totalNumObjectsToReq + , objectMultiplicity + , reqObjectsDecisions + } + (peerAddr, numObjectsInFlight) = + let + -- see what has already been attributed to this peer + objectsToReq = Map.findWithDefault Set.empty peerAddr reqObjectsDecisions + numObjectsToReq = fromIntegral (Set.size objectsToReq) + + shouldSelect = + -- We should not go over the multiplicity limit per object + objectMultiplicity + expectedMultiplicity < dpTargetObjectRedundancy + -- We should not go over the total number of objects inflight limit + && totalNumObjectsInflight + totalNumObjectsToReq < dpMaxNumObjectsInflightTotal + -- We should not go over the per-peer number of objects inflight limit + && numObjectsInFlight + numObjectsToReq < dpMaxNumObjectsInflightPerPeer + in + if shouldSelect + then + -- We increase both global count and per-object count, and we add + -- the object to the peer's set + DownloadPickState + { totalNumObjectsToReq = totalNumObjectsToReq + 1 + , objectMultiplicity = objectMultiplicity + 1 + , reqObjectsDecisions = + Map.insert + peerAddr + (Set.insert objectId objectsToReq) + reqObjectsDecisions + } + -- Or we keep the state as is if we don't select this peer + else st diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Inbound/V2/Registry.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Inbound/V2/Registry.hs new file mode 100644 index 0000000000..e8c6d7e8da --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Inbound/V2/Registry.hs @@ -0,0 +1,363 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.V2.Registry + ( PeerDecisionChannels + , PeerDecisionChannelsVar + , ObjectPoolSem + , PeerStatesVar + , newPeerDecisionChannelsVar + , newObjectPoolSem + , PeerStateAPI (..) + , withObjectDiffusionInboundPeer + , decisionLogicThread + ) where + +import Control.Concurrent.Class.MonadSTM.Strict +import Control.Monad (forever) +import Control.Monad.Class.MonadFork +import Control.Monad.Class.MonadThrow +import Control.Monad.Class.MonadTimer.SI +import Control.Monad.IO.Class (MonadIO) +import Control.Tracer (Tracer, traceWith) +import Data.Foldable as Foldable (traverse_) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Sequence.Strict qualified as StrictSeq +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Void (Void) +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.V2.Decision +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.V2.State qualified as State +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.V2.Types +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API +import Ouroboros.Network.Protocol.ObjectDiffusion.Type (NumObjectIdsAck, NumObjectIdsReq) +import System.Random (initStdGen) + +-- | Communication channels between `ObjectDiffusion` mini-protocol inbound side +-- and decision logic. +type PeerDecisionChannels m peerAddr objectId object = + Map peerAddr (StrictTVar m (PeerDecisionStatus objectId object)) + +type PeerDecisionChannelsVar m peerAddr objectId object = + StrictTVar m (PeerDecisionChannels m peerAddr objectId object) + +newPeerDecisionChannelsVar :: + MonadSTM m => m (PeerDecisionChannelsVar m peerAddr objectId object) +newPeerDecisionChannelsVar = newTVarIO (Map.empty) + +data PeerStateAPI m objectId object = PeerStateAPI + { psaReadDecision :: m (PeerDecision objectId object) + -- ^ A blocking action which reads the `PeerDecision` for this peer from the + -- decision channel. + -- It blocks until a new decision (i.e. with status `DecisionUnread`) is + -- emitted for the peer by the decision thread, and immediately turn its + -- status to `DecisionBeingActedUpon`. + -- + -- PRECONDITIONS: + -- * The decision in the channel has status `DecisionUnread` or `DecisionCompleted` + -- POSTCONDITIONS: + -- * The decision in the channel has status `DecisionBeingActedUpon` + , psaOnDecisionCompleted :: m () + -- ^ To be called by the peer when it has fully executed the decision. + -- Marks the peer as available for the decision logic. + -- + -- PRECONDITIONS: + -- * The decision in the channel has status `DecisionBeingActedUpon` + -- POSTCONDITIONS: + -- * The decision in the channel has status `DecisionCompleted` + , psaOnRequestIds :: NumObjectIdsAck -> NumObjectIdsReq -> m () + -- ^ To be called when emitting a request for new IDs (that also acks + -- previously received IDs that we no longer care about). Under the hood, it + -- will increase the `psNumIdsInFlight` count by the requested number of IDs, + -- and remove the acked IDs from `psOutstandingFifo` and `psObjectsAvailableIds`. + -- Note that those IDs may not be present in the latter, if they have already + -- been requested to the outbound peer. + -- + -- PRECONDITIONS: + -- * `psOutstandingFifo` has at least `nAck :: NumObjectIdsAck` IDs that will + -- be removed from it + -- POSTCONDITIONS: + -- * The `nAck` first IDs from `psOutstandingFifo` are removed from + -- `psOutstandingFifo` and removed from `psObjectsAvailableIds` + , psaOnRequestObjects :: Set objectId -> m () + -- ^ To be called when emitting a request for new objects. Under the hood, it + -- will remove the requested IDs from `psObjectsAvailableIds` and add them to + -- `psObjectsInflightIds`. + -- + -- PRECONDITIONS: + -- * The requested IDs are a subset of `psObjectsAvailableIds` + -- * The requested IDs are not in `psObjectsInflightIds` + -- POSTCONDITIONS: + -- * The requested IDs are removed from `psObjectsAvailableIds` + -- * The requested IDs are now in `psObjectsInflightIds` + , psaOnReceiveIds :: NumObjectIdsReq -> [objectId] -> m () + -- ^ To be called after receiving new IDs from the outbound peer, after + -- validating that we received the correct number (not more than requested). + -- Under the hood, it will decrease the `psNumIdsInFlight` count by **the + -- number of IDs that were requested in the request corresponding to this reply**. + -- This number might be more than the number of received IDs. It also add the + -- received IDs to `psOutstandingFifo` and `psObjectsAvailableIds`. + -- + -- PRECONDITIONS: + -- * The number of received IDs is less than or equal to `nReq :: NumObjectIdsReq` + -- (the number of IDs that were requested in the request corresponding to this reply) + -- * The received IDs are not already in `psObjectsAvailableIds` nor in + -- `psObjectsInflightIds` nor in `psObjectsOwtPool` + -- * The received IDs do not contain duplicates + -- * `psNumIdsInFlight` is greater than or equal to `nReq :: NumObjectIdsReq` + -- POSTCONDITIONS: + -- * `psNumIdsInflight` is `nReq` less than before + -- * `psOutstandingFifo` contains the received IDs appended at the end in the + -- same order as they were received + -- * `psObjectsAvailableIds` contains the received IDs + , psaOnReceiveObjects :: [object] -> m () + -- ^ To be called when receiving objects from the outbound peer, after + -- validating that the received objects match exactly the requested IDs. + -- It also checks that all received objects have valid cryptographic proofs. + -- Under the hood, it will remove the received IDs from `psObjectsInflightIds`, + -- add the received objects to `dpsOwtPool`, and call the `submitObjectsToPool` + -- subroutine that will actually insert the objects into the object pool. + -- + -- PRECONDITIONS: + -- * All received objects are valid wrt. their cryptographic proofs/invariants + -- specific to the object type + -- * The received objects correspond exactly to the set of requested objects + -- (order not mattering) + -- * The IDs of the received objects are a subset of `psObjectsInflightIds` + -- POSTCONDITIONS: + -- * The IDs of the received objects are removed from `psObjectsInflightIds` + -- * `psObjectsOwtPool` contains the received objects + } + +-- | A bracket function which registers / de-registers a new peer in +-- `PeerStatesVar` and `PeerDecisionChannelsVar`s, which exposes `PeerStateAPI`. +-- `PeerStateAPI` is only safe inside the `withObjectDiffusionInboundPeer` scope. +withObjectDiffusionInboundPeer :: + forall object peerAddr objectId m a. + ( MonadMask m + , MonadSTM m + , Ord objectId + , Ord peerAddr + ) => + Tracer m (TraceDecisionLogic peerAddr objectId object) -> + Tracer m (TraceObjectDiffusionInbound objectId object) -> + PeerDecisionChannelsVar m peerAddr objectId object -> + DecisionPolicy -> + PeerStatesVar m peerAddr objectId object -> + ObjectPoolWriter objectId object m -> + ObjectPoolSem m -> + -- | new peer + peerAddr -> + -- | callback which gives access to `PeerStateAPI` + (PeerStateAPI m objectId object -> m a) -> + m a +withObjectDiffusionInboundPeer + decisionTracer + objectDiffusionTracer + decisionChannelsVar + _decisionPolicy + peerStatesVar + objectPoolWriter + objectPoolSem + peerAddr + withAPI = + bracket registerPeerAndCreateAPI unregisterPeer withAPI + where + registerPeerAndCreateAPI :: m (PeerStateAPI m objectId object) + registerPeerAndCreateAPI = atomically $ do + peerToChannel <- readTVar decisionChannelsVar + decisionChan <- case peerToChannel Map.!? peerAddr of + -- Checks if a channel already exists for this peer, in case we reuse it + -- Should not happen normally, because we unregister the peer from the + -- channels map on disconnection through the bracket function + Just chan -> return chan + -- Otherwise create a new channel and register it + Nothing -> do + newChan <- newTVar PeerDecisionCompleted + modifyTVar decisionChannelsVar (Map.insert peerAddr newChan) + return newChan + + let !inboundPeerAPI = + PeerStateAPI + { psaReadDecision = atomically $ do + -- This should block until the decision has status `DecisionUnread` + -- which means it is a new decision that the peer has not acted upon yet + -- If `DecisionCompleted` is read here, it means the decision + -- logic hasn't had time to make a new decision for this peer + decision <- readTVar decisionChan + case decision of + PeerDecisionBeingActedUpon{} -> + error "Forgot to call `psaOnDecisionCompleted` for this peer" + PeerDecisionCompleted -> retry + PeerDecisionUnread dec -> + let decision' = PeerDecisionBeingActedUpon dec + in do + writeTVar decisionChan decision' + return dec + , psaOnDecisionCompleted = atomically $ do + decision <- readTVar decisionChan + case decision of + PeerDecisionUnread{} -> + error + ( "Forgot to call `psaReadDecision` for this peer, or the " + ++ "decision thread has mistakenly updated the decision " + ++ "for this peer while it was executing it" + ) + PeerDecisionCompleted -> + error "`psaOnDecisionCompleted` has already been called for this peer" + PeerDecisionBeingActedUpon{} -> + writeTVar decisionChan PeerDecisionCompleted + , psaOnRequestIds = + State.onRequestIds + objectDiffusionTracer + decisionTracer + peerStatesVar + peerAddr + , psaOnRequestObjects = + State.onRequestObjects + objectDiffusionTracer + decisionTracer + peerStatesVar + peerAddr + , psaOnReceiveIds = + State.onReceiveIds + objectDiffusionTracer + decisionTracer + objectPoolWriter + peerStatesVar + peerAddr + , psaOnReceiveObjects = \objects -> do + status <- atomically $ readTVar decisionChan + case status of + PeerDecisionUnread{} -> + error + ( "The peer shouldn't be processing received objects " + ++ "if it has no decision being acted upon" + ) + PeerDecisionCompleted -> + error + ( "The peer shouldn't be processing received objects if it " + ++ "has finished acting upon its decision" + ) + PeerDecisionBeingActedUpon decision -> do + let objectsToRequest = rodObjectsToReqIds (pdReqObjects decision) + State.onReceiveObjects + objectDiffusionTracer + decisionTracer + peerStatesVar + objectPoolWriter + objectPoolSem + peerAddr + objectsToRequest + objects + } + + -- register the peer in the global state now + modifyTVar peerStatesVar registerPeerPeerStates + -- initialization is complete for this peer, it can proceed and + -- interact through its given API + return inboundPeerAPI + + unregisterPeer :: PeerStateAPI m objectId object -> m () + unregisterPeer _api = + -- the handler is a short blocking operation, thus we need to use + -- `uninterruptibleMask_` + uninterruptibleMask_ $ atomically $ do + -- unregister the peer from the global state + modifyTVar peerStatesVar unregisterPeerPeerStates + -- remove the channel of this peer from the global channel map + modifyTVar decisionChannelsVar (Map.delete peerAddr) + + registerPeerPeerStates :: + Map peerAddr (PeerState objectId object) -> + Map peerAddr (PeerState objectId object) + registerPeerPeerStates peerStates = + Map.insert + peerAddr + PeerState + { psObjectsAvailableIds = Set.empty + , psNumIdsInflight = 0 + , psObjectsInflightIds = Set.empty + , psOutstandingFifo = StrictSeq.empty + , psObjectsOwtPool = Map.empty + } + peerStates + + -- TODO: this function needs to be tested! + -- Issue: https://github.com/IntersectMBO/ouroboros-network/issues/5151 + unregisterPeerPeerStates :: + Map peerAddr (PeerState objectId object) -> + Map peerAddr (PeerState objectId object) + unregisterPeerPeerStates = Map.delete peerAddr + +decisionLogicThread :: + forall m peerAddr objectId object. + ( MonadDelay m + , MonadSTM m + , MonadFork m + , MonadIO m + , Ord peerAddr + , Ord objectId + ) => + Tracer m (TraceDecisionLogic peerAddr objectId object) -> + Tracer m ObjectDiffusionCounters -> + ObjectPoolWriter objectId object m -> + DecisionPolicy -> + PeerDecisionChannelsVar m peerAddr objectId object -> + PeerStatesVar m peerAddr objectId object -> + m Void +decisionLogicThread + decisionTracer + countersTracer + ObjectPoolWriter{opwHasObject} + decisionPolicy@DecisionPolicy{dpDecisionThreadSleepDelay} + decisionChannelsVar + peerStatesVar = do + labelThisThread "ObjectDiffusionInbound.decisionLogicThread" + forever $ do + -- We rate limit the decision making process, it could overwhelm the CPU + -- if there are too many inbound connections. + -- + -- TODO: change that for a watcher pattern based on decisions/global state + -- being updated? + threadDelay dpDecisionThreadSleepDelay + + rng <- initStdGen + + (newDecisions, counters) <- atomically $ do + decisionsChannels <- readTVar decisionChannelsVar + prevDecisions <- traverse readTVar decisionsChannels + peerStates <- readTVar peerStatesVar + hasObject <- opwHasObject + let newDecisions = + makeDecisions + DecisionContext + { dcRng = rng + , dcHasObject = hasObject + , dcDecisionPolicy = decisionPolicy + , dcPeerStates = peerStates + , dcPrevDecisions = prevDecisions + } + + peerToChannel <- readTVar decisionChannelsVar + -- Pair decision channel with the corresponding decision + let peerToChannelAndDecision = + Map.intersectionWith + (,) + peerToChannel + newDecisions + -- Send the newDecisions to the corresponding peers + traverse_ + (\(chan, decision) -> writeTVar chan (PeerDecisionUnread decision)) + peerToChannelAndDecision + + -- Return values for tracing purposes + let counters = makeObjectDiffusionCounters peerStates + return (newDecisions, counters) + + traceWith decisionTracer (TraceDecisionLogicDecisionsMade newDecisions) + traceWith countersTracer counters diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Inbound/V2/State.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Inbound/V2/State.hs new file mode 100644 index 0000000000..d5d142ab40 --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Inbound/V2/State.hs @@ -0,0 +1,438 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.V2.State + ( -- * Core API + PeerState (..) + , onRequestIds + , onRequestObjects + , onReceiveIds + , onReceiveObjects + ) where + +import Control.Concurrent.Class.MonadSTM.Strict +import Control.Concurrent.Class.MonadSTM.TSem +import Control.Exception (assert, throw) +import Control.Monad (when) +import Control.Tracer (Tracer, traceWith) +import Data.Foldable qualified as Foldable +import Data.Map.Strict (Map, findWithDefault) +import Data.Map.Strict qualified as Map +import Data.Sequence.Strict qualified as StrictSeq +import Data.Set (Set, (\\)) +import Data.Set qualified as Set +import GHC.Stack (HasCallStack) +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.V2.Types +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API (ObjectPoolWriter (..)) +import Ouroboros.Consensus.Util.IOLike (MonadMask, bracket_) +import Ouroboros.Network.Protocol.ObjectDiffusion.Type (NumObjectIdsAck, NumObjectIdsReq) + +onRequestIds :: + forall m peerAddr object objectId. + (MonadSTM m, Ord objectId, Ord peerAddr) => + Tracer m (TraceObjectDiffusionInbound objectId object) -> + Tracer m (TraceDecisionLogic peerAddr objectId object) -> + PeerStatesVar m peerAddr objectId object -> + peerAddr -> + NumObjectIdsAck -> + -- | number of requests to req + NumObjectIdsReq -> + m () +onRequestIds + odTracer + decisionTracer + peerStatesVar + peerAddr + numIdsToAck + numIdsToReq = do + peerStates' <- atomically $ do + stateTVar + peerStatesVar + ( \peerStates -> + let peerStates' = onRequestIdsImpl peerAddr numIdsToAck numIdsToReq peerStates + in (peerStates', peerStates') + ) + traceWith odTracer (TraceObjectDiffusionInboundRequestedIds (fromIntegral numIdsToReq)) + traceWith decisionTracer (TraceDecisionLogicPeerStatesUpdated "onRequestIds" peerStates') + +-- Acknowledgment is done when a requestIds is made. +-- That's why we update the psOutstandingFifo and psObjectsAvailableIds here. +onRequestIdsImpl :: + forall peerAddr object objectId. + (Ord objectId, Ord peerAddr) => + peerAddr -> + NumObjectIdsAck -> + -- | number of requests to req + NumObjectIdsReq -> + Map peerAddr (PeerState objectId object) -> + Map peerAddr (PeerState objectId object) +onRequestIdsImpl + peerAddr + numIdsToAck + numIdsToReq + peerStates = + Map.adjust + ( \ps@PeerState{psNumIdsInflight, psOutstandingFifo, psObjectsAvailableIds} -> + -- we isolate the longest prefix of outstandingFifo that matches our + -- ack criteria (see above in computeAck doc) + let + -- We compute the ids to ack and new state of the FIFO based on the + -- number of ids to ack given by the decision logic + (idsToAck, psOutstandingFifo') = + assert (StrictSeq.length psOutstandingFifo >= fromIntegral numIdsToAck) $ + StrictSeq.splitAt + (fromIntegral numIdsToAck) + psOutstandingFifo + + -- We remove the acknowledged ids from psObjectsAvailableIds if they + -- were present. + -- We need to do that because objects that were advertised by this + -- corresponding outbound peer but never downloaded because we + -- already have them in pool were consequently never removed + -- from psObjectsAvailableIds by onRequestObjects + psObjectsAvailableIds' = + Foldable.foldl' + (\set objectId -> Set.delete objectId set) + psObjectsAvailableIds + idsToAck + in + ps + { psNumIdsInflight = psNumIdsInflight + numIdsToReq + , psOutstandingFifo = psOutstandingFifo' + , psObjectsAvailableIds = psObjectsAvailableIds' + } + ) + peerAddr + peerStates + +onRequestObjects :: + forall m peerAddr object objectId. + (MonadSTM m, Ord objectId, Ord peerAddr) => + Tracer m (TraceObjectDiffusionInbound objectId object) -> + Tracer m (TraceDecisionLogic peerAddr objectId object) -> + PeerStatesVar m peerAddr objectId object -> + peerAddr -> + -- | objets to request, by id + Set objectId -> + m () +onRequestObjects odTracer decisionTracer peerStatesVar peerAddr objectIds = do + peerStates' <- atomically $ do + stateTVar + peerStatesVar + ( \peerStates -> + let peerStates' = onRequestObjectsImpl peerAddr objectIds peerStates + in (peerStates', peerStates') + ) + traceWith odTracer (TraceObjectDiffusionInboundRequestedObjects (Set.size objectIds)) + traceWith decisionTracer (TraceDecisionLogicPeerStatesUpdated "onRequestObjects" peerStates') + +onRequestObjectsImpl :: + forall peerAddr object objectId. + (Ord objectId, Ord peerAddr) => + peerAddr -> + -- | objets to request, by id + Set objectId -> + Map peerAddr (PeerState objectId object) -> + Map peerAddr (PeerState objectId object) +onRequestObjectsImpl + peerAddr + objectIds + peerStates = + Map.adjust + ( \ps@PeerState{psObjectsAvailableIds, psObjectsInflightIds} -> + assert + ( objectIds `Set.isSubsetOf` psObjectsAvailableIds + && Set.null (objectIds `Set.intersection` psObjectsInflightIds) + ) + $ ps + { psObjectsAvailableIds = psObjectsAvailableIds \\ objectIds + , psObjectsInflightIds = psObjectsInflightIds `Set.union` objectIds + } + ) + peerAddr + peerStates + +-- | Wrapper around `onReceiveIdsImpl`. +-- Obtain the `hasObject` function atomically from the STM context and +-- updates and traces the global state TVar. +onReceiveIds :: + forall m peerAddr object objectId. + (MonadSTM m, Ord objectId, Ord peerAddr) => + Tracer m (TraceObjectDiffusionInbound objectId object) -> + Tracer m (TraceDecisionLogic peerAddr objectId object) -> + ObjectPoolWriter objectId object m -> + PeerStatesVar m peerAddr objectId object -> + peerAddr -> + -- | number of requests to subtract from + -- `psNumIdsInflight` + NumObjectIdsReq -> + -- | sequence of received `objectIds` + [objectId] -> + -- | received `objectId`s + m () +onReceiveIds + odTracer + decisionTracer + ObjectPoolWriter{opwHasObject} + peerStatesVar + peerAddr + numIdsInitiallyRequested + receivedIds = do + peerStates' <- atomically $ do + peerState <- (Map.! peerAddr) <$> readTVar peerStatesVar + hasObject <- opwHasObject + checkProtocolErrors hasObject peerState numIdsInitiallyRequested receivedIds + stateTVar + peerStatesVar + ( \peerStates -> + let peerStates' = + onReceiveIdsImpl + peerAddr + numIdsInitiallyRequested + receivedIds + peerStates + in (peerStates', peerStates') + ) + traceWith odTracer (TraceObjectDiffusionInboundReceivedIds (length receivedIds)) + traceWith decisionTracer (TraceDecisionLogicPeerStatesUpdated "onReceiveIds" peerStates') + where + checkProtocolErrors :: + (objectId -> Bool) -> + PeerState objectId object -> + NumObjectIdsReq -> + [objectId] -> + STM m () + checkProtocolErrors + hasObject + PeerState{psObjectsAvailableIds, psObjectsInflightIds} + nReq + ids = do + when (length ids > fromIntegral nReq) $ throw ProtocolErrorObjectIdsNotRequested + let idSet = Set.fromList ids + when (length ids /= Set.size idSet) $ throw ProtocolErrorObjectIdsDuplicate + when + ( (not $ Set.null $ idSet `Set.intersection` psObjectsAvailableIds) + || (not $ Set.null $ idSet `Set.intersection` psObjectsInflightIds) + || (any hasObject ids) + ) + $ throw ProtocolErrorObjectIdAlreadyKnown + +onReceiveIdsImpl :: + forall peerAddr object objectId. + (Ord objectId, Ord peerAddr, HasCallStack) => + peerAddr -> + -- | number of requests to subtract from + -- `psNumIdsInflight` + NumObjectIdsReq -> + -- | sequence of received `objectId`s + [objectId] -> + Map peerAddr (PeerState objectId object) -> + Map peerAddr (PeerState objectId object) +onReceiveIdsImpl + peerAddr + numIdsInitiallyRequested + receivedIds + peerStates = peerStates' + where + peerState@PeerState + { psOutstandingFifo + , psObjectsAvailableIds + , psNumIdsInflight + } = + findWithDefault + (error "ObjectDiffusion.onReceiveIdsImpl: the peer should appear in peerStates") + peerAddr + peerStates + + -- Actually we don't need to filter out availableIds, because + -- makeDecisions is the only reader of psObjectsAvailableIds + -- and will filter it when needed with the actualized state of the object + -- pool. + psObjectsAvailableIds' = + psObjectsAvailableIds `Set.union` Set.fromList receivedIds + + -- Add received objectIds to `psOutstandingFifo`. + psOutstandingFifo' = psOutstandingFifo <> StrictSeq.fromList receivedIds + + peerState' = + assert + (psNumIdsInflight >= numIdsInitiallyRequested) + peerState + { psObjectsAvailableIds = psObjectsAvailableIds' + , psOutstandingFifo = psOutstandingFifo' + , psNumIdsInflight = psNumIdsInflight - numIdsInitiallyRequested + } + + peerStates' = Map.insert peerAddr peerState' peerStates + +-- | Wrapper around `onReceiveObjectsImpl` that updates and traces the +-- global state TVar. +onReceiveObjects :: + forall m peerAddr object objectId. + ( MonadSTM m + , MonadMask m + , Ord objectId + , Ord peerAddr + ) => + Tracer m (TraceObjectDiffusionInbound objectId object) -> + Tracer m (TraceDecisionLogic peerAddr objectId object) -> + PeerStatesVar m peerAddr objectId object -> + ObjectPoolWriter objectId object m -> + ObjectPoolSem m -> + peerAddr -> + -- | requested objects + Set objectId -> + -- | received objects + [object] -> + m () +onReceiveObjects + odTracer + tracer + peerStatesVar + objectPoolWriter + poolSem + peerAddr + objectsRequestedIds + objectsReceived = do + let getId = opwObjectId objectPoolWriter + let objectsReceivedMap = + Map.fromList $ (\obj -> (getId obj, obj)) <$> objectsReceived + checkProtocolErrors objectsRequestedIds objectsReceivedMap + peerStates' <- atomically $ do + stateTVar + peerStatesVar + ( \peerStates -> + let peerStates' = + onReceiveObjectsImpl + peerAddr + objectsReceivedMap + peerStates + in (peerStates', peerStates') + ) + traceWith odTracer (TraceObjectDiffusionInboundReceivedObjects (length objectsReceived)) + traceWith tracer (TraceDecisionLogicPeerStatesUpdated "onReceiveObjects" peerStates') + submitObjectsToPool + odTracer + tracer + peerStatesVar + objectPoolWriter + poolSem + peerAddr + objectsReceivedMap + where + checkProtocolErrors :: + Set objectId -> + Map objectId object -> + m () + checkProtocolErrors requested received' = do + let received = Map.keysSet received' + when (not $ Set.null $ requested \\ received) $ throw ProtocolErrorObjectMissing + when (not $ Set.null $ received \\ requested) $ throw ProtocolErrorObjectNotRequested + +onReceiveObjectsImpl :: + forall peerAddr object objectId. + ( Ord peerAddr + , Ord objectId + ) => + peerAddr -> + -- | received objects + Map objectId object -> + Map peerAddr (PeerState objectId object) -> + Map peerAddr (PeerState objectId object) +onReceiveObjectsImpl + peerAddr + objectsReceived + peerStates = peerStates' + where + objectsReceivedIds = Map.keysSet objectsReceived + + peerState@PeerState + { psObjectsInflightIds + , psObjectsOwtPool + } = + findWithDefault + (error "ObjectDiffusion.onReceiveObjectsImpl: the peer should appear in peerStates") + peerAddr + peerStates + + -- subtract requested from in-flight + psObjectsInflightIds' = + assert (objectsReceivedIds `Set.isSubsetOf` psObjectsInflightIds) $ + psObjectsInflightIds \\ objectsReceivedIds + + psObjectsOwtPool' = psObjectsOwtPool <> objectsReceived + + peerState' = + peerState + { psObjectsInflightIds = psObjectsInflightIds' + , psObjectsOwtPool = psObjectsOwtPool' + } + + peerStates' = Map.insert peerAddr peerState' peerStates + +submitObjectsToPool :: + forall m peerAddr object objectId. + ( Ord objectId + , Ord peerAddr + , MonadMask m + , MonadSTM m + ) => + Tracer m (TraceObjectDiffusionInbound objectId object) -> + Tracer m (TraceDecisionLogic peerAddr objectId object) -> + PeerStatesVar m peerAddr objectId object -> + ObjectPoolWriter objectId object m -> + ObjectPoolSem m -> + peerAddr -> + Map objectId object -> + m () +submitObjectsToPool + odTracer + decisionTracer + peerStatesVar + objectPoolWriter + (ObjectPoolSem poolSem) + peerAddr + objects = do + let getId = opwObjectId objectPoolWriter + + bracket_ + (atomically $ waitTSem poolSem) + (atomically $ signalTSem poolSem) + $ do + -- When the lock over the object pool is obtained + opwAddObjects objectPoolWriter (Map.elems objects) + traceWith odTracer $ + TraceObjectDiffusionInboundAddedObjects $ + length objects + + -- Move objects from `owtPool` to `inPool` state + peerStates' <- atomically $ stateTVar peerStatesVar $ \peerStates -> + let peerStates' = + Foldable.foldl' + (\st object -> removeObjectsFromStateWhenAddedToPool (getId object) st) + peerStates + objects + in (peerStates', peerStates') + traceWith + decisionTracer + ( TraceDecisionLogicPeerStatesUpdated + "submitObjectsToPool.removeObjectsFromStateWhenAddedToPool" + peerStates' + ) + where + removeObjectsFromStateWhenAddedToPool :: + objectId -> + Map peerAddr (PeerState objectId object) -> + Map peerAddr (PeerState objectId object) + removeObjectsFromStateWhenAddedToPool + objectId + peerStates = + Map.adjust + ( \ps@PeerState{psObjectsOwtPool} -> + ps{psObjectsOwtPool = Map.delete objectId psObjectsOwtPool} + ) + peerAddr + peerStates diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Inbound/V2/Types.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Inbound/V2/Types.hs new file mode 100644 index 0000000000..0f0e023f5a --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Inbound/V2/Types.hs @@ -0,0 +1,298 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.V2.Types + ( -- * State + PeerState (..) + , pssObjectsAvailableMultiplicities + , pssObjectsInflightMultiplicities + , pssObjectsOwtPoolMultiplicities + , PeerStatesVar + , newPeerStatesVar + + -- * Decisions + , DecisionContext (..) + , DecisionPolicy (..) + , PeerDecision (..) + , PeerDecisionStatus (..) + , ReqObjectsDecision (..) + , ReqIdsDecision (..) + + -- * Tracing + , mempty + , TraceDecisionLogic (..) + , ObjectMultiplicity (..) + + -- * Reporting + , ObjectDiffusionCounters (..) + , makeObjectDiffusionCounters + + -- * Error and Tracing + , TraceObjectDiffusionInbound (..) + , ObjectDiffusionInboundError (..) + + -- * Object pool semaphore + , ObjectPoolSem (..) + , newObjectPoolSem + ) where + +import Control.Concurrent.Class.MonadSTM.Strict + ( MonadSTM + , StrictTVar + , atomically + , newTVarIO + ) +import Control.Concurrent.Class.MonadSTM.TSem (TSem, newTSem) +import Control.DeepSeq (NFData (..)) +import Control.Exception (Exception (..)) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Monoid (Sum (..)) +import Data.Sequence.Strict (StrictSeq) +import Data.Set (Set) +import Data.Time (DiffTime) +import Data.Word (Word64) +import GHC.Generics (Generic) +import NoThunks.Class (NoThunks (..)) +import Ouroboros.Network.ControlMessage (ControlMessage) +import Ouroboros.Network.Protocol.ObjectDiffusion.Type +import Quiet (Quiet (..)) +import System.Random (StdGen) + +-- | Semaphore to guard access to the ObjectPool +newtype ObjectPoolSem m = ObjectPoolSem (TSem m) + +newObjectPoolSem :: MonadSTM m => m (ObjectPoolSem m) +newObjectPoolSem = ObjectPoolSem <$> atomically (newTSem 1) + +-- | In all the fields' names, +-- If "Ids" appears at the beginning of a name field, it means we refer to IDs +-- specifically (i.e. before the corresponding object is in flight). +-- On the other hand, a field name of the form "Objects...Ids" means we are +-- speaking of objects (i.e. after they have been requested) but identify them +-- by their IDs for this field purpose. +data PeerState objectId object = PeerState + { psNumIdsInflight :: !NumObjectIdsReq + -- ^ The number of object identifiers that we have requested but + -- which have not yet been replied to. We need to track this it keep + -- our requests within the limit on the number of unacknowledged objectIds. + , psOutstandingFifo :: !(StrictSeq objectId) + -- ^ Sequence of objects (by their id) that the client has told + -- us about, and which we have not yet acknowledged. This is kept in + -- the order in which the client gave them to us. It is also the order + -- in which we acknowledge them. + , psObjectsAvailableIds :: !(Set objectId) + -- ^ Set of objects (by their ids) that can be requested from the outbound peer. + , psObjectsInflightIds :: !(Set objectId) + -- ^ The set of requested objects (by their ids) that haven't been received yet. + , psObjectsOwtPool :: !(Map objectId object) + -- ^ Received objects that are on their way to the objectpool. + } + deriving stock (Show, Eq, Generic) + deriving anyclass (NFData, NoThunks) + +countMultiplicities :: + Ord objectId => + (PeerState objectId object -> Set objectId) -> + Map peerAddr (PeerState objectId object) -> + Map objectId ObjectMultiplicity +countMultiplicities selector peerStates = + Map.unionsWith + (+) + (Map.fromSet (const 1) . selector <$> Map.elems peerStates) + +pssObjectsAvailableMultiplicities :: + Ord objectId => + Map peerAddr (PeerState objectId object) -> + Map objectId ObjectMultiplicity +pssObjectsAvailableMultiplicities = countMultiplicities psObjectsAvailableIds + +pssObjectsInflightMultiplicities :: + Ord objectId => + Map peerAddr (PeerState objectId object) -> + Map objectId ObjectMultiplicity +pssObjectsInflightMultiplicities = countMultiplicities psObjectsInflightIds + +pssObjectsOwtPoolMultiplicities :: + Ord objectId => + Map peerAddr (PeerState objectId object) -> + Map objectId ObjectMultiplicity +pssObjectsOwtPoolMultiplicities = countMultiplicities (Map.keysSet . psObjectsOwtPool) + +type PeerStatesVar m peerAddr objectId object = + StrictTVar m (Map peerAddr (PeerState objectId object)) + +newPeerStatesVar :: + MonadSTM m => + m (PeerStatesVar m peerAddr objectId object) +newPeerStatesVar = + newTVarIO Map.empty + +-- +-- Decisions +-- + +data DecisionContext peerAddr objectId object = DecisionContext + { dcRng :: StdGen + , dcHasObject :: (objectId -> Bool) + , dcDecisionPolicy :: DecisionPolicy + , dcPeerStates :: Map peerAddr (PeerState objectId object) + , dcPrevDecisions :: Map peerAddr (PeerDecisionStatus objectId object) + } + deriving stock Generic + deriving anyclass NFData + +-- | Policy for making decisions +data DecisionPolicy = DecisionPolicy + { dpMaxNumObjectIdsReq :: !NumObjectIdsReq + -- ^ a maximal number of objectIds requested at once. + , dpMaxNumObjectsOutstanding :: !NumObjectsOutstanding + -- ^ maximal number of objects in the outstanding FIFO. + -- Must be the same as the outbound peer's value. + , dpMaxNumObjectsInflightPerPeer :: !NumObjectsReq + -- ^ a limit of objects in-flight from a single peer. + , dpMaxNumObjectsInflightTotal :: !NumObjectsReq + -- ^ a limit of objects in-flight from all peers for this node. + , dpTargetObjectRedundancy :: !ObjectMultiplicity + -- ^ from how many peers download the `objectId` simultaneously + , dpDecisionThreadSleepDelay :: !DiffTime + -- ^ delay (in seconds) between two decision making rounds + } + deriving stock (Show, Eq, Generic) + deriving anyclass (NFData, NoThunks) + +-- | Decision made by the decision logic. Each peer will receive a 'Decision'. +-- +-- /note:/ it is rather non-standard to represent a choice between requesting +-- `objectId`s and `object`'s as a product rather than a sum type. The client will +-- need to download `object`s first and then send a request for more objectIds (and +-- acknowledge some `objectId`s). Due to pipelining each client will request +-- decision from the decision logic quite often (every two pipelined requests). +-- +-- TODO: in the previous design, we prefiltered pending peers before calling +-- `makeDecision`, so that a decision once taken would make the peer non-pending +-- (e.g. it won't be returned by `filterPendingPeers`) for longer, and thus the +-- expensive `makeDecision` computation would not need to take that peer into +-- account. This is no longer the case, but we could reintroduce this optimization +-- if needed. +data ReqIdsDecision objectId object = ReqIdsDecision + { ridNumIdsToAck :: !NumObjectIdsAck + -- ^ objectId's to acknowledge + , ridNumIdsToReq :: !NumObjectIdsReq + -- ^ number of objectId's to request + , ridCanPipelineIdsRequests :: !Bool + -- ^ the object-submission protocol only allows to pipeline `objectId`'s requests + -- if we have non-acknowledged `objectId`s. + } + deriving stock (Show, Eq, Generic) + deriving anyclass (NFData, NoThunks) + +newtype ReqObjectsDecision objectId object = ReqObjectsDecision + { rodObjectsToReqIds :: Set objectId + -- ^ objectId's to request + } + deriving stock (Show, Eq, Generic) + deriving anyclass (NFData, NoThunks) + +data PeerDecision objectId object + = PeerDecision + { pdReqObjects :: ReqObjectsDecision objectId object + , pdReqIds :: ReqIdsDecision objectId object + } + deriving stock (Show, Eq, Generic) + deriving anyclass (NFData, NoThunks) + +data PeerDecisionStatus objectId object + = PeerDecisionUnread !(PeerDecision objectId object) + | PeerDecisionBeingActedUpon !(PeerDecision objectId object) + | PeerDecisionCompleted + deriving stock (Show, Eq, Generic) + deriving anyclass (NFData, NoThunks) + +-- | ObjectLogic tracer. +data TraceDecisionLogic peerAddr objectId object + = TraceDecisionLogicPeerStatesUpdated String (Map peerAddr (PeerState objectId object)) + | TraceDecisionLogicDecisionsMade (Map peerAddr (PeerDecision objectId object)) + deriving stock (Show, Eq, Generic) + +data ObjectDiffusionCounters + = ObjectDiffusionCounters + { odcNumDistinctObjectsAvailable :: Int + -- ^ objectIds which are not yet downloaded. + , odcNumDistinctObjectsInflight :: Int + -- ^ number of distinct in-flight objects. + , odcNumTotalObjectsInflight :: Int + -- ^ number of all in-flight objects. + , odcNumDistinctObjectsOwtPool :: Int + -- ^ number of distinct objects which are waiting to be added to the + -- objectpool (each peer need to acquire the semaphore to effectively add + -- them to the pool) + } + deriving stock (Show, Eq, Generic) + +makeObjectDiffusionCounters :: + Ord objectId => + Map peerAddr (PeerState objectId object) -> + ObjectDiffusionCounters +makeObjectDiffusionCounters + peerStates = + ObjectDiffusionCounters + { odcNumDistinctObjectsAvailable = + Map.size $ pssObjectsAvailableMultiplicities peerStates + , odcNumDistinctObjectsInflight = + Map.size $ pssObjectsInflightMultiplicities peerStates + , odcNumTotalObjectsInflight = + fromIntegral . mconcat . Map.elems $ pssObjectsInflightMultiplicities peerStates + , odcNumDistinctObjectsOwtPool = + Map.size $ pssObjectsOwtPoolMultiplicities peerStates + } + +newtype ObjectMultiplicity + = ObjectMultiplicity + { getObjectMultiplicity :: Word64 + } + deriving stock (Eq, Ord, Generic) + deriving newtype (NFData, NoThunks, Num, Enum, Real, Integral, Bounded) + deriving Semigroup via (Sum Word64) + deriving Monoid via (Sum Word64) + deriving Show via (Quiet ObjectMultiplicity) + +data TraceObjectDiffusionInbound objectId object + = TraceObjectDiffusionInboundRequestedIds Int + | TraceObjectDiffusionInboundRequestedObjects Int + | TraceObjectDiffusionInboundReceivedIds Int + | TraceObjectDiffusionInboundReceivedObjects Int + | TraceObjectDiffusionInboundAddedObjects Int + | -- | Received a 'ControlMessage' from the outbound peer governor, and about + -- to act on it. + TraceObjectDiffusionInboundReceivedControlMessage ControlMessage + | TraceObjectDiffusionInboundTerminated + | TraceObjectDiffusionInboundReceivedDecision (PeerDecision objectId object) + deriving stock (Show, Eq, Generic) + +data ObjectDiffusionInboundError + = ProtocolErrorObjectNotRequested + | ProtocolErrorObjectIdsNotRequested + | ProtocolErrorObjectIdAlreadyKnown + | ProtocolErrorObjectIdsDuplicate + | ProtocolErrorObjectMissing + deriving stock (Show, Eq, Generic) + +instance Exception ObjectDiffusionInboundError where + displayException ProtocolErrorObjectNotRequested = + "The peer replied with an 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." + displayException ProtocolErrorObjectMissing = + "The peer did not deliver an object for which it claimed to have an id." From 7219242c0566b1385cca2e41540c381d735f508e Mon Sep 17 00:00:00 2001 From: Thomas BAGREL Date: Mon, 10 Nov 2025 16:18:01 +0100 Subject: [PATCH 43/43] Add bench for `makeDecision` (ObjectDiffusion V2) --- .../bench/ObjectDiffusion-bench/Main.hs | 84 ++++ ouroboros-consensus/ouroboros-consensus.cabal | 16 + .../ObjectDiffusion/Inbound/V2/TestUtils.hs | 359 ++++++++++++++++++ 3 files changed, 459 insertions(+) create mode 100644 ouroboros-consensus/bench/ObjectDiffusion-bench/Main.hs create mode 100644 ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Inbound/V2/TestUtils.hs diff --git a/ouroboros-consensus/bench/ObjectDiffusion-bench/Main.hs b/ouroboros-consensus/bench/ObjectDiffusion-bench/Main.hs new file mode 100644 index 0000000000..b0f69914fb --- /dev/null +++ b/ouroboros-consensus/bench/ObjectDiffusion-bench/Main.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE TypeApplications #-} + +-- | This module contains benchmarks for Peras Object diffusion decision logic +-- as implemented by the by the function +-- 'Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.V2.Decision.makeDecision' +module Main (main) where + +import Control.DeepSeq (NFData (..)) +import Control.Exception (evaluate) +import Data.Hashable (Hashable) +import GHC.Generics (Generic) +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.V2.Decision qualified as OD +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.V2.TestUtils qualified as OD +import Test.QuickCheck (Arbitrary (..), generate) +import Test.QuickCheck.Gen (vectorOf) +import Test.Tasty.Bench + +-- TODO: We will probably want to use the actual types used in vote/cert diffusion, +-- instead of placeholders. +newtype DummyPeerAddr = DummyPeerAddr Int + deriving (Eq, Ord, Generic, NFData) + +instance Arbitrary DummyPeerAddr where + arbitrary = DummyPeerAddr <$> arbitrary + +newtype DummyObjectId = DummyObjectId Int + deriving (Eq, Ord, Generic, Hashable, NFData) + +instance Arbitrary DummyObjectId where + arbitrary = DummyObjectId <$> arbitrary + +data DummyObject = DummyObject + { doId :: DummyObjectId + , doPayload :: () + } + deriving (Eq, Ord, Generic, Hashable, NFData) + +instance Arbitrary DummyObject where + arbitrary = DummyObject <$> arbitrary <*> arbitrary + +-- TODO: We should probably use specific policies that are well suited to the +-- number of peers and objects. + +main :: IO () +main = + defaultMain + [ bgroup + "ouroboros-consensus:ObjectDiffusion" + [ bgroup + "VoteDiffusion" + [ env + (genToNF $ vectorOf 1_000 $ OD.genDecisionContext 10 50 doId Nothing) + ( \contexts -> + bench "makeDecisions: 1000 decisions with (10 pairs, 50 objects) each" $ + nf (fmap makeVoteDiffusionDecisions) contexts + ) + , env + (genToNF $ vectorOf 1_000 $ OD.genDecisionContext 100 500 doId Nothing) + ( \contexts -> + bench "makeDecisions: 1000 decisions with (100 pairs, 500 objects) each" $ + nf (fmap makeVoteDiffusionDecisions) contexts + ) + , env + (genToNF $ vectorOf 1_000 $ OD.genDecisionContext 1_000 5_000 doId Nothing) + ( \contexts -> + bench "makeDecisions: 1000 decisions with (1000 pairs, 5000 objects) each" $ + nf (fmap makeVoteDiffusionDecisions) contexts + ) + ] + , bgroup "CertDiffusion" [] + ] + ] + where + genToNF gen = do + x <- generate gen + evaluate $ rnf x + pure $! x + + makeVoteDiffusionDecisions decisionContext = + OD.makeDecisions @DummyPeerAddr @DummyObjectId @DummyObject decisionContext diff --git a/ouroboros-consensus/ouroboros-consensus.cabal b/ouroboros-consensus/ouroboros-consensus.cabal index 7de0ecce2d..c7e8542a2b 100644 --- a/ouroboros-consensus/ouroboros-consensus.cabal +++ b/ouroboros-consensus/ouroboros-consensus.cabal @@ -197,6 +197,7 @@ library Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.V2.Decision Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.V2.Registry Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.V2.State + Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.V2.TestUtils Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.V2.Types Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.PerasCert @@ -323,6 +324,7 @@ library build-depends: FailT ^>=0.1.2, + QuickCheck, aeson, base >=4.14 && <4.22, base-deriving-via, @@ -935,6 +937,20 @@ benchmark PerasCertDB-bench tasty-bench, unstable-consensus-testlib, +benchmark ObjectDiffusion-bench + import: common-bench + type: exitcode-stdio-1.0 + hs-source-dirs: bench/ObjectDiffusion-bench + main-is: Main.hs + other-modules: + build-depends: + QuickCheck, + base, + deepseq, + hashable, + ouroboros-consensus, + tasty-bench, + test-suite doctest import: common-test main-is: doctest.hs diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Inbound/V2/TestUtils.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Inbound/V2/TestUtils.hs new file mode 100644 index 0000000000..2f3204dd25 --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Inbound/V2/TestUtils.hs @@ -0,0 +1,359 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.V2.TestUtils + ( chooseGeometricWithMedian + , partitionWithProb + , genDecisionPolicy + , genDecisionContext + , genPeerStates + , genPeerState + , defaultDecisionPolicy + ) +where + +import Data.Either (partitionEithers) +import qualified Data.Foldable as Foldable +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe (fromMaybe) +import qualified Data.Sequence.Strict as StrictSeq +import qualified Data.Set as Set +import Data.Traversable (for) +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.V2.Types + ( DecisionContext (..) + , DecisionPolicy (..) + , PeerDecisionStatus (PeerDecisionCompleted) + , PeerState (..) + ) +import Ouroboros.Network.Protocol.ObjectDiffusion.Type (NumObjectsReq (..)) +import System.Random (mkStdGen) +import Test.QuickCheck (Arbitrary (arbitrary), Gen, choose, shuffle, vector) + +-- | Partition a list into two lists according to a given probability, in the +-- QuickCheck 'Gen' monad. +-- Each element has probability 'p' of going into the first list, +-- and probability '1 - p' of going into the second list. +partitionWithProb :: + -- | Probability 'p' of going into the first list + Double -> + -- | Input list + [a] -> + Gen ([a], [a]) +partitionWithProb p xs = do + partitionEithers + <$> traverse + ( \x -> do + r <- choose (0.0, 1.0) + if r < p then return (Left x) else return (Right x) + ) + xs + +-- TODO: this needs to be tested and inspected + +-- | Geometric-decay generator over [1 .. maxBound - 1] for the type 'a'. +-- Smaller values are more likely; the (lower) median is ~ medianTarget. +-- Works for any Integral + Bounded numeric type (e.g. Int, Word32, Int64 +-- and newtypes around those). +chooseGeometricWithMedian :: forall a. (Integral a, Bounded a) => a -> Gen a +chooseGeometricWithMedian medianTarget + | (maxBound @a) <= 1 = + error "Type's maxBound <= 1: no room for [1..maxBound-1]" + | medianTarget < 1 || medianTarget >= maxBound = + error "medianTarget must be in [1 .. maxBound-1]" + | otherwise = do + let lo = 1 + hi = maxBound - 1 + -- use Integer for counts, Double for CDF inversion + nI = toInteger (hi - lo + 1) + mI = toInteger (medianTarget - lo + 1) + n = fromIntegral nI :: Double + m = fromIntegral mI :: Double + p = 1 - 2 ** (-1 / m) -- set so P(X ≤ median) ≈ 0.5 + q = 1 - p -- decay factor + qn = q ** n -- truncation term + u <- choose (0, 1 :: Double) + let y = 1 - u * (1 - qn) + k = floor (log y / log q) -- inverse truncated geometric CDF + k' = max 0 (min (floor (n - 1)) k) + pure (lo + fromInteger k') + +-- | Default decision policy suitable for tests. It is in-between the expected +-- values for cert diffusion and these for vote diffusion. +defaultDecisionPolicy :: DecisionPolicy +defaultDecisionPolicy = + DecisionPolicy + { dpMaxNumObjectIdsReq = 10 + , dpMaxNumObjectsOutstanding = 100 + , dpMaxNumObjectsInflightPerPeer = 50 + , dpMaxNumObjectsInflightTotal = 500 + , dpTargetObjectRedundancy = 3 + , dpDecisionThreadSleepDelay = 0.005 + } + +-- | Generate a random 'DecisionPolicy' based on a geometric variation using the +-- values of 'defaultDecisionPolicy' as median targets. +genDecisionPolicy :: Gen DecisionPolicy +genDecisionPolicy = + let DecisionPolicy + { dpMaxNumObjectIdsReq + , dpMaxNumObjectsOutstanding + , dpMaxNumObjectsInflightPerPeer + , dpMaxNumObjectsInflightTotal + , dpTargetObjectRedundancy + } = defaultDecisionPolicy + in DecisionPolicy + <$> (chooseGeometricWithMedian dpMaxNumObjectIdsReq) + <*> (chooseGeometricWithMedian dpMaxNumObjectsOutstanding) + <*> (chooseGeometricWithMedian dpMaxNumObjectsInflightPerPeer) + <*> (chooseGeometricWithMedian dpMaxNumObjectsInflightTotal) + <*> (chooseGeometricWithMedian dpTargetObjectRedundancy) + <*> pure 0.005 + +-- TODO: in all functions below, we may want to use random ratios centered on a +-- given median instead of fixed ratios, to have more variability in the +-- generated states. + +-- | Generate a random 'DecisionContext' suitable for tests. +-- +-- The number of desired peers and existing objects must be specified. +-- It will take the whole pool of existing objects as a starting point, and +-- randomly attribute a subset of them to each peer. +-- Then for each peer the `genPeerState` function will randomly +-- decide which objects are available, inflight, in the OWT pool, etc. +-- +-- NOTE: given that the generated decision context is meant for benchs +-- primarily, all peers receive an 'PeerDecisionCompleted' as their previous +-- so that they are all selected for the next round of decisions. +-- +-- We also try to uphold as much realism as possible, e.g. we try to enforce +-- the invariants that must be held in the peer states and global state, +-- as well as respecting the decision policy limits. +-- The only policy limit we may not respect is `dpTargetObjectRedundancy`, as +-- we may have more copies inflight of a given object than the target redundancy +-- specified in the policy, but it isn't an invariant like the others, it's +-- just a target to aim for. +genDecisionContext :: + forall peerAddr objectId object. + ( Arbitrary peerAddr + , Arbitrary object + , Ord peerAddr + , Ord objectId + , Ord object + ) => + -- | Number of concurrent connections to outbound peers + Int -> + -- | Number of total distinct objects that exist at this given time + Int -> + -- | How to get the id out of an object + (object -> objectId) -> + -- | If we want to provide a specific decision policy instead of relying on + -- an arbitrary variation of the default one + Maybe DecisionPolicy -> + Gen (DecisionContext peerAddr objectId object) +genDecisionContext peersNb objectsNb getId mPolicy = do + -- Ratio of objects (compared to all existing objects) that will be + -- considered already in the ObjectPool + let alreadyInPoolRatio :: Double = 0.2 + + dcRng <- mkStdGen <$> arbitrary + + -- Either use the provided policy, or generate a new one using + -- `genDecisionPolicy` + dcDecisionPolicy <- fromMaybe genDecisionPolicy (pure <$> mPolicy) + + -- Generate the pool of all existing objects + objects <- vector objectsNb + + -- Mark a subset of them as already in the ObjectPool + -- We try to make the `dcHasObject` function as efficient as possible + (alreadyInPool, _) <- partitionWithProb alreadyInPoolRatio objects + let !alreadyInPoolIds = Set.fromList $ getId <$> alreadyInPool + dcHasObject = (`Set.member` alreadyInPoolIds) + + -- Delegate generation of the state to `genPeerStates` (and beneath + -- that `genPeerState`) + dcPeerStates <- genPeerStates getId dcDecisionPolicy peersNb objects + + -- Use `PeerDecisionCompleted` as the previous decision for all peers so that + -- they are all selected in the next round of decisions. + let dcPrevDecisions = + Map.map (\_ -> PeerDecisionCompleted) (dcPeerStates) + + pure $ + DecisionContext + { dcRng + , dcHasObject + , dcDecisionPolicy + , dcPeerStates + , dcPrevDecisions + } + +-- | Generate a random 'PeerStates' suitable for benchs, +-- based on a given decision policy and a pool of existing objects. +genPeerStates :: + (Arbitrary peerAddr, Ord peerAddr, Ord objectId, Ord object) => + (object -> objectId) -> + -- | Decision policy to respect when generating the global state. + DecisionPolicy -> + -- | Number of concurrent connections to outbound peers + Int -> + -- | Pool of all existing objects to choose from + [object] -> + Gen (Map peerAddr (PeerState objectId object)) +genPeerStates + getId + policy@DecisionPolicy{dpMaxNumObjectsInflightTotal} + peersNb + objects = + do + let objectRepresentationRatio :: Double = 0.6 + + peerPairs <- for [1 .. peersNb] \_ -> do + (peerObjects, _) <- + partitionWithProb + objectRepresentationRatio + objects + + peerAddr <- arbitrary + peerState <- genPeerState getId policy peerObjects + pure (peerAddr, peerState) + + -- Now we need to make sure that we are not over the limit of + -- `dpMaxNumObjectsInflightTotal` across all peers. + -- It's a bit ugly, because we can't really control that in the individual + -- generation of each peer state, as it depends on the values of + -- `dpMaxNumObjectsInflightPerPeer`, `dpMaxNumObjectsInflightTotal`, + -- `peersNb`, and the size of the pool of existing objects we use + -- in the generation of the state as well as various ratios which are + -- implementation details. + let numObjectsInflightTotal = + Foldable.foldl' + ( \count (_, PeerState{psObjectsInflightIds}) -> + count + (fromIntegral $ Set.size psObjectsInflightIds) + ) + (NumObjectsReq 0) + peerPairs + trimRatio :: Double + trimRatio = + ( fromIntegral numObjectsInflightTotal + / fromIntegral dpMaxNumObjectsInflightTotal + ) + - 1 + peerPairs' <- + if trimRatio > 0 + then traverse (trimObjectsInflightIds trimRatio) peerPairs + else pure peerPairs + + pure $ Map.fromList peerPairs' + +-- | Remove a given ratio of inflight ids from a peer state in a most equitable +-- fashion. It also removes them from the FIFO. +trimObjectsInflightIds :: + Ord objectId => + -- | Ratio of inflight ids to remove (between 0 and 1) + Double -> + -- | Peer address and its peer state + (peerAddr, PeerState objectId object) -> + Gen (peerAddr, PeerState objectId object) +trimObjectsInflightIds + trimRatio + ( peerAddr + , peerState@PeerState{psObjectsInflightIds, psOutstandingFifo} + ) = + do + -- We take the ceiling of the number to remove to make sure we go under the limit + let nbToRemove = ceiling $ fromIntegral (Set.size psObjectsInflightIds) * trimRatio + -- Then pick randomly this number of ids to remove + idsToRemove <- take nbToRemove <$> shuffle (Set.toList psObjectsInflightIds) + -- Then we remove them from both the inflight set and the outstanding FIFO + let psObjectsInflightIds' = + Foldable.foldl' + (flip Set.delete) + psObjectsInflightIds + idsToRemove + + -- Should we actually do that? + psOutstandingFifo' = + StrictSeq.filter + (\objId -> not (objId `elem` idsToRemove)) + psOutstandingFifo + pure + ( peerAddr + , peerState + { psObjectsInflightIds = psObjectsInflightIds' + , psOutstandingFifo = psOutstandingFifo' + } + ) + +-- | Generate a random 'PeerState' suitable for benchs, +-- based on a given decision policy and a pool of existing objects that this +-- peer can use in its state. +genPeerState :: + (Ord objectId, Ord object) => + (object -> objectId) -> + -- | Decision policy to respect when generating the peer state. + DecisionPolicy -> + -- | Pool of existing objects this peer should use for its state + [object] -> + Gen (PeerState objectId object) +genPeerState + getId + DecisionPolicy{dpMaxNumObjectsOutstanding, dpMaxNumObjectsInflightPerPeer} + peerObjects = + do + let inflightRatio :: Double = 0.1 + let owtPoolRatio :: Double = 0.1 + -- let availableRatio :: Double = 1 - (inflightRatio + owtPoolRatio) + let owtPoolStillInFifoRatio :: Double = 0.3 + + -- First we divide the existing objects into three groups that must be disjoint: + -- objects available, inflight, and owt pool, according to the specified ratios. + (objectsAvailable, rest) <- + partitionWithProb (1 - (inflightRatio + owtPoolRatio)) peerObjects + (objectsInflight, objectsOwtPool) <- + partitionWithProb (owtPoolRatio / (owtPoolRatio + inflightRatio)) rest + -- For objects inflight we limit their number according to the decision policy + -- (we dont' need to do that for the other two categories) + let objectsInflight' = + take (fromIntegral dpMaxNumObjectsInflightPerPeer) objectsInflight + + -- Now we decide of a subset of objects owt pool that haven't been acked yet, + -- so must still be in the FIFO. + (owtPoolStillInFifo, _) <- + partitionWithProb owtPoolStillInFifoRatio objectsOwtPool + + -- We can now reconstruct the FIFO, by taking all available and inflight objects + -- (as they must be in the FIFO according to the state invariants), and + -- and topping up with the subset of objects owt pool that we defined above. + -- We also shuffle the FIFO and limit its size according to the decision policy. + objectsInFifo <- + take (fromIntegral dpMaxNumObjectsOutstanding) + <$> (shuffle $ objectsAvailable ++ objectsInflight ++ owtPoolStillInFifo) + + -- Retropendingly, to uphold the invariants, we must remove elements from + -- the available and inflight lists that are not in the FIFO. + let objectsAvailable' = + filter (\obj -> obj `elem` objectsInFifo) objectsAvailable + objectsInflight'' = + filter (\obj -> obj `elem` objectsInFifo) objectsInflight' + + -- Finally, we decide how many ids are inflight + -- We can't have more than the difference between the policy limit for the FIFO + -- and the current size of the FIFO. + let maxNumIdsInFlight = + fromIntegral dpMaxNumObjectsOutstanding - length objectsInFifo + numIdsInFlight <- choose (0, maxNumIdsInFlight) + + pure $ + PeerState + { psObjectsAvailableIds = Set.fromList $ getId <$> objectsAvailable' + , psObjectsInflightIds = Set.fromList $ getId <$> objectsInflight'' + , psObjectsOwtPool = Map.fromList $ (\obj -> (getId obj, obj)) <$> objectsOwtPool + , psOutstandingFifo = StrictSeq.fromList $ getId <$> objectsInFifo + , psNumIdsInflight = fromIntegral $ numIdsInFlight + }