diff --git a/cabal.project b/cabal.project index 9c97a6c5ba..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 @@ -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,14 @@ source-repository-package eras/byron/ledger/impl eras/byron/crypto --- Backported version of https://github.com/IntersectMBO/ouroboros-network/pull/5161 +-- 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: 1385b53cefb81e79553b6b0252537455833ea9c4 - --sha256: sha256-zZ7WsMfRs1fG16bmvI5vIh4fhQ8RGyEvYGLSWlrxpg0= + tag: peras-staging/pr-5202-v2 + --sha256: sha256-vEO721Xab0RTVKFQFKal5VCV5y+OUzELo8+7Z8TETJQ= subdir: + ouroboros-network + ouroboros-network-protocols ouroboros-network-api ouroboros-network 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-cardano/golden/cardano/disk/ChainDepState_Babbage b/ouroboros-consensus-cardano/golden/cardano/disk/ChainDepState_Babbage index 3bc6eaac88..2e06ac93cf 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/disk/ChainDepState_Babbage and b/ouroboros-consensus-cardano/golden/cardano/disk/ChainDepState_Babbage differ diff --git a/ouroboros-consensus-cardano/golden/cardano/disk/ChainDepState_Conway b/ouroboros-consensus-cardano/golden/cardano/disk/ChainDepState_Conway index 5043da9e14..760307285a 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/disk/ChainDepState_Conway and b/ouroboros-consensus-cardano/golden/cardano/disk/ChainDepState_Conway differ diff --git a/ouroboros-consensus-cardano/golden/cardano/disk/ChainDepState_Dijkstra b/ouroboros-consensus-cardano/golden/cardano/disk/ChainDepState_Dijkstra index 8745a735ad..64bfb1dc43 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/disk/ChainDepState_Dijkstra and b/ouroboros-consensus-cardano/golden/cardano/disk/ChainDepState_Dijkstra differ diff --git a/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Babbage b/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Babbage index 622ee470ff..e1cb075b82 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Babbage and b/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Babbage differ diff --git a/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Conway b/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Conway index 1d2b0c3c12..74fe8bc575 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Conway and b/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Conway differ diff --git a/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Dijkstra b/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Dijkstra index 563a4897c6..a57ec35d1a 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Dijkstra and b/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Dijkstra differ diff --git a/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/Ledger.hs b/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/Ledger.hs index f57756fe0f..c1b7ebbf39 100644 --- a/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/Ledger.hs +++ b/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/Ledger.hs @@ -333,6 +333,7 @@ byronEraParams genesis = , eraSlotLength = fromByronSlotLength $ genesisSlotLength genesis , eraSafeZone = HardFork.StandardSafeZone (2 * k) , eraGenesisWin = GenesisWindow (2 * k) + , eraPerasRoundLength = HardFork.NoPerasEnabled } where k = unNonZero $ maxRollbacks $ genesisSecurityParam genesis @@ -345,6 +346,7 @@ byronEraParamsNeverHardForks genesis = , eraSlotLength = fromByronSlotLength $ genesisSlotLength genesis , eraSafeZone = HardFork.UnsafeIndefiniteSafeZone , eraGenesisWin = GenesisWindow (2 * Gen.unBlockCount (Gen.configK genesis)) + , eraPerasRoundLength = HardFork.NoPerasEnabled } instance HasHardForkHistory ByronBlock where diff --git a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Node.hs b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Node.hs index 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/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/shelley/Ouroboros/Consensus/Shelley/Ledger/NetworkProtocolVersion.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/NetworkProtocolVersion.hs index c03e0e5179..7003a5ce8a 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/NetworkProtocolVersion.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/NetworkProtocolVersion.hs @@ -48,6 +48,7 @@ instance SupportedNetworkProtocolVersion (ShelleyBlock proto era) where Map.fromList [ (NodeToNodeV_14, ShelleyNodeToNodeVersion1) , (NodeToNodeV_15, ShelleyNodeToNodeVersion1) + , (NodeToNodeV_16, ShelleyNodeToNodeVersion1) ] supportedNodeToClientVersions _ = Map.fromList diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/Consensus/Cardano/Generators.hs b/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/Consensus/Cardano/Generators.hs index 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/ouroboros-consensus-diffusion.cabal b/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal index f1c5b42fcd..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 @@ -77,6 +78,7 @@ library build-depends: base >=4.14 && <4.22, bytestring >=0.10 && <0.13, + cardano-base, cardano-slotting, cborg ^>=0.2.2, containers >=0.5 && <0.8, @@ -97,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/Network/NodeToNode.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs index bc66cf78d6..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 @@ -39,6 +39,7 @@ module Ouroboros.Consensus.Network.NodeToNode , initiatorAndResponder ) where +import Cardano.Base.FeatureFlags (CardanoFeatureFlag) import Codec.CBOR.Decoding (Decoder) import qualified Codec.CBOR.Decoding as CBOR import Codec.CBOR.Encoding (Encoding) @@ -54,6 +55,7 @@ import qualified Data.ByteString.Lazy as BSL import Data.Hashable (Hashable) import Data.Int (Int64) import Data.Map.Strict (Map) +import Data.Set (Set) import Data.Void (Void) import qualified Network.Mux as Mux import Network.TypedProtocol.Codec @@ -68,6 +70,14 @@ import Ouroboros.Consensus.MiniProtocol.ChainSync.Client ) import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client as CsClient import Ouroboros.Consensus.MiniProtocol.ChainSync.Server +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.V1 (objectDiffusionInbound) +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.V1.State + ( ObjectDiffusionInboundStateView + , bracketObjectDiffusionInbound + ) +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.PerasCert +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Outbound (objectDiffusionOutbound) +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.PerasCert import Ouroboros.Consensus.Node.ExitPolicy import Ouroboros.Consensus.Node.NetworkProtocolVersion import Ouroboros.Consensus.Node.Run @@ -81,10 +91,6 @@ import Ouroboros.Consensus.Util.IOLike import Ouroboros.Consensus.Util.Orphans () import Ouroboros.Network.Block ( Serialised (..) - , decodePoint - , decodeTip - , encodePoint - , encodeTip ) import Ouroboros.Network.BlockFetch import Ouroboros.Network.BlockFetch.Client @@ -124,6 +130,18 @@ import Ouroboros.Network.Protocol.KeepAlive.Client import Ouroboros.Network.Protocol.KeepAlive.Codec import Ouroboros.Network.Protocol.KeepAlive.Server import Ouroboros.Network.Protocol.KeepAlive.Type +import Ouroboros.Network.Protocol.ObjectDiffusion.Codec + ( byteLimitsObjectDiffusion + , codecObjectDiffusion + , codecObjectDiffusionId + , timeLimitsObjectDiffusion + ) +import Ouroboros.Network.Protocol.ObjectDiffusion.Inbound + ( objectDiffusionInboundPeerPipelined + ) +import Ouroboros.Network.Protocol.ObjectDiffusion.Outbound + ( objectDiffusionOutboundPeer + ) import Ouroboros.Network.Protocol.PeerSharing.Client ( PeerSharingClient , peerSharingClientPeer @@ -197,6 +215,16 @@ data Handlers m addr blk = Handlers NodeToNodeVersion -> ConnectionId addr -> TxSubmissionServerPipelined (GenTxId blk) (GenTx blk) m () + , hPerasCertDiffusionClient :: + NodeToNodeVersion -> + ControlMessageSTM m -> + ObjectDiffusionInboundStateView m -> + ConnectionId addr -> + PerasCertDiffusionInboundPipelined blk m () + , hPerasCertDiffusionServer :: + NodeToNodeVersion -> + ConnectionId addr -> + PerasCertDiffusionOutbound blk m () , hKeepAliveClient :: NodeToNodeVersion -> ControlMessageSTM m -> @@ -241,6 +269,7 @@ mkHandlers , keepAliveRng , miniProtocolParameters , getDiffusionPipeliningSupport + , systemTime } NodeKernel { getChainDB @@ -293,6 +322,23 @@ mkHandlers (mapTxSubmissionMempoolReader txForgetValidated $ getMempoolReader getMempool) (getMempoolWriter getMempool) version + , hPerasCertDiffusionClient = \version controlMessageSTM state peer -> + objectDiffusionInbound + (contramap (TraceLabelPeer peer) (Node.perasCertDiffusionInboundTracer tracers)) + ( perasCertDiffusionMaxFifoLength miniProtocolParameters + , 10 -- TODO: see https://github.com/tweag/cardano-peras/issues/97 + , 10 -- TODO: see https://github.com/tweag/cardano-peras/issues/97 + ) + (makePerasCertPoolWriterFromChainDB systemTime getChainDB) + version + controlMessageSTM + state + , hPerasCertDiffusionServer = \version peer -> + objectDiffusionOutbound + (contramap (TraceLabelPeer peer) (Node.perasCertDiffusionOutboundTracer tracers)) + (perasCertDiffusionMaxFifoLength miniProtocolParameters) + (makePerasCertPoolReaderFromChainDB $ getChainDB) + version , hKeepAliveClient = \_version -> keepAliveClient (Node.keepAliveClientTracer tracers) keepAliveRng , hKeepAliveServer = \_version _peer -> keepAliveServer , hPeerSharingClient = \_version controlMessageSTM _peer -> peerSharingClient controlMessageSTM @@ -304,7 +350,7 @@ mkHandlers -------------------------------------------------------------------------------} -- | Node-to-node protocol codecs needed to run 'Handlers'. -data Codecs blk addr e m bCS bSCS bBF bSBF bTX bKA bPS = Codecs +data Codecs blk addr e m bCS bSCS bBF bSBF bTX bPCD bKA bPS = Codecs { cChainSyncCodec :: Codec (ChainSync (Header blk) (Point blk) (Tip blk)) e m bCS , cChainSyncCodecSerialised :: Codec (ChainSync (SerialisedHeader blk) (Point blk) (Tip blk)) e m bSCS @@ -312,6 +358,7 @@ data Codecs blk addr e m bCS bSCS bBF bSBF bTX bKA bPS = Codecs , cBlockFetchCodecSerialised :: Codec (BlockFetch (Serialised blk) (Point blk)) e m bSBF , cTxSubmission2Codec :: Codec (TxSubmission2 (GenTxId blk) (GenTx blk)) e m bTX + , cPerasCertDiffusionCodec :: Codec (PerasCertDiffusion blk) e m bPCD , cKeepAliveCodec :: Codec KeepAlive e m bKA , cPeerSharingCodec :: Codec (PeerSharing addr) e m bPS } @@ -339,49 +386,53 @@ defaultCodecs :: ByteString ByteString ByteString + ByteString defaultCodecs ccfg version encAddr decAddr nodeToNodeVersion = Codecs { cChainSyncCodec = codecChainSync enc dec - (encodePoint (encodeRawHash p)) - (decodePoint (decodeRawHash p)) - (encodeTip (encodeRawHash p)) - (decodeTip (decodeRawHash p)) + enc + dec + enc + dec , cChainSyncCodecSerialised = codecChainSync enc dec - (encodePoint (encodeRawHash p)) - (decodePoint (decodeRawHash p)) - (encodeTip (encodeRawHash p)) - (decodeTip (decodeRawHash p)) + enc + dec + enc + dec , cBlockFetchCodec = codecBlockFetch enc dec - (encodePoint (encodeRawHash p)) - (decodePoint (decodeRawHash p)) + enc + dec , cBlockFetchCodecSerialised = codecBlockFetch enc dec - (encodePoint (encodeRawHash p)) - (decodePoint (decodeRawHash p)) + enc + dec , cTxSubmission2Codec = codecTxSubmission2 enc dec enc dec + , cPerasCertDiffusionCodec = + codecObjectDiffusion + enc + dec + enc + dec , cKeepAliveCodec = codecKeepAlive_v2 , cPeerSharingCodec = codecPeerSharing (encAddr nodeToNodeVersion) (decAddr nodeToNodeVersion) } where - p :: Proxy blk - p = Proxy - enc :: SerialiseNodeToNode blk a => a -> Encoding enc = encodeNodeToNode ccfg version @@ -401,6 +452,7 @@ identityCodecs :: (AnyMessage (BlockFetch blk (Point blk))) (AnyMessage (BlockFetch (Serialised blk) (Point blk))) (AnyMessage (TxSubmission2 (GenTxId blk) (GenTx blk))) + (AnyMessage (PerasCertDiffusion blk)) (AnyMessage KeepAlive) (AnyMessage (PeerSharing addr)) identityCodecs = @@ -410,6 +462,7 @@ identityCodecs = , cBlockFetchCodec = codecBlockFetchId , cBlockFetchCodecSerialised = codecBlockFetchId , cTxSubmission2Codec = codecTxSubmission2Id + , cPerasCertDiffusionCodec = codecObjectDiffusionId , cKeepAliveCodec = codecKeepAliveId , cPeerSharingCodec = codecPeerSharingId } @@ -432,6 +485,7 @@ data Tracers' peer ntnAddr blk e f = Tracers f (TraceLabelPeer peer (TraceSendRecv (BlockFetch (Serialised blk) (Point blk)))) , tTxSubmission2Tracer :: f (TraceLabelPeer peer (TraceSendRecv (TxSubmission2 (GenTxId blk) (GenTx blk)))) + , tPerasCertDiffusionTracer :: f (TraceLabelPeer peer (TraceSendRecv (PerasCertDiffusion blk))) , tKeepAliveTracer :: f (TraceLabelPeer peer (TraceSendRecv KeepAlive)) , tPeerSharingTracer :: f (TraceLabelPeer peer (TraceSendRecv (PeerSharing ntnAddr))) } @@ -444,6 +498,7 @@ instance (forall a. Semigroup (f a)) => Semigroup (Tracers' peer ntnAddr blk e f , tBlockFetchTracer = f tBlockFetchTracer , tBlockFetchSerialisedTracer = f tBlockFetchSerialisedTracer , tTxSubmission2Tracer = f tTxSubmission2Tracer + , tPerasCertDiffusionTracer = f tPerasCertDiffusionTracer , tKeepAliveTracer = f tKeepAliveTracer , tPeerSharingTracer = f tPeerSharingTracer } @@ -464,6 +519,7 @@ nullTracers = , tBlockFetchTracer = nullTracer , tBlockFetchSerialisedTracer = nullTracer , tTxSubmission2Tracer = nullTracer + , tPerasCertDiffusionTracer = nullTracer , tKeepAliveTracer = nullTracer , tPeerSharingTracer = nullTracer } @@ -485,6 +541,7 @@ showTracers tr = , tBlockFetchTracer = showTracing tr , tBlockFetchSerialisedTracer = showTracing tr , tTxSubmission2Tracer = showTracing tr + , tPerasCertDiffusionTracer = showTracing tr , tKeepAliveTracer = showTracing tr , tPeerSharingTracer = showTracing tr } @@ -509,7 +566,7 @@ type ServerApp m addr bytes a = -- | Applications for the node-to-node protocols -- -- See 'Network.Mux.Types.MuxApplication' -data Apps m addr bCS bBF bTX bKA bPS a b = Apps +data Apps m addr bCS bBF bTX bPCD bKA bPS a b = Apps { aChainSyncClient :: ClientApp m addr bCS a -- ^ Start a chain sync client that communicates with the given upstream -- node. @@ -525,6 +582,10 @@ data Apps m addr bCS bBF bTX bKA bPS a b = Apps -- given upstream node. , aTxSubmission2Server :: ServerApp m addr bTX b -- ^ Start a transaction submission v2 server. + , aPerasCertDiffusionClient :: ClientApp m addr bPCD a + -- ^ Start a Peras cert diffusion client. + , aPerasCertDiffusionServer :: ServerApp m addr bPCD b + -- ^ Start a Peras cert diffusion server. , aKeepAliveClient :: ClientApp m addr bKA a -- ^ Start a keep-alive client. , aKeepAliveServer :: ServerApp m addr bKA b @@ -540,7 +601,7 @@ data Apps m addr bCS bBF bTX bKA bPS a b = Apps -- -- They don't depend on the instantiation of the protocol parameters (which -- block type is used, etc.), hence the use of 'RankNTypes'. -data ByteLimits bCS bBF bTX bKA bPS = ByteLimits +data ByteLimits bCS bBF bTX bPCD bKA bPS = ByteLimits { blChainSync :: forall header point tip. ProtocolSizeLimits @@ -556,6 +617,11 @@ data ByteLimits bCS bBF bTX bKA bPS = ByteLimits ProtocolSizeLimits (TxSubmission2 txid tx) bTX + , blPerasCertDiffusion :: + forall blk. + ProtocolSizeLimits + (PerasCertDiffusion blk) + bPCD , blKeepAlive :: ProtocolSizeLimits KeepAlive @@ -567,22 +633,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 } @@ -594,7 +662,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 @@ -609,8 +677,8 @@ mkApps :: NodeKernel m addrNTN addrNTC blk -> StdGen -> Tracers m addrNTN blk e -> - (NodeToNodeVersion -> Codecs blk addrNTN e m bCS bCS bBF bBF bTX bKA bPS) -> - ByteLimits bCS bBF bTX bKA bPS -> + (NodeToNodeVersion -> Codecs blk addrNTN e m bCS bCS bBF bBF bTX bPCD 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))) -> @@ -618,7 +686,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 @@ -797,6 +865,56 @@ mkApps kernel rng Tracers{..} mkCodecs ByteLimits{..} chainSyncTimeouts lopBucke channel (txSubmissionServerPeerPipelined (hTxSubmissionServer version them)) + aPerasCertDiffusionClient :: + NodeToNodeVersion -> + ExpandedInitiatorContext addrNTN m -> + Channel m bPCD -> + m (NodeToNodeInitiatorResult, Maybe bPCD) + aPerasCertDiffusionClient + version + ExpandedInitiatorContext + { eicConnectionId = them + , eicControlMessage = controlMessageSTM + } + channel = do + labelThisThread "PerasCertDiffusionClient" + bracketObjectDiffusionInbound + version + (getPerasCertDiffusionHandles kernel) + them + $ \state -> do + ((), trailing) <- + runPipelinedPeerWithLimits + (TraceLabelPeer them `contramap` tPerasCertDiffusionTracer) + (cPerasCertDiffusionCodec (mkCodecs version)) + blPerasCertDiffusion + timeLimitsObjectDiffusion + channel + ( objectDiffusionInboundPeerPipelined + (hPerasCertDiffusionClient version controlMessageSTM state them) + ) + return (NoInitiatorResult, trailing) + + aPerasCertDiffusionServer :: + NodeToNodeVersion -> + ResponderContext addrNTN -> + Channel m bPCD -> + m ((), Maybe bPCD) + aPerasCertDiffusionServer + version + ResponderContext{rcConnectionId = them} + channel = do + labelThisThread "PerasCertDiffusionServer" + runPeerWithLimits + (TraceLabelPeer them `contramap` tPerasCertDiffusionTracer) + (cPerasCertDiffusionCodec (mkCodecs version)) + blPerasCertDiffusion + timeLimitsObjectDiffusion + channel + ( objectDiffusionOutboundPeer + (hPerasCertDiffusionServer version them) + ) + aKeepAliveClient :: NodeToNodeVersion -> ExpandedInitiatorContext addrNTN m -> @@ -897,13 +1015,15 @@ mkApps kernel rng Tracers{..} mkCodecs ByteLimits{..} chainSyncTimeouts lopBucke -- on the protocol version, but it eventually may; this is why @_version@ is -- currently unused. initiator :: + Set CardanoFeatureFlag -> MiniProtocolParameters -> NodeToNodeVersion -> NodeToNodeVersionData -> - Apps m addr b b b b b a c -> + Apps m addr b b b b b b a c -> OuroborosBundleWithExpandedCtx 'Mux.InitiatorMode addr b m a Void -initiator miniProtocolParameters version versionData Apps{..} = +initiator featureFlags miniProtocolParameters version versionData Apps{..} = nodeToNodeProtocols + featureFlags miniProtocolParameters -- TODO: currently consensus is using 'ConnectionId' for its 'peer' type. -- This is currently ok, as we might accept multiple connections from the @@ -918,6 +1038,10 @@ initiator miniProtocolParameters version versionData Apps{..} = (InitiatorProtocolOnly (MiniProtocolCb (\ctx -> aBlockFetchClient version ctx))) , txSubmissionProtocol = (InitiatorProtocolOnly (MiniProtocolCb (\ctx -> aTxSubmission2Client version ctx))) + , perasCertDiffusionProtocol = + (InitiatorProtocolOnly (MiniProtocolCb (\ctx -> aPerasCertDiffusionClient version ctx))) + , perasVoteDiffusionProtocol = + error "perasVoteDiffusionProtocol not implemented" , keepAliveProtocol = (InitiatorProtocolOnly (MiniProtocolCb (\ctx -> aKeepAliveClient version ctx))) , peerSharingProtocol = @@ -933,13 +1057,15 @@ initiator miniProtocolParameters version versionData Apps{..} = -- on the protocol version, but it eventually may; this is why @_version@ is -- currently unused. initiatorAndResponder :: + Set CardanoFeatureFlag -> MiniProtocolParameters -> NodeToNodeVersion -> NodeToNodeVersionData -> - Apps m addr b b b b b a c -> + Apps m addr b b b b b b a c -> OuroborosBundleWithExpandedCtx 'Mux.InitiatorResponderMode addr b m a c -initiatorAndResponder miniProtocolParameters version versionData Apps{..} = +initiatorAndResponder featureFlags miniProtocolParameters version versionData Apps{..} = nodeToNodeProtocols + featureFlags miniProtocolParameters ( NodeToNodeProtocols { chainSyncProtocol = @@ -957,6 +1083,13 @@ initiatorAndResponder miniProtocolParameters version versionData Apps{..} = (MiniProtocolCb (\initiatorCtx -> aTxSubmission2Client version initiatorCtx)) (MiniProtocolCb (\responderCtx -> aTxSubmission2Server version responderCtx)) ) + , perasCertDiffusionProtocol = + ( InitiatorAndResponderProtocol + (MiniProtocolCb (\initiatorCtx -> aPerasCertDiffusionClient version initiatorCtx)) + (MiniProtocolCb (\responderCtx -> aPerasCertDiffusionServer version responderCtx)) + ) + , perasVoteDiffusionProtocol = + error "perasVoteDiffusionProtocol not implemented" , keepAliveProtocol = ( InitiatorAndResponderProtocol (MiniProtocolCb (\initiatorCtx -> aKeepAliveClient version initiatorCtx)) diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node.hs index 5bd6b825f0..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 @@ -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,8 +577,10 @@ runWith RunNodeArgs{..} encAddrNtN decAddrNtN LowLevelRunNodeArgs{..} = gsmAntiThunderingHerd keepAliveRng cfg + llrnFeatureFlags rnTraceConsensus btime + systemTime (InFutureCheck.realHeaderInFutureCheck llrnMaxClockSkew systemTime) historicityCheck chainDB @@ -650,6 +658,7 @@ runWith RunNodeArgs{..} encAddrNtN decAddrNtN LowLevelRunNodeArgs{..} = ByteString ByteString ByteString + ByteString NodeToNodeInitiatorResult () mkNodeToNodeApps nodeKernelArgs nodeKernel peerMetrics encAddrNTN decAddrNTN version = @@ -691,6 +700,7 @@ runWith RunNodeArgs{..} encAddrNtN decAddrNtN LowLevelRunNodeArgs{..} = ByteString ByteString ByteString + ByteString NodeToNodeInitiatorResult () ) -> @@ -732,7 +742,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. @@ -747,7 +757,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 @@ -846,8 +856,10 @@ mkNodeKernelArgs :: StdGen -> StdGen -> TopLevelConfig blk -> + Set CardanoFeatureFlag -> Tracers m (ConnectionId addrNTN) (ConnectionId addrNTC) blk -> BlockchainTime m -> + SystemTime m -> InFutureCheck.SomeHeaderInFutureCheck m blk -> (m GSM.GsmState -> HistoricityCheck m blk) -> ChainDB m blk -> @@ -865,8 +877,10 @@ mkNodeKernelArgs gsmAntiThunderingHerd rng cfg + featureFlags tracers btime + systemTime chainSyncFutureCheck chainSyncHistoricityCheck chainDB @@ -884,7 +898,9 @@ mkNodeKernelArgs { tracers , registry , cfg + , featureFlags , btime + , systemTime , chainDB , initChainDB = nodeInitChainDB , chainSyncFutureCheck @@ -1002,6 +1018,7 @@ stdLowLevelRunNodeArgsIO { rnProtocolInfo , rnPeerSharing , rnGenesisConfig + , rnFeatureFlags } $(SafeWildCards.fields 'StdRunNodeArgs) = do llrnBfcSalt <- stdBfcSaltIO @@ -1051,6 +1068,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/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/Node/GSM/PeerState.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/GSM/PeerState.hs new file mode 100644 index 0000000000..ce092dad15 --- /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.V1.State + ( ObjectDiffusionInboundHandle (..) + , ObjectDiffusionInboundHandleCollection (..) + , ObjectDiffusionInboundState (..) + ) +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.PerasCert (PerasCertDiffusionInboundState) +import Ouroboros.Consensus.Util.IOLike (MonadSTM (..), readTVar) +import Ouroboros.Network.NodeToNode.Version (isPerasEnabled) + +-- | State about peers we are connected to during initialization. +newtype GsmPeerState blk = GsmPeerState + { unGsmPeerState :: + These + (ChainSyncState blk) + (PerasCertDiffusionInboundState blk) + } + +-- | Retrieve the 'ChainSync' state of this peer, if such a connection is established. +maybeChainSyncState :: GsmPeerState blk -> Maybe (ChainSyncState blk) +maybeChainSyncState (GsmPeerState these) = + case these of + This csState -> Just csState + That _ -> Nothing + These csState _ -> Just csState + +-- | Retrieve the 'PerasCertDiffusion' state of this peer, if such a connection is established. +maybePerasCertDiffusionState :: GsmPeerState blk -> Maybe (PerasCertDiffusionInboundState blk) +maybePerasCertDiffusionState (GsmPeerState these) = + case these of + This _ -> Nothing + That pcdState -> Just pcdState + These _ pcdState -> Just pcdState + +-- | Construct a 'GsmPeerState' for all peers we are connected to. +mkGsmPeerStates :: + (Ord peer, MonadSTM m) => + ChainSyncClientHandleCollection peer m blk -> + ObjectDiffusionInboundHandleCollection peer m blk -> + STM m (Map peer (GsmPeerState blk)) +mkGsmPeerStates csHandles pcdHandles = do + csPeerStates <- traverse (readTVar . cschState) =<< cschcMap csHandles + pcdPeerStates <- traverse (readTVar . odihState) =<< odihcMap pcdHandles + pure (GsmPeerState <$> align csPeerStates pcdPeerStates) + +-- | Determine whether our connections to this peer are idle. +gsmPeerIsIdle :: Set CardanoFeatureFlag -> GsmPeerState blk -> Bool +gsmPeerIsIdle featureFlags (GsmPeerState these) = + case these of + -- We have both ChainSync and PerasCertDiffusion connections => idle if both are idling + These csState pcdState -> csIdling csState && odisIdling pcdState + -- Only a ChainSync connection is available => idle if the ChainSync connection is idling + This csState | not (perasIsEnabled csState) -> csIdling csState + -- We will soon establish a PerasCertDiffusion connection => not idling + This _ -> False + -- We will soon establish a ChainSync connection => not idling + That _ -> False + where + -- Is the Peras feature flag enabled and the peer is compatible with it? + perasIsEnabled csState = isPerasEnabled featureFlags (csNodeToNodeVersion csState) diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/Tracers.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/Tracers.hs index 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-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs index 1c45c68155..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 @@ -27,6 +27,7 @@ module Ouroboros.Consensus.NodeKernel , toConsensusMode ) where +import Cardano.Base.FeatureFlags (CardanoFeatureFlag (..)) import Cardano.Network.ConsensusMode (ConsensusMode (..)) import Cardano.Network.PeerSelection.Bootstrap (UseBootstrapPeers) import Cardano.Network.PeerSelection.LocalRootPeers @@ -49,8 +50,9 @@ import Data.Functor ((<&>)) import Data.Hashable (Hashable) import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NE -import Data.Maybe (isJust, mapMaybe) +import Data.Maybe (isJust, isNothing, mapMaybe) import Data.Proxy +import Data.Set (Set) import qualified Data.Text as Text import Data.Void (Void) import Ouroboros.Consensus.Block hiding (blockMatchesHeader) @@ -80,8 +82,16 @@ import Ouroboros.Consensus.MiniProtocol.ChainSync.Client.HistoricityCheck import Ouroboros.Consensus.MiniProtocol.ChainSync.Client.InFutureCheck ( SomeHeaderInFutureCheck ) +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.V1.State + ( ObjectDiffusionInboundHandleCollection (..) + , newObjectDiffusionInboundHandleCollection + ) +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.PerasCert + ( PerasCertDiffusionInboundHandleCollection + ) import Ouroboros.Consensus.Node.GSM (GsmNodeKernelArgs (..)) import qualified Ouroboros.Consensus.Node.GSM as GSM +import Ouroboros.Consensus.Node.GSM.PeerState (gsmPeerIsIdle, maybeChainSyncState, mkGsmPeerStates) import Ouroboros.Consensus.Node.Genesis ( GenesisNodeKernelArgs (..) , LoEAndGDDConfig (..) @@ -173,6 +183,9 @@ data NodeKernel m addrNTN addrNTC blk = NodeKernel -- from it with 'GSM.gsmStateToLedgerJudgement'. , getChainSyncHandles :: ChainSyncClientHandleCollection (ConnectionId addrNTN) m blk -- ^ The kill handle and exposed state for each ChainSync client. + , getPerasCertDiffusionHandles :: + ObjectDiffusionInboundHandleCollection (ConnectionId addrNTN) m blk + -- ^ The exposed state for each Peras CertDiffusion client. , getPeerSharingRegistry :: PeerSharingRegistry addrNTN m -- ^ Read the current peer sharing registry, used for interacting with -- the PeerSharing protocol @@ -195,7 +208,9 @@ data NodeKernelArgs m addrNTN addrNTC blk = NodeKernelArgs { tracers :: Tracers m (ConnectionId addrNTN) addrNTC blk , registry :: ResourceRegistry m , cfg :: TopLevelConfig blk + , featureFlags :: Set CardanoFeatureFlag , btime :: BlockchainTime m + , systemTime :: SystemTime m , chainDB :: ChainDB m blk , initChainDB :: StorageConfig blk -> InitChainDB m blk -> m () , chainSyncFutureCheck :: SomeHeaderInFutureCheck m blk @@ -232,6 +247,7 @@ initNodeKernel args@NodeKernelArgs { registry , cfg + , featureFlags , tracers , chainDB , initChainDB @@ -254,6 +270,7 @@ initNodeKernel , mempool , peerSharingRegistry , varChainSyncHandles + , varPerasCertDiffusionHandles , varGsmState } = st @@ -272,24 +289,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.getChainSyncStates = fmap cschState <$> cschcMap varChainSyncHandles + , GSM.getPeerStates = + mkGsmPeerStates + varChainSyncHandles + varPerasCertDiffusionHandles , GSM.getCurrentSelection = do headers <- ChainDB.getCurrentChainWithTime chainDB extLedgerState <- ChainDB.getCurrentLedger chainDB @@ -366,6 +393,7 @@ initNodeKernel , getFetchMode = readFetchMode blockFetchInterface , getGsmState = readTVar varGsmState , getChainSyncHandles = varChainSyncHandles + , getPerasCertDiffusionHandles = varPerasCertDiffusionHandles , getPeerSharingRegistry = peerSharingRegistry , getTracers = tracers , setBlockForging = \a -> atomically . LazySTM.putTMVar blockForgingVar $! a @@ -416,6 +444,8 @@ data InternalState m addrNTN addrNTC blk = IS BlockFetchConsensusInterface (ConnectionId addrNTN) (HeaderWithTime blk) blk m , fetchClientRegistry :: FetchClientRegistry (ConnectionId addrNTN) (HeaderWithTime blk) blk m , varChainSyncHandles :: ChainSyncClientHandleCollection (ConnectionId addrNTN) m blk + , varPerasCertDiffusionHandles :: + PerasCertDiffusionInboundHandleCollection (ConnectionId addrNTN) m blk , varGsmState :: StrictTVar m GSM.GsmState , mempool :: Mempool m blk , peerSharingRegistry :: PeerSharingRegistry addrNTN m @@ -454,6 +484,8 @@ initInternalState newTVarIO gsmState varChainSyncHandles <- atomically newChainSyncClientHandleCollection + varPerasCertDiffusionHandles <- atomically newObjectDiffusionInboundHandleCollection + mempool <- openMempool registry diff --git a/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs b/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs index 6df036c539..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 @@ -83,6 +83,7 @@ import Ouroboros.Consensus.Mempool import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client as CSClient import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client.HistoricityCheck as HistoricityCheck import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client.InFutureCheck as InFutureCheck +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.PerasCert (PerasCertDiffusion) import qualified Ouroboros.Consensus.Network.NodeToNode as NTN import Ouroboros.Consensus.Node.ExitPolicy import qualified Ouroboros.Consensus.Node.GSM as GSM @@ -123,8 +124,8 @@ import Ouroboros.Network.NodeToNode ( ConnectionId (..) , ExpandedInitiatorContext (..) , IsBigLedgerPeer (..) - , MiniProtocolParameters (..) , ResponderContext (..) + , defaultMiniProtocolParameters ) import Ouroboros.Network.PeerSelection.Governor ( makePublicPeerSelectionStateVar @@ -1044,7 +1045,9 @@ runThreadNetwork { tracers , registry , cfg = pInfoConfig + , featureFlags = mempty , btime + , systemTime , chainDB , initChainDB = nodeInitChainDB , chainSyncFutureCheck = @@ -1056,13 +1059,7 @@ runThreadNetwork , mempoolCapacityOverride = NoMempoolCapacityBytesOverride , keepAliveRng = kaRng , peerSharingRng = psRng - , miniProtocolParameters = - MiniProtocolParameters - { chainSyncPipeliningHighMark = 4 - , chainSyncPipeliningLowMark = 2 - , blockFetchPipeliningMax = 10 - , txSubmissionMaxUnacked = 1000 -- TODO ? - } + , miniProtocolParameters = defaultMiniProtocolParameters , blockFetchConfiguration = BlockFetchConfiguration { bfcMaxConcurrencyBulkSync = 1 @@ -1188,6 +1185,7 @@ runThreadNetwork Lazy.ByteString Lazy.ByteString (AnyMessage (TxSubmission2 (GenTxId blk) (GenTx blk))) + (AnyMessage (PerasCertDiffusion blk)) (AnyMessage KeepAlive) (AnyMessage (PeerSharing NodeId)) customNodeToNodeCodecs cfg ntnVersion = @@ -1207,6 +1205,9 @@ runThreadNetwork , cTxSubmission2Codec = mapFailureCodec CodecIdFailure $ NTN.cTxSubmission2Codec NTN.identityCodecs + , cPerasCertDiffusionCodec = + mapFailureCodec CodecIdFailure $ + NTN.cPerasCertDiffusionCodec NTN.identityCodecs , cKeepAliveCodec = mapFailureCodec CodecIdFailure $ NTN.cKeepAliveCodec NTN.identityCodecs @@ -1797,6 +1798,7 @@ type LimitedApp' m addr blk = Lazy.ByteString Lazy.ByteString (AnyMessage (TxSubmission2 (GenTxId blk) (GenTx blk))) + (AnyMessage (PerasCertDiffusion blk)) (AnyMessage KeepAlive) (AnyMessage (PeerSharing addr)) NodeToNodeInitiatorResult diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/GSM.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/GSM.hs index 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/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 a58923bd60..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 @@ -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. 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-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 diff --git a/ouroboros-consensus/bench/ChainSync-client-bench/Main.hs b/ouroboros-consensus/bench/ChainSync-client-bench/Main.hs index 70854581a8..9d983608d2 100644 --- a/ouroboros-consensus/bench/ChainSync-client-bench/Main.hs +++ b/ouroboros-consensus/bench/ChainSync-client-bench/Main.hs @@ -37,6 +37,7 @@ import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client.InFutureCheck import Ouroboros.Consensus.MiniProtocol.ChainSync.Server ( chainSyncServerForFollower ) +import qualified Ouroboros.Consensus.MiniProtocol.Util.Idling as Idling import Ouroboros.Consensus.Node.NetworkProtocolVersion ( NodeToNodeVersion ) @@ -158,7 +159,7 @@ oneBenchRun , CSClient.headerMetricsTracer = nullTracer , CSClient.setCandidate = writeTVar varCandidate , CSClient.setLatestSlot = \_ -> pure () - , CSClient.idling = CSClient.noIdling + , CSClient.idling = Idling.noIdling , CSClient.loPBucket = CSClient.noLoPBucket , CSClient.jumping = CSClient.noJumping } diff --git a/ouroboros-consensus/bench/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 5f2cd98720..c7e8542a2b 100644 --- a/ouroboros-consensus/ouroboros-consensus.cabal +++ b/ouroboros-consensus/ouroboros-consensus.cabal @@ -191,6 +191,20 @@ library Ouroboros.Consensus.MiniProtocol.LocalStateQuery.Server Ouroboros.Consensus.MiniProtocol.LocalTxMonitor.Server 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.TestUtils + Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.V2.Types + Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API + Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.PerasCert + Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Outbound + Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.PerasCert + Ouroboros.Consensus.MiniProtocol.Util + Ouroboros.Consensus.MiniProtocol.Util.Idling Ouroboros.Consensus.Node.GsmState Ouroboros.Consensus.Node.InitStorage Ouroboros.Consensus.Node.NetworkProtocolVersion @@ -198,7 +212,9 @@ library Ouroboros.Consensus.Node.Run Ouroboros.Consensus.Node.Serialisation 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 @@ -300,6 +316,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 @@ -307,6 +324,7 @@ library build-depends: FailT ^>=0.1.2, + QuickCheck, aeson, base >=4.14 && <4.22, base-deriving-via, @@ -343,6 +361,8 @@ library primitive, psqueues ^>=0.2.3, quiet ^>=0.2, + random, + random-shuffle, rawlock ^>=0.1.1, resource-registry ^>=0.1, semialign >=1.1, @@ -664,8 +684,12 @@ 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.Voting Test.Consensus.Peras.WeightSnapshot Test.Consensus.Util.MonadSTM.NormalForm + Test.Consensus.Util.Pred Test.Consensus.Util.Versioned build-depends: @@ -913,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/Block/SupportsPeras.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs index bdfd9c826c..a1a468ee8b 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 #-} @@ -13,16 +13,16 @@ module Ouroboros.Consensus.Block.SupportsPeras ( PerasRoundNo (..) + , onPerasRoundNo , PerasWeight (..) - , boostPerCert , BlockSupportsPeras (..) , PerasCert (..) + , PerasCfg (..) , ValidatedPerasCert (..) , makePerasCfg - , HasPerasCert (..) - , getPerasCertRound - , getPerasCertBoostedBlock - , getPerasCertBoost + , HasPerasCertRound (..) + , HasPerasCertBoostedBlock (..) + , HasPerasCertBoost (..) -- * Ouroboros Peras round length , PerasRoundLength (..) @@ -32,12 +32,14 @@ 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) 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 (..)) @@ -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 @@ -166,20 +174,47 @@ makePerasCfg _ = { perasCfgWeightBoost = boostPerCert } -class StandardHash blk => HasPerasCert cert blk where - getPerasCert :: cert blk -> PerasCert blk +-- | Extract the certificate round from a Peras certificate container +class HasPerasCertRound cert where + getPerasCertRound :: cert -> PerasRoundNo + +instance HasPerasCertRound (PerasCert blk) where + getPerasCertRound = pcCertRound -instance StandardHash blk => HasPerasCert PerasCert blk where - getPerasCert = id +instance HasPerasCertRound (ValidatedPerasCert blk) where + getPerasCertRound = getPerasCertRound . vpcCert -instance StandardHash blk => HasPerasCert ValidatedPerasCert blk where - getPerasCert = vpcCert +instance + HasPerasCertRound cert => + HasPerasCertRound (WithArrivalTime cert) + where + getPerasCertRound = getPerasCertRound . forgetArrivalTime -getPerasCertRound :: HasPerasCert cert blk => cert blk -> PerasRoundNo -getPerasCertRound = pcCertRound . getPerasCert +-- | Extract the boosted block point from a Peras certificate container +class HasPerasCertBoostedBlock cert blk | cert -> blk where + getPerasCertBoostedBlock :: cert -> Point blk -getPerasCertBoostedBlock :: HasPerasCert cert blk => cert blk -> Point blk -getPerasCertBoostedBlock = pcCertBoostedBlock . getPerasCert +instance HasPerasCertBoostedBlock (PerasCert blk) blk where + getPerasCertBoostedBlock = pcCertBoostedBlock -getPerasCertBoost :: ValidatedPerasCert blk -> PerasWeight -getPerasCertBoost = vpcCertBoost +instance HasPerasCertBoostedBlock (ValidatedPerasCert blk) blk where + getPerasCertBoostedBlock = getPerasCertBoostedBlock . vpcCert + +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) where + getPerasCertBoost = vpcCertBoost + +instance + HasPerasCertBoost cert => + HasPerasCertBoost (WithArrivalTime cert) + where + getPerasCertBoost = getPerasCertBoost . forgetArrivalTime diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/BlockchainTime/WallClock/Types.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/BlockchainTime/WallClock/Types.hs index 28105dd672..16277ad4ec 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/BlockchainTime/WallClock/Types.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/BlockchainTime/WallClock/Types.hs @@ -1,4 +1,6 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} module Ouroboros.Consensus.BlockchainTime.WallClock.Types @@ -15,6 +17,10 @@ module Ouroboros.Consensus.BlockchainTime.WallClock.Types -- * Get current time (as 'RelativeTime') , SystemTime (..) + -- * Attach an arrival time (as 'RelativeTime') to an object + , WithArrivalTime (..) + , addArrivalTime + -- * Slot length , getSlotLength , mkSlotLength @@ -31,6 +37,7 @@ module Ouroboros.Consensus.BlockchainTime.WallClock.Types import Cardano.Slotting.Time import Data.Time.Clock (NominalDiffTime) +import GHC.Generics (Generic) import NoThunks.Class (NoThunks, OnlyCheckWhnfNamed (..)) addRelTime :: NominalDiffTime -> RelativeTime -> RelativeTime @@ -60,3 +67,22 @@ data SystemTime m = SystemTime -- to reach 'SystemStart'. In tests this does nothing. } deriving NoThunks via OnlyCheckWhnfNamed "SystemTime" (SystemTime m) + +{------------------------------------------------------------------------------- + Attach an arrival time (as RelativeTime) to an object +-------------------------------------------------------------------------------} + +-- | WithArrivalTime +data WithArrivalTime a = WithArrivalTime + { getArrivalTime :: !RelativeTime + -- ^ The time at which the object arrived + , forgetArrivalTime :: !a + -- ^ The object without its arrival time + } + deriving (Show, Eq, Ord, Generic, NoThunks) + +-- | Add an arrival time to an object +addArrivalTime :: Monad m => SystemTime m -> a -> m (WithArrivalTime a) +addArrivalTime systemTime a = do + t <- systemTimeCurrent systemTime + return (WithArrivalTime t a) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Abstract.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Abstract.hs index 7498024f6a..b2a07369df 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Abstract.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Abstract.hs @@ -67,6 +67,6 @@ neverForksHardForkSummary :: LedgerState blk mk -> HardFork.Summary '[blk] neverForksHardForkSummary getParams cfg _st = - HardFork.neverForksSummary eraEpochSize eraSlotLength eraGenesisWin + HardFork.neverForksSummary eraEpochSize eraSlotLength eraGenesisWin eraPerasRoundLength where HardFork.EraParams{..} = getParams cfg diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/History/EraParams.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/History/EraParams.hs index e0784c8d34..4bcbc77786 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/History/EraParams.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/History/EraParams.hs @@ -1,9 +1,13 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralisedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} @@ -12,17 +16,23 @@ module Ouroboros.Consensus.HardFork.History.EraParams ( -- * API EraParams (..) , SafeZone (..) + , PerasEnabled + , pattern PerasEnabled + , pattern NoPerasEnabled + , PerasEnabledT (..) + , fromPerasEnabled -- * Defaults , defaultEraParams ) where -import Cardano.Binary (enforceSize) +import Cardano.Binary (DecoderError (DecoderErrorCustom), cborError) import Cardano.Ledger.BaseTypes (unNonZero) import Codec.CBOR.Decoding (Decoder, decodeListLen, decodeWord8) import Codec.CBOR.Encoding (Encoding, encodeListLen, encodeWord8) import Codec.Serialise (Serialise (..)) -import Control.Monad (void) +import Control.Monad (ap, liftM, void) +import Control.Monad.Trans.Class import Data.Word import GHC.Generics (Generic) import NoThunks.Class (NoThunks) @@ -136,10 +146,57 @@ data EraParams = EraParams , eraSlotLength :: !SlotLength , eraSafeZone :: !SafeZone , eraGenesisWin :: !GenesisWindow + , eraPerasRoundLength :: !(PerasEnabled PerasRoundLength) + -- ^ Optional, as not every era will be Peras-enabled } deriving stock (Show, Eq, Generic) deriving anyclass NoThunks +-- | A marker for era parameters that are Peras-specific +-- and are not present in pre-Peras eras +newtype PerasEnabled a = MkPerasEnabled (Maybe a) + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass NoThunks + deriving newtype (Functor, Applicative, Monad) + +pattern PerasEnabled :: a -> PerasEnabled a +pattern PerasEnabled x <- MkPerasEnabled (Just !x) + where + PerasEnabled !x = MkPerasEnabled (Just x) + +pattern NoPerasEnabled :: PerasEnabled a +pattern NoPerasEnabled = MkPerasEnabled Nothing + +{-# COMPLETE PerasEnabled, NoPerasEnabled #-} + +-- | A 'fromMaybe'-like eliminator for 'PerasEnabled' +fromPerasEnabled :: a -> PerasEnabled a -> a +fromPerasEnabled defaultValue = + \case + NoPerasEnabled -> defaultValue + PerasEnabled value -> value + +-- | A 'MaybeT'-line monad transformer. +-- +-- Used solely for the Peras-related hard fork combinator queries, +-- see 'Ouroboros.Consensus.HardFork.History.Qry'. +newtype PerasEnabledT m a = PerasEnabledT {runPerasEnabledT :: m (PerasEnabled a)} + deriving stock Functor + +instance (Functor m, Monad m) => Applicative (PerasEnabledT m) where + pure = PerasEnabledT . pure . PerasEnabled + (<*>) = ap + +instance Monad m => Monad (PerasEnabledT m) where + x >>= f = PerasEnabledT $ do + v <- runPerasEnabledT x + case v of + NoPerasEnabled -> pure NoPerasEnabled + PerasEnabled y -> runPerasEnabledT (f y) + +instance MonadTrans PerasEnabledT where + lift = PerasEnabledT . liftM PerasEnabled + -- | Default 'EraParams' -- -- We set @@ -147,6 +204,7 @@ data EraParams = EraParams -- * epoch size to @10k@ slots -- * the safe zone to @2k@ slots -- * the upper bound to 'NoLowerBound' +-- * the Peras Round Length is unset -- -- This is primarily useful for tests. defaultEraParams :: SecurityParam -> SlotLength -> EraParams @@ -156,6 +214,8 @@ defaultEraParams (SecurityParam k) slotLength = , eraSlotLength = slotLength , eraSafeZone = StandardSafeZone (unNonZero k * 2) , eraGenesisWin = GenesisWindow (unNonZero k * 2) + , -- Peras is disabled by default + eraPerasRoundLength = NoPerasEnabled } -- | Zone in which it is guaranteed that no hard fork can take place @@ -235,17 +295,27 @@ decodeSafeBeforeEpoch = do instance Serialise EraParams where encode EraParams{..} = mconcat $ - [ encodeListLen 4 + [ encodeListLen $ case eraPerasRoundLength of + NoPerasEnabled -> 4 + PerasEnabled{} -> 5 , encode (unEpochSize eraEpochSize) , encode eraSlotLength , encode eraSafeZone , encode (unGenesisWindow eraGenesisWin) ] + <> case eraPerasRoundLength of + NoPerasEnabled -> [] + PerasEnabled rl -> [encode (unPerasRoundLength rl)] decode = do - enforceSize "EraParams" 4 + len <- decodeListLen eraEpochSize <- EpochSize <$> decode eraSlotLength <- decode eraSafeZone <- decode eraGenesisWin <- GenesisWindow <$> decode + eraPerasRoundLength <- + case len of + 4 -> pure NoPerasEnabled + 5 -> PerasEnabled . PerasRoundLength <$> decode + _ -> cborError (DecoderErrorCustom "EraParams" "unexpected list length") return EraParams{..} diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/History/Qry.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/History/Qry.hs index 9c4844c752..786c269433 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/History/Qry.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/History/Qry.hs @@ -42,12 +42,15 @@ module Ouroboros.Consensus.HardFork.History.Qry , slotToSlotLength , slotToWallclock , wallclockToSlot + , perasRoundNoToSlot + , slotToPerasRoundNo ) where import Codec.Serialise (Serialise (..)) import Control.Exception (throw) import Control.Monad (ap, guard, liftM, (>=>)) import Control.Monad.Except () +import Control.Monad.Trans.Class import Data.Bifunctor import Data.Fixed (divMod') import Data.Foldable (toList) @@ -126,6 +129,8 @@ import Quiet These are equal by (INV-2a). + 5. Slot to Peras round translation. + This means that for values at that boundary, it does not matter if we use this era or the next era for the translation. However, this is only true for these 4 translations. If we are returning the era parameters directly, then @@ -182,12 +187,16 @@ newtype TimeInSlot = TimeInSlot {getTimeInSlot :: NominalDiffTime} deriving Gene newtype SlotInEra = SlotInEra {getSlotInEra :: Word64} deriving Generic newtype SlotInEpoch = SlotInEpoch {getSlotInEpoch :: Word64} deriving Generic newtype EpochInEra = EpochInEra {getEpochInEra :: Word64} deriving Generic +newtype PerasRoundNoInEra = PerasRoundNoInEra {getPerasRoundNoInEra :: Word64} deriving Generic +newtype SlotInPerasRound = SlotInPerasRound {getSlotInPerasRound :: Word64} deriving Generic deriving via Quiet TimeInEra instance Show TimeInEra deriving via Quiet TimeInSlot instance Show TimeInSlot deriving via Quiet SlotInEra instance Show SlotInEra deriving via Quiet SlotInEpoch instance Show SlotInEpoch deriving via Quiet EpochInEra instance Show EpochInEra +deriving via Quiet PerasRoundNoInEra instance Show PerasRoundNoInEra +deriving via Quiet SlotInPerasRound instance Show SlotInPerasRound {------------------------------------------------------------------------------- Expressions @@ -212,23 +221,30 @@ data Expr (f :: Type -> Type) :: Type -> Type where EAbsToRelTime :: Expr f RelativeTime -> Expr f TimeInEra EAbsToRelSlot :: Expr f SlotNo -> Expr f SlotInEra EAbsToRelEpoch :: Expr f EpochNo -> Expr f EpochInEra + EAbsToRelPerasRoundNo :: Expr f PerasRoundNo -> Expr f (PerasEnabled PerasRoundNoInEra) -- Convert from era-relative to absolute ERelToAbsTime :: Expr f TimeInEra -> Expr f RelativeTime ERelToAbsSlot :: Expr f (SlotInEra, TimeInSlot) -> Expr f SlotNo ERelToAbsEpoch :: Expr f (EpochInEra, SlotInEpoch) -> Expr f EpochNo + ERelToAbsPerasRoundNo :: + Expr f (PerasEnabled PerasRoundNoInEra) -> Expr f (PerasEnabled PerasRoundNo) -- Convert between relative values ERelTimeToSlot :: Expr f TimeInEra -> Expr f (SlotInEra, TimeInSlot) ERelSlotToTime :: Expr f SlotInEra -> Expr f TimeInEra ERelSlotToEpoch :: Expr f SlotInEra -> Expr f (EpochInEra, SlotInEpoch) ERelEpochToSlot :: Expr f EpochInEra -> Expr f SlotInEra + ERelPerasRoundNoToSlot :: Expr f (PerasEnabled PerasRoundNoInEra) -> Expr f (PerasEnabled SlotInEra) + ERelSlotToPerasRoundNo :: + Expr f SlotInEra -> Expr f (PerasEnabled (PerasRoundNoInEra, SlotInPerasRound)) -- Get era parameters -- The arguments are used for bound checks ESlotLength :: Expr f SlotNo -> Expr f SlotLength EEpochSize :: Expr f EpochNo -> Expr f EpochSize EGenesisWindow :: Expr f SlotNo -> Expr f GenesisWindow + EPerasRoundLength :: Expr f PerasRoundNo -> Expr f (PerasEnabled PerasRoundLength) {------------------------------------------------------------------------------- Interpreter @@ -247,6 +263,11 @@ evalExprInEra EraSummary{..} = \(ClosedExpr e) -> go e EraUnbounded -> return () EraEnd b -> guard $ p b + guardEndPeras :: (Bound -> PerasEnabledT Maybe Bool) -> PerasEnabledT Maybe () + guardEndPeras p = case eraEnd of + EraUnbounded -> pure () + EraEnd end -> lift . guard =<< p end + go :: Expr Identity a -> Maybe a go (EVar a) = return $ runIdentity a @@ -279,6 +300,13 @@ evalExprInEra EraSummary{..} = \(ClosedExpr e) -> go e e <- go expr guard (e >= boundEpoch eraStart) return $ EpochInEra (countEpochs e (boundEpoch eraStart)) + go (EAbsToRelPerasRoundNo expr) = + runPerasEnabledT $ do + eraStartPerasRound <- PerasEnabledT . Just $ boundPerasRound eraStart + absPerasRoundNo <- lift $ go expr + lift . guard $ absPerasRoundNo >= eraStartPerasRound + let roundInEra = countPerasRounds absPerasRoundNo eraStartPerasRound + pure . PerasRoundNoInEra $ roundInEra -- Convert relative to absolute -- @@ -304,6 +332,15 @@ evalExprInEra EraSummary{..} = \(ClosedExpr e) -> go e absEpoch < boundEpoch end || absEpoch == boundEpoch end && getSlotInEpoch s == 0 return absEpoch + go (ERelToAbsPerasRoundNo expr) = runPerasEnabledT $ do + eraStartPerasRound <- PerasEnabledT . Just $ boundPerasRound eraStart + relPerasRound <- PerasEnabledT $ go expr + let absPerasRound = addPerasRounds (getPerasRoundNoInEra relPerasRound) eraStartPerasRound + + guardEndPeras $ \end -> do + eraEndPerasRound <- PerasEnabledT . Just $ boundPerasRound end + pure $ absPerasRound <= eraEndPerasRound + pure absPerasRound -- Convert between relative values -- @@ -321,6 +358,14 @@ evalExprInEra EraSummary{..} = \(ClosedExpr e) -> go e go (ERelEpochToSlot expr) = do e <- go expr return $ SlotInEra (getEpochInEra e * epochSize) + go (ERelPerasRoundNoToSlot expr) = runPerasEnabledT $ do + PerasRoundNoInEra relPerasRoundNo <- PerasEnabledT $ go expr + PerasRoundLength perasRoundLength <- PerasEnabledT . Just $ eraPerasRoundLength + pure $ SlotInEra (relPerasRoundNo * perasRoundLength) + go (ERelSlotToPerasRoundNo expr) = runPerasEnabledT $ do + SlotInEra relSlot <- lift $ go expr + PerasRoundLength perasRoundLength <- PerasEnabledT . Just $ eraPerasRoundLength + pure . bimap PerasRoundNoInEra SlotInPerasRound $ relSlot `divMod` perasRoundLength -- Get era parameters -- @@ -342,6 +387,14 @@ evalExprInEra EraSummary{..} = \(ClosedExpr e) -> go e guard $ s >= boundSlot eraStart guardEnd $ \end -> s < boundSlot end return eraGenesisWin + go (EPerasRoundLength expr) = runPerasEnabledT $ do + eraStartPerasRound <- PerasEnabledT . Just $ boundPerasRound eraStart + absPerasRound <- lift $ go expr + lift . guard $ absPerasRound >= eraStartPerasRound + guardEndPeras $ \end -> do + eraEndPerasRound <- PerasEnabledT . Just $ boundPerasRound end + pure $ absPerasRound < eraEndPerasRound + PerasEnabledT . Just $ eraPerasRoundLength {------------------------------------------------------------------------------- PastHorizonException @@ -499,7 +552,7 @@ slotToEpoch' absSlot = -- | Translate 'SlotNo' to its corresponding 'EpochNo' -- -- Additionally returns the relative slot within this epoch and how many --- slots are left in this slot. +-- slots are left in this epoch. slotToEpoch :: SlotNo -> Qry (EpochNo, Word64, Word64) slotToEpoch absSlot = aux <$> qryFromExpr (slotToEpochExpr absSlot) @@ -528,6 +581,38 @@ epochToSize :: EpochNo -> Qry EpochSize epochToSize absEpoch = qryFromExpr (epochToSizeExpr absEpoch) +-- | Translate 'PerasRoundNo' to the 'SlotNo' of the first slot in that Peras round +-- +-- Additionally returns the length of the round. +perasRoundNoToSlot :: PerasRoundNo -> Qry (PerasEnabled (SlotNo, PerasRoundLength)) +perasRoundNoToSlot perasRoundNo = runPerasEnabledT $ do + relSlot <- + PerasEnabledT $ qryFromExpr (ERelPerasRoundNoToSlot (EAbsToRelPerasRoundNo (ELit perasRoundNo))) + absSlot <- lift $ qryFromExpr (ERelToAbsSlot (EPair (ELit relSlot) (ELit (TimeInSlot 0)))) + roundLength <- PerasEnabledT $ qryFromExpr (perasRoundNoPerasRoundLengthExpr perasRoundNo) + pure (absSlot, roundLength) + +-- | Translate 'SlotNo' to its corresponding 'PerasRoundNo' +-- +-- Additionally returns the relative slot within this round and how many +-- slots are left in this round. +slotToPerasRoundNo :: SlotNo -> Qry (PerasEnabled (PerasRoundNo, Word64, Word64)) +slotToPerasRoundNo absSlot = runPerasEnabledT $ do + (relPerasRoundNo, slotInPerasRound) <- + PerasEnabledT $ + qryFromExpr (ERelSlotToPerasRoundNo (EAbsToRelSlot (ELit absSlot))) + absPerasRoundNo <- + PerasEnabledT $ + qryFromExpr (ERelToAbsPerasRoundNo (ELit (PerasEnabled relPerasRoundNo))) + roundLength <- + PerasEnabledT $ + qryFromExpr (perasRoundNoPerasRoundLengthExpr absPerasRoundNo) + pure $ + ( absPerasRoundNo + , getSlotInPerasRound slotInPerasRound + , unPerasRoundLength roundLength - getSlotInPerasRound slotInPerasRound + ) + {------------------------------------------------------------------------------- Supporting expressions for the queries above -------------------------------------------------------------------------------} @@ -581,6 +666,10 @@ slotToGenesisWindow :: SlotNo -> Expr f GenesisWindow slotToGenesisWindow absSlot = EGenesisWindow (ELit absSlot) +perasRoundNoPerasRoundLengthExpr :: PerasRoundNo -> Expr f (PerasEnabled PerasRoundLength) +perasRoundNoPerasRoundLengthExpr absPerasRoundNo = + EPerasRoundLength (ELit absPerasRoundNo) + {------------------------------------------------------------------------------- 'Show' instances -------------------------------------------------------------------------------} @@ -629,13 +718,18 @@ instance Show (ClosedExpr a) where EAbsToRelTime e -> showString "EAbsToRelTime " . go n 11 e EAbsToRelSlot e -> showString "EAbsToRelSlot " . go n 11 e EAbsToRelEpoch e -> showString "EAbsToRelEpoch " . go n 11 e + EAbsToRelPerasRoundNo e -> showString "EAbsToRelPerasRoundNo " . go n 11 e ERelToAbsTime e -> showString "ERelToAbsTime " . go n 11 e ERelToAbsSlot e -> showString "ERelToAbsSlot " . go n 11 e ERelToAbsEpoch e -> showString "ERelToAbsEpoch " . go n 11 e + ERelToAbsPerasRoundNo e -> showString "ERelToAbsPerasRoundNo " . go n 11 e ERelTimeToSlot e -> showString "ERelTimeToSlot " . go n 11 e ERelSlotToTime e -> showString "ERelSlotToTime " . go n 11 e ERelSlotToEpoch e -> showString "ERelSlotToEpoch " . go n 11 e ERelEpochToSlot e -> showString "ERelEpochToSlot " . go n 11 e + ERelPerasRoundNoToSlot e -> showString "ERelPerasRoundNoToSlot " . go n 11 e + ERelSlotToPerasRoundNo e -> showString "ERelSlotToPerasRoundNo " . go n 11 e ESlotLength e -> showString "ESlotLength " . go n 11 e EEpochSize e -> showString "EEpochSize " . go n 11 e EGenesisWindow e -> showString "EGenesisWindow " . go n 11 e + EPerasRoundLength e -> showString "EPerasRoundLength " . go n 11 e diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/History/Summary.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/History/Summary.hs index 0ef241f4a5..03b71562e1 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/History/Summary.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/History/Summary.hs @@ -47,7 +47,7 @@ module Ouroboros.Consensus.HardFork.History.Summary , summaryInit ) where -import Cardano.Binary (enforceSize) +import Cardano.Binary (DecoderError (DecoderErrorCustom), cborError, decodeListLen, enforceSize) import Codec.CBOR.Decoding ( TokenType (TypeNull) , decodeNull @@ -83,6 +83,8 @@ data Bound = Bound { boundTime :: !RelativeTime , boundSlot :: !SlotNo , boundEpoch :: !EpochNo + , boundPerasRound :: !(PerasEnabled PerasRoundNo) + -- ^ Optional, as not every era will be Peras-enabled } deriving stock (Show, Eq, Generic) deriving anyclass NoThunks @@ -93,6 +95,9 @@ initBound = { boundTime = RelativeTime 0 , boundSlot = SlotNo 0 , boundEpoch = EpochNo 0 + , -- TODO(geo2a): we may want to make this configurable, + -- see https://github.com/tweag/cardano-peras/issues/112 + boundPerasRound = NoPerasEnabled } -- | Version of 'mkUpperBound' when the upper bound may not be known @@ -122,12 +127,16 @@ mkUpperBound EraParams{..} lo hiEpoch = { boundTime = addRelTime inEraTime $ boundTime lo , boundSlot = addSlots inEraSlots $ boundSlot lo , boundEpoch = hiEpoch + , boundPerasRound = addPerasRounds <$> inEraPerasRounds <*> boundPerasRound lo } where inEraEpochs, inEraSlots :: Word64 inEraEpochs = countEpochs hiEpoch (boundEpoch lo) inEraSlots = inEraEpochs * unEpochSize eraEpochSize + inEraPerasRounds :: PerasEnabled Word64 + inEraPerasRounds = div <$> PerasEnabled inEraSlots <*> (unPerasRoundLength <$> eraPerasRoundLength) + inEraTime :: NominalDiffTime inEraTime = fromIntegral inEraSlots * getSlotLength eraSlotLength @@ -182,6 +191,10 @@ slotToEpochBound EraParams{eraEpochSize = EpochSize epochSize} lo hiSlot = -- > t' - t == ((s' - s) * slotLen) -- > (t' - t) / slotLen == s' - s -- > s + ((t' - t) / slotLen) == s' +-- +-- Ouroboros Peras adds an invariant relating epoch size and Peras voting round lengths: +-- > epochSize % perasRoundLength == 0 +-- i.e. the round length should divide the epoch size data EraSummary = EraSummary { eraStart :: !Bound -- ^ Inclusive lower bound @@ -219,8 +232,9 @@ newtype Summary xs = Summary {getSummary :: NonEmpty xs EraSummary} -------------------------------------------------------------------------------} -- | 'Summary' for a ledger that never forks -neverForksSummary :: EpochSize -> SlotLength -> GenesisWindow -> Summary '[x] -neverForksSummary epochSize slotLen genesisWindow = +neverForksSummary :: + EpochSize -> SlotLength -> GenesisWindow -> PerasEnabled PerasRoundLength -> Summary '[x] +neverForksSummary epochSize slotLen genesisWindow perasRoundLength = Summary $ NonEmptyOne $ EraSummary @@ -232,6 +246,7 @@ neverForksSummary epochSize slotLen genesisWindow = , eraSlotLength = slotLen , eraSafeZone = UnsafeIndefiniteSafeZone , eraGenesisWin = genesisWindow + , eraPerasRoundLength = perasRoundLength } } @@ -331,8 +346,19 @@ summarize :: Transitions xs -> Summary xs summarize ledgerTip = \(Shape shape) (Transitions transitions) -> - Summary $ go initBound shape transitions + Summary $ go initBoundWithPeras shape transitions where + -- as noted in the haddock, this function is only used for testing purposes, + -- therefore we make the initial era is Peras-enabled, which means + -- we only test Peras-enabled eras. It is rather difficult + -- to parameterise the test suite, as it requires also parameterise many non-test functions, like + -- 'HF.initBound'. + -- + -- TODO(geo2a): revisit this hard-coding of enabling Peras when + -- we're further into the integration process + -- see https://github.com/tweag/cardano-peras/issues/112 + initBoundWithPeras = initBound{boundPerasRound = PerasEnabled . PerasRoundNo $ 0} + go :: Bound -> -- Lower bound for current era Exactly (x ': xs) EraParams -> -- params for all eras @@ -471,6 +497,21 @@ invariantSummary = \(Summary summary) -> , " (INV-2b)" ] + case eraPerasRoundLength curParams of + NoPerasEnabled -> pure () + PerasEnabled perasRoundLength -> + unless + ( (unEpochSize $ eraEpochSize curParams) + `mod` (unPerasRoundLength perasRoundLength) + == 0 + ) + $ throwError + $ mconcat + [ "Invalid Peras round length " + , show curSummary + , " (Peras round length does not divide epoch size)" + ] + go curEnd next where curStart :: Bound @@ -484,18 +525,27 @@ invariantSummary = \(Summary summary) -> instance Serialise Bound where encode Bound{..} = - mconcat - [ encodeListLen 3 + mconcat $ + [ encodeListLen $ case boundPerasRound of + NoPerasEnabled -> 3 + PerasEnabled{} -> 4 , encode boundTime , encode boundSlot , encode boundEpoch ] + <> case boundPerasRound of + NoPerasEnabled -> [] + PerasEnabled bound -> [encode bound] decode = do - enforceSize "Bound" 3 + len <- decodeListLen boundTime <- decode boundSlot <- decode boundEpoch <- decode + boundPerasRound <- case len of + 3 -> pure NoPerasEnabled + 4 -> PerasEnabled <$> decode + _ -> cborError (DecoderErrorCustom "Bound" "unexpected list length") return Bound{..} instance Serialise EraEnd where diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/History/Util.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/History/Util.hs index daf8fd443e..7cdebd4ea0 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/History/Util.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/History/Util.hs @@ -2,8 +2,10 @@ module Ouroboros.Consensus.HardFork.History.Util ( -- * Adding and subtracting slots/epochs addEpochs , addSlots + , addPerasRounds , countEpochs , countSlots + , countPerasRounds , subSlots ) where @@ -26,6 +28,9 @@ subSlots n (SlotNo x) = assert (x >= n) $ SlotNo (x - n) addEpochs :: Word64 -> EpochNo -> EpochNo addEpochs n (EpochNo x) = EpochNo (x + n) +addPerasRounds :: Word64 -> PerasRoundNo -> PerasRoundNo +addPerasRounds n (PerasRoundNo x) = PerasRoundNo (x + n) + -- | @countSlots to fr@ counts the slots from @fr@ to @to@ (@to >= fr@) countSlots :: HasCallStack => SlotNo -> SlotNo -> Word64 countSlots (SlotNo to) (SlotNo fr) = assert (to >= fr) $ to - fr @@ -37,3 +42,8 @@ countEpochs :: HasCallStack => EpochNo -> EpochNo -> Word64 countEpochs (EpochNo to) (EpochNo fr) = assert (to >= fr) $ to - fr where _ = keepRedundantConstraint (Proxy :: Proxy HasCallStack) + +countPerasRounds :: HasCallStack => PerasRoundNo -> PerasRoundNo -> Word64 +countPerasRounds (PerasRoundNo to) (PerasRoundNo fr) = assert (to >= fr) $ to - fr + where + _ = keepRedundantConstraint (Proxy :: Proxy HasCallStack) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client.hs index fcb0e25388..85b0b1a487 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client.hs @@ -73,7 +73,6 @@ module Ouroboros.Consensus.MiniProtocol.ChainSync.Client , Jumping.noJumping , chainSyncStateFor , newChainSyncClientHandleCollection - , noIdling , noLoPBucket , viewChainSyncState ) where @@ -122,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 ()) @@ -405,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/V1.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Inbound/V1.hs new file mode 100644 index 0000000000..e19eb43302 --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Inbound/V1.hs @@ -0,0 +1,478 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.V1 + ( 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 (..)) +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.V1.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) +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. + TraceObjectDiffusionInboundCollectedObjects Int + | -- | Just processed object pass/fail breakdown. + TraceObjectDiffusionInboundAddedObjects NumObjectsProcessed + | -- | Received a 'ControlMessage' from the outbound peer governor, and about + -- to act on it. + TraceObjectDiffusionInboundRecvControlMessage ControlMessage + | TraceObjectDiffusionInboundCanRequestMoreObjects Int + | TraceObjectDiffusionInboundCannotRequestMoreObjects Int + | TraceObjectDiffusionInboundStartedIdling + | TraceObjectDiffusionInboundStoppedIdling + deriving (Eq, Show) + +data ObjectDiffusionInboundError + = ProtocolErrorObjectNotRequested + | ProtocolErrorObjectIdsNotRequested + | ProtocolErrorObjectIdAlreadyKnown + | ProtocolErrorObjectIdsDuplicate + deriving Show + +instance Exception ObjectDiffusionInboundError where + displayException ProtocolErrorObjectNotRequested = + "The peer replied with a object we did not ask for." + displayException ProtocolErrorObjectIdsNotRequested = + "The peer replied with more objectIds than we asked for." + displayException ProtocolErrorObjectIdAlreadyKnown = + "The peer replied with an objectId that it has already sent us previously." + displayException ProtocolErrorObjectIdsDuplicate = + "The peer replied with a batch of objectIds containing a duplicate." + +-- | Information maintained internally in the 'objectDiffusionInbound' +-- implementation. +data InboundSt objectId object = InboundSt + { numIdsInFlight :: !NumObjectIdsReq + -- ^ The number of object identifiers that we have requested but + -- which have not yet been replied to. We need to track this to keep + -- our requests within the limit on the 'outstandingFifo' size. + , outstandingFifo :: !(StrictSeq objectId) + -- ^ This mirrors the queue of objects that the outbound peer has available + -- for us. Objects are kept in the order in which the outbound peer + -- advertised them to us. This is the same order in which we submit them to + -- the objectPool. It is also the order we acknowledge them. + , canRequestNext :: !(Set objectId) + -- ^ The objectIds that we can request. These are a subset of the + -- 'outstandingFifo' that we have not yet requested or not have in the pool + -- already. This is not ordered to illustrate the fact that we can + -- request objects out of order. + , pendingObjects :: !(Map objectId (Maybe object)) + -- ^ Objects we have successfully downloaded (or decided intentionally to + -- skip download) but have not yet added to the objectPool or acknowledged. + -- + -- Object IDs in this 'Map' are mapped to 'Nothing' if we notice that + -- they are already in the objectPool. That way we can skip requesting them + -- from the outbound peer, but still acknowledge them when the time comes. + , numToAckOnNextReq :: !NumObjectIdsAck + -- ^ The number of objects we can acknowledge on our next request + -- for more object IDs. Their corresponding IDs have already been removed + -- from 'outstandingFifo'. + } + deriving stock (Show, Generic) + deriving anyclass NoThunks + +initialInboundSt :: InboundSt objectId object +initialInboundSt = InboundSt 0 Seq.empty Set.empty Map.empty 0 + +objectDiffusionInbound :: + forall objectId object m. + ( Ord objectId + , NoThunks objectId + , NoThunks object + , MonadSTM m + , MonadThrow m + ) => + Tracer m (TraceObjectDiffusionInbound objectId object) -> + -- | Maximum values for outstanding FIFO length, number of IDs to request, + -- and number of objects to request + (NumObjectsOutstanding, NumObjectIdsReq, NumObjectsReq) -> + ObjectPoolWriter objectId object m -> + NodeToNodeVersion -> + ControlMessageSTM m -> + ObjectDiffusionInboundStateView m -> + ObjectDiffusionInboundPipelined objectId object m () +objectDiffusionInbound + tracer + (maxFifoLength, maxNumIdsToReq, maxNumObjectsToReq) + ObjectPoolWriter{..} + _version + controlMessageSTM + state = + ObjectDiffusionInboundPipelined $! + checkState initialInboundSt & go Zero + 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 + poolHasObject + 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' = + 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). + 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 + + !st' = + st + { canRequestNext = canRequestNext st <> (Set.fromList notYetObtained) + , pendingObjects = pendingObjects'' + , outstandingFifo = outstandingFifo'' + , numToAckOnNextReq = + numToAckOnNextReq st + + fromIntegral (Seq.length objectIdsToAck) + } + in + st' + + go :: + forall (n :: N). + Nat n -> + 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 $ + TraceObjectDiffusionInboundRecvControlMessage 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 $ + 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 $ + 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. + 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 $ + TraceObjectDiffusionInboundCanRequestMoreObjects (natToInt n) + pure $! + CollectPipelined + (Just (checkState st & goReqObjectsAndObjectIdsPipelined (Succ n'))) + (\collected -> checkState st & goCollect n' collected) + else do + traceWith tracer $ + TraceObjectDiffusionInboundCannotRequestMoreObjects (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 + (\collected -> checkState st & goCollect n' collected) + + goCollect :: + forall (n :: N). + Nat n -> + 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 + + -- 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 + 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) + + -- 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 $ + TraceObjectDiffusionInboundCollectedObjects (length collectedObjects) + + -- We update 'pendingObjects' with the newly obtained objects + 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'. + -- 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) + + opwAddObjects objectsToAck + traceWith tracer $ + TraceObjectDiffusionInboundAddedObjects + (NumObjectsProcessed (fromIntegral $ length objectsToAck)) + + 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. + !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 -> + 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 :: + forall (n :: N). + Nat n -> + 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) + !st' = st{canRequestNext = canRequestNext'} + in SendMsgRequestObjectsPipelined + (toList toRequest) + (checkState st' & goReqObjectIdsPipelined (Succ n)) + + goReqObjectIdsPipelined :: + forall (n :: N). + Nat n -> + InboundSt objectId object -> + InboundStIdle n objectId object m () + goReqObjectIdsPipelined n !st = + let numIdsToRequest = numIdsToReq st + 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 () + 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/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Inbound/V1/State.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Inbound/V1/State.hs new file mode 100644 index 0000000000..3aa84c3915 --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Inbound/V1/State.hs @@ -0,0 +1,138 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} + +module Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.V1.State + ( ObjectDiffusionInboundState (..) + , initObjectDiffusionInboundState + , ObjectDiffusionInboundHandle (..) + , ObjectDiffusionInboundHandleCollection (..) + , ObjectDiffusionInboundStateView (..) + , newObjectDiffusionInboundHandleCollection + , bracketObjectDiffusionInbound + ) +where + +import Control.Monad.Class.MonadThrow (bracket) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import GHC.Generics (Generic) +import NoThunks.Class (NoThunks) +import Ouroboros.Consensus.Block (BlockSupportsProtocol, HasHeader, Header) +import Ouroboros.Consensus.MiniProtocol.Util.Idling (Idling (..)) +import Ouroboros.Consensus.Node.NetworkProtocolVersion (NodeToNodeVersion) +import Ouroboros.Consensus.Util.IOLike + ( IOLike (..) + , MonadSTM (..) + , StrictTVar + , modifyTVar + , newTVar + , newTVarIO + , readTVar + ) + +-- | An ObjectDiffusion inbound client state that's used by other components. +-- +-- NOTE: 'blk' is not needed for now, but we keep it for future use. +data ObjectDiffusionInboundState blk = ObjectDiffusionInboundState + { odisIdling :: !Bool + -- ^ Whether the client is currently idling + , odisNodeToNodeVersion :: !NodeToNodeVersion + -- ^ Negotiated version of the protocol with the peer. + -- + -- This is used to determine later on whether other mini-protocols are + -- expected to run in parallel with this one. + } + deriving stock Generic + +deriving anyclass instance + ( HasHeader blk + , NoThunks (Header blk) + ) => + NoThunks (ObjectDiffusionInboundState blk) + +initObjectDiffusionInboundState :: NodeToNodeVersion -> ObjectDiffusionInboundState blk +initObjectDiffusionInboundState version = + ObjectDiffusionInboundState + { odisIdling = True + , odisNodeToNodeVersion = version + } + +-- | An interface to an ObjectDiffusion inbound client that's used by other components. +data ObjectDiffusionInboundHandle m blk = ObjectDiffusionInboundHandle + { odihState :: !(StrictTVar m (ObjectDiffusionInboundState blk)) + -- ^ Data shared between the client and external components. + } + deriving stock Generic + +deriving anyclass instance + ( IOLike m + , HasHeader blk + , NoThunks (Header blk) + ) => + NoThunks (ObjectDiffusionInboundHandle m blk) + +-- | A collection of ObjectDiffusion inbound client handles for the peers of this node. +data ObjectDiffusionInboundHandleCollection peer m blk = ObjectDiffusionInboundHandleCollection + { odihcMap :: !(STM m (Map peer (ObjectDiffusionInboundHandle m blk))) + -- ^ A map containing the handles for the peers in the collection + , odihcAddHandle :: !(peer -> ObjectDiffusionInboundHandle m blk -> STM m ()) + -- ^ Add the handle for the given peer to the collection + , odihcRemoveHandle :: !(peer -> STM m ()) + -- ^ Remove the handle for the given peer from the collection + } + deriving stock Generic + +newObjectDiffusionInboundHandleCollection :: + (Ord peer, IOLike m, NoThunks peer, BlockSupportsProtocol blk) => + STM m (ObjectDiffusionInboundHandleCollection peer m blk) +newObjectDiffusionInboundHandleCollection = do + handlesMap <- newTVar mempty + return + ObjectDiffusionInboundHandleCollection + { odihcMap = readTVar handlesMap + , odihcAddHandle = \peer handle -> + modifyTVar handlesMap (Map.insert peer handle) + , odihcRemoveHandle = \peer -> + modifyTVar handlesMap (Map.delete peer) + } + +-- | Interface for the ObjectDiffusion client to its state allocated by +-- 'bracketObjectDiffusionInbound'. +data ObjectDiffusionInboundStateView m = ObjectDiffusionInboundStateView + { odisvIdling :: !(Idling m) + } + deriving stock Generic + +bracketObjectDiffusionInbound :: + forall m peer blk a. + (IOLike m, HasHeader blk, NoThunks (Header blk)) => + NodeToNodeVersion -> + ObjectDiffusionInboundHandleCollection peer m blk -> + peer -> + (ObjectDiffusionInboundStateView m -> m a) -> + m a +bracketObjectDiffusionInbound version handles peer body = do + odiState <- newTVarIO (initObjectDiffusionInboundState version) + bracket (acquireContext odiState) releaseContext body + where + acquireContext odiState = atomically $ do + odihcAddHandle handles peer $ + ObjectDiffusionInboundHandle + { odihState = odiState + } + return + ObjectDiffusionInboundStateView + { odisvIdling = + Idling + { idlingStart = atomically $ modifyTVar odiState $ \s -> s{odisIdling = True} + , idlingStop = atomically $ modifyTVar odiState $ \s -> s{odisIdling = False} + } + } + + releaseContext _ = atomically $ do + odihcRemoveHandle handles peer diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/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/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 + } 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." diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/API.hs new file mode 100644 index 0000000000..2f949d8b3b --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/API.hs @@ -0,0 +1,59 @@ +-- | API for reading from and writing to object pools in the ObjectDiffusion +-- miniprotocol. +-- +-- The underlying object pool can be any database, such as a 'PerasCertDb' in +-- Peras certificate diffusion. +-- +-- 'ObjectPoolReader' is used on the outbound side of the protocol. Objects in +-- the pool are ordered by a strictly increasing ticket number ('ticketNo'), +-- which represents their time of arrival. Ticket numbers are local to each +-- node, unlike object IDs, which are global. Object IDs are not used for +-- ordering, since objects may arrive slightly out of order from peers. +-- +-- To read from the pool, one requests objects with a ticket number strictly +-- greater than the last known one. 'oprZeroTicketNo' provides an initial ticket +-- number for the first request. +-- +-- 'ObjectPoolWriter' is used on the inbound side of the protocol. It allows +-- checking whether an object is already present (to avoid re-requesting it) and +-- appending new objects. Ticket numbers are not part of the inbound interface, +-- but are used internally: newly added objects always receive a ticket number +-- strictly greater than those of older ones. +-- +-- This API design is inspired by 'MempoolSnapshot' from the TX-submission +-- miniprotocol, see: +-- +module Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API + ( ObjectPoolReader (..) + , ObjectPoolWriter (..) + ) where + +import Control.Concurrent.Class.MonadSTM.Strict (STM) +import Data.Word (Word64) + +-- | Interface used by the outbound side of object diffusion as its source of +-- objects to give to the remote side. +data ObjectPoolReader objectId object ticketNo m + = ObjectPoolReader + { oprObjectId :: object -> objectId + -- ^ Return the id of the specified object + , oprZeroTicketNo :: ticketNo + -- ^ Ticket number before the first item in the pool. + , oprObjectsAfter :: ticketNo -> Word64 -> STM m [(ticketNo, objectId, m object)] + -- ^ Get the list of objects available in the pool with a ticketNo greater + -- than the specified one. The number of returned objects is capped by the + -- given Word64. Only the IDs and ticketNos of the objects are directly + -- accessible; each actual object must be loaded through a monadic action. + } + +-- | Interface used by the inbound side of object diffusion when receiving +-- objects. +data ObjectPoolWriter objectId object m + = ObjectPoolWriter + { opwObjectId :: object -> objectId + -- ^ Return the id of the specified object + , opwAddObjects :: [object] -> m () + -- ^ Add a batch of objects to the objectPool. + , opwHasObject :: STM m (objectId -> Bool) + -- ^ Check if the object pool contains an object with the given id + } diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasCert.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasCert.hs new file mode 100644 index 0000000000..fa70be56a7 --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasCert.hs @@ -0,0 +1,135 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE StandaloneDeriving #-} + +-- | Instantiate 'ObjectPoolReader' and 'ObjectPoolWriter' using Peras +-- certificates from the 'PerasCertDB' (or the 'ChainDB' which is wrapping the +-- 'PerasCertDB'). +module Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.PerasCert + ( makePerasCertPoolReaderFromCertDB + , makePerasCertPoolWriterFromCertDB + , makePerasCertPoolReaderFromChainDB + , makePerasCertPoolWriterFromChainDB + ) where + +import Control.Monad ((>=>)) +import 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 (..) + , 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 +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 => + STM m (PerasCertSnapshot blk) -> + ObjectPoolReader PerasRoundNo (PerasCert blk) PerasCertTicketNo m +makePerasCertPoolReaderFromSnapshot getCertSnapshot = + ObjectPoolReader + { oprObjectId = getPerasCertRound + , oprZeroTicketNo = PerasCertDB.zeroPerasCertTicketNo + , oprObjectsAfter = \lastKnown limit -> do + certSnapshot <- getCertSnapshot + pure $ + take (fromIntegral limit) $ + [ (ticketNo, getPerasCertRound cert, pure (vpcCert (forgetArrivalTime cert))) + | (ticketNo, cert) <- + Map.toAscList $ + PerasCertDB.getCertsAfter certSnapshot lastKnown + ] + } + +makePerasCertPoolReaderFromCertDB :: + IOLike m => + PerasCertDB m blk -> ObjectPoolReader PerasRoundNo (PerasCert blk) PerasCertTicketNo m +makePerasCertPoolReaderFromCertDB perasCertDB = + makePerasCertPoolReaderFromSnapshot (PerasCertDB.getCertSnapshot perasCertDB) + +makePerasCertPoolWriterFromCertDB :: + (StandardHash blk, IOLike m) => + SystemTime m -> + PerasCertDB m blk -> + ObjectPoolWriter PerasRoundNo (PerasCert blk) m +makePerasCertPoolWriterFromCertDB systemTime perasCertDB = + ObjectPoolWriter + { opwObjectId = getPerasCertRound + , opwAddObjects = addPerasCerts systemTime (PerasCertDB.addCert perasCertDB) + , opwHasObject = do + certSnapshot <- PerasCertDB.getCertSnapshot perasCertDB + pure $ PerasCertDB.containsCert certSnapshot + } + +makePerasCertPoolReaderFromChainDB :: + IOLike m => + ChainDB m blk -> ObjectPoolReader PerasRoundNo (PerasCert blk) PerasCertTicketNo m +makePerasCertPoolReaderFromChainDB chainDB = + makePerasCertPoolReaderFromSnapshot (ChainDB.getPerasCertSnapshot chainDB) + +makePerasCertPoolWriterFromChainDB :: + (StandardHash blk, IOLike m) => + SystemTime m -> + ChainDB m blk -> + ObjectPoolWriter PerasRoundNo (PerasCert blk) m +makePerasCertPoolWriterFromChainDB systemTime chainDB = + ObjectPoolWriter + { opwObjectId = getPerasCertRound + , opwAddObjects = addPerasCerts systemTime (ChainDB.addPerasCertAsync chainDB) + , opwHasObject = do + certSnapshot <- ChainDB.getPerasCertSnapshot chainDB + pure $ PerasCertDB.containsCert certSnapshot + } + +data PerasCertInboundException + = forall blk. PerasCertValidationError (PerasValidationErr blk) + +deriving instance Show PerasCertInboundException + +instance Exception PerasCertInboundException + +-- | Validate a list of 'PerasCert's, throwing a 'PerasCertInboundException' if +-- any of them are invalid. +validatePerasCerts :: + (StandardHash blk, MonadThrow m) => + [PerasCert blk] -> + m [ValidatedPerasCert blk] +validatePerasCerts certs = do + let perasCfg = makePerasCfg Nothing + -- TODO replace the mocked-up Nothing with a real + -- 'BlockConfig' when all the plumbing is in place + -- 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 + +-- | Add a list of 'PerasCert's into an object pool. +-- +-- NOTE: we first validate the certificates, throwing an exception if any of +-- them are invalid. We then wrap them with their arrival time, and finally add +-- them to the pool using the provided adder function. +-- +-- The order of the first two operations (i.e., validation and timestamping) are +-- rather arbitrary, and the abstract Peras protocol just assumes it can happen +-- "within" a slot. +addPerasCerts :: + (StandardHash blk, MonadThrow m) => + SystemTime m -> + (WithArrivalTime (ValidatedPerasCert blk) -> m a) -> + [PerasCert blk] -> + m () +addPerasCerts systemTime adder = do + validatePerasCerts + >=> mapM (addArrivalTime systemTime) + >=> mapM_ adder diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Outbound.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Outbound.hs new file mode 100644 index 0000000000..34c90b9836 --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Outbound.hs @@ -0,0 +1,244 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Outbound + ( objectDiffusionOutbound + , TraceObjectDiffusionOutbound (..) + , ObjectDiffusionOutboundError (..) + ) where + +import Control.Exception (assert) +import Control.Monad (forM, unless, when) +import Control.Monad.Class.MonadSTM +import Control.Monad.Class.MonadThrow +import Control.Tracer (Tracer, traceWith) +import Data.List.NonEmpty qualified as NonEmpty +import Data.Sequence.Strict (StrictSeq) +import Data.Sequence.Strict qualified as Seq +import Data.Set qualified as Set +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API +import Ouroboros.Network.NodeToNode.Version (NodeToNodeVersion) +import Ouroboros.Network.Protocol.ObjectDiffusion.Outbound +import Ouroboros.Network.Protocol.ObjectDiffusion.Type + +-- Note: This module is inspired from TxSubmission outbound side. + +data TraceObjectDiffusionOutbound objectId object + = TraceObjectDiffusionOutboundRecvMsgRequestObjectIds NumObjectIdsReq + | -- | The IDs to be sent in the response + TraceObjectDiffusionOutboundSendMsgReplyObjectIds [objectId] + | -- | The IDs of the objects requested. + TraceObjectDiffusionOutboundRecvMsgRequestObjects + [objectId] + | -- | The objects to be sent in the response. + TraceObjectDiffusionOutboundSendMsgReplyObjects + [object] + | -- | Received 'MsgDone' + TraceObjectDiffusionOutboundTerminated + deriving Show + +data ObjectDiffusionOutboundError + = ProtocolErrorAckedTooManyObjectIds + | ProtocolErrorRequestedNothing + | ProtocolErrorRequestedTooManyObjectIds NumObjectIdsReq NumObjectsOutstanding + | ProtocolErrorRequestBlocking + | ProtocolErrorRequestNonBlocking + | ProtocolErrorRequestedUnavailableObject + | ProtocolErrorRequestedDuplicateObject + deriving Show + +instance Exception ObjectDiffusionOutboundError where + displayException ProtocolErrorAckedTooManyObjectIds = + "The peer tried to acknowledged more objectIds than are available to do so." + displayException (ProtocolErrorRequestedTooManyObjectIds reqNo maxUnacked) = + "The peer requested " + ++ show reqNo + ++ " objectIds which would put the " + ++ "total in flight over the limit of " + ++ show maxUnacked + displayException ProtocolErrorRequestedNothing = + "The peer requested zero objectIds." + displayException ProtocolErrorRequestBlocking = + "The peer made a blocking request for more objectIds when there are still " + ++ "unacknowledged objectIds. It should have used a non-blocking request." + displayException ProtocolErrorRequestNonBlocking = + "The peer made a non-blocking request for more objectIds when there are " + ++ "no unacknowledged objectIds. It should have used a blocking request." + displayException ProtocolErrorRequestedUnavailableObject = + "The peer requested an object which is not available, either " + ++ "because it was never available or because it was previously requested." + displayException ProtocolErrorRequestedDuplicateObject = + "The peer requested the same object twice." + +data OutboundSt objectId object ticketNo = OutboundSt + { outstandingFifo :: !(StrictSeq object) + , lastTicketNo :: !ticketNo + } + +objectDiffusionOutbound :: + forall objectId object ticketNo m. + (Ord objectId, Ord ticketNo, MonadSTM m, MonadThrow m) => + Tracer m (TraceObjectDiffusionOutbound objectId object) -> + -- | Maximum number of unacknowledged objectIds allowed + NumObjectsOutstanding -> + ObjectPoolReader objectId object ticketNo m -> + NodeToNodeVersion -> + ObjectDiffusionOutbound objectId object m () +objectDiffusionOutbound tracer maxFifoLength ObjectPoolReader{..} _version = + ObjectDiffusionOutbound (pure (makeBundle $ OutboundSt Seq.empty oprZeroTicketNo)) + where + makeBundle :: OutboundSt objectId object ticketNo -> OutboundStIdle objectId object m () + makeBundle !st = + OutboundStIdle + { recvMsgRequestObjectIds = recvMsgRequestObjectIds st + , recvMsgRequestObjects = recvMsgRequestObjects st + , recvMsgDone = traceWith tracer TraceObjectDiffusionOutboundTerminated + } + + updateStNewObjects :: + OutboundSt objectId object ticketNo -> + [(object, ticketNo)] -> + OutboundSt objectId object ticketNo + updateStNewObjects !OutboundSt{..} newObjectsWithTicketNos = + -- These objects should all be fresh + assert (all (\(_, ticketNo) -> ticketNo > lastTicketNo) newObjectsWithTicketNos) $ + let !outstandingFifo' = + outstandingFifo + <> (Seq.fromList $ fst <$> newObjectsWithTicketNos) + !lastTicketNo' + | null newObjectsWithTicketNos = lastTicketNo + | otherwise = snd $ last newObjectsWithTicketNos + in OutboundSt + { outstandingFifo = outstandingFifo' + , lastTicketNo = lastTicketNo' + } + + recvMsgRequestObjectIds :: + forall blocking. + OutboundSt objectId object ticketNo -> + SingBlockingStyle blocking -> + NumObjectIdsAck -> + NumObjectIdsReq -> + m (OutboundStObjectIds blocking objectId object m ()) + recvMsgRequestObjectIds !st@OutboundSt{..} blocking numIdsToAck numIdsToReq = do + traceWith tracer (TraceObjectDiffusionOutboundRecvMsgRequestObjectIds numIdsToReq) + + when (numIdsToAck > fromIntegral (Seq.length outstandingFifo)) $ + throwIO ProtocolErrorAckedTooManyObjectIds + + when + ( Seq.length outstandingFifo + - fromIntegral numIdsToAck + + fromIntegral numIdsToReq + > fromIntegral maxFifoLength + ) + $ throwIO (ProtocolErrorRequestedTooManyObjectIds numIdsToReq maxFifoLength) + + -- First we update our FIFO to remove the number of objectIds that the + -- inbound peer has acknowledged. + let !outstandingFifo' = Seq.drop (fromIntegral numIdsToAck) outstandingFifo + -- must specify the type here otherwise GHC complains about mismatch objectId types + st' :: OutboundSt objectId object ticketNo + !st' = st{outstandingFifo = outstandingFifo'} + + -- Grab info about any new objects after the last object ticketNo we've + -- seen, up to the number that the peer has requested. + case blocking of + ----------------------------------------------------------------------- + SingBlocking -> do + when (numIdsToReq == 0) $ + throwIO ProtocolErrorRequestedNothing + unless (Seq.null outstandingFifo') $ + throwIO ProtocolErrorRequestBlocking + + newContent <- atomically $ do + newObjectsWithTicketNos <- + oprObjectsAfter + lastTicketNo + (fromIntegral numIdsToReq) + check (not $ null newObjectsWithTicketNos) + pure newObjectsWithTicketNos + + newObjectsWithTicketNos <- forM newContent $ + \(ticketNo, _, getObject) -> do + object <- getObject + pure (object, ticketNo) + + let !newIds = oprObjectId . fst <$> newObjectsWithTicketNos + st'' = updateStNewObjects st' newObjectsWithTicketNos + + traceWith tracer (TraceObjectDiffusionOutboundSendMsgReplyObjectIds newIds) + + -- Assert objects is non-empty: we blocked until objects was + -- non-null, and we know numIdsToReq > 0, hence + -- `take numIdsToReq objects` is non-null. + assert (not $ null newObjectsWithTicketNos) $ + pure $ + SendMsgReplyObjectIds + (BlockingReply (NonEmpty.fromList $ newIds)) + (makeBundle st'') + + ----------------------------------------------------------------------- + SingNonBlocking -> do + when (numIdsToReq == 0 && numIdsToAck == 0) $ + throwIO ProtocolErrorRequestedNothing + when (Seq.null outstandingFifo') $ + throwIO ProtocolErrorRequestNonBlocking + + newContent <- + atomically $ + oprObjectsAfter lastTicketNo (fromIntegral numIdsToReq) + newObjectsWithTicketNos <- forM newContent $ + \(ticketNo, _, getObject) -> do + object <- getObject + pure (object, ticketNo) + + let !newIds = oprObjectId . fst <$> newObjectsWithTicketNos + st'' = updateStNewObjects st' newObjectsWithTicketNos + + traceWith tracer (TraceObjectDiffusionOutboundSendMsgReplyObjectIds newIds) + + pure (SendMsgReplyObjectIds (NonBlockingReply newIds) (makeBundle st'')) + + recvMsgRequestObjects :: + OutboundSt objectId object ticketNo -> + [objectId] -> + m (OutboundStObjects objectId object m ()) + recvMsgRequestObjects !st@OutboundSt{..} requestedIds = do + traceWith tracer (TraceObjectDiffusionOutboundRecvMsgRequestObjects requestedIds) + + -- All the objects correspond to advertised objectIds are already in the + -- outstandingFifo. So we don't need to read from the object pool here. + + -- I've optimized the search to do only one traversal of 'outstandingFifo'. + -- When the 'requestedIds' is exactly the whole 'outstandingFifo', then this + -- should take O(n * log n) time. + -- + -- TODO: We might need to revisit the underlying 'outstandingFifo' data + -- structure and the search if performance isn't sufficient when we'll use + -- ObjectDiffusion for votes diffusion (and not just cert diffusion). + + let requestedIdsSet = Set.fromList requestedIds + + when (Set.size requestedIdsSet /= length requestedIds) $ + throwIO ProtocolErrorRequestedDuplicateObject + + let requestedObjects = + foldr + ( \obj acc -> + if Set.member (oprObjectId obj) requestedIdsSet + then obj : acc + else acc + ) + [] + outstandingFifo + + when (Set.size requestedIdsSet /= length requestedObjects) $ + throwIO ProtocolErrorRequestedUnavailableObject + + traceWith tracer (TraceObjectDiffusionOutboundSendMsgReplyObjects requestedObjects) + + pure (SendMsgReplyObjects requestedObjects (makeBundle st)) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/PerasCert.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/PerasCert.hs new file mode 100644 index 0000000000..c86cef1707 --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/PerasCert.hs @@ -0,0 +1,54 @@ +-- | This module defines type aliases for the ObjectDiffusion protocol applied +-- to PerasCert diffusion. +module Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.PerasCert + ( TracePerasCertDiffusionInbound + , TracePerasCertDiffusionOutbound + , PerasCertPoolReader + , PerasCertPoolWriter + , PerasCertDiffusionInboundPipelined + , PerasCertDiffusionOutbound + , PerasCertDiffusion + , PerasCertDiffusionInboundState + , PerasCertDiffusionInboundHandle + , PerasCertDiffusionInboundHandleCollection + ) where + +import Ouroboros.Consensus.Block +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.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 +import Ouroboros.Network.Protocol.ObjectDiffusion.Inbound (ObjectDiffusionInboundPipelined) +import Ouroboros.Network.Protocol.ObjectDiffusion.Outbound (ObjectDiffusionOutbound) +import Ouroboros.Network.Protocol.ObjectDiffusion.Type (ObjectDiffusion) + +type TracePerasCertDiffusionInbound blk = + TraceObjectDiffusionInbound PerasRoundNo (PerasCert blk) + +type TracePerasCertDiffusionOutbound blk = + TraceObjectDiffusionOutbound PerasRoundNo (PerasCert blk) + +type PerasCertPoolReader blk m = + ObjectPoolReader PerasRoundNo (PerasCert blk) PerasCertTicketNo m + +type PerasCertPoolWriter blk m = + ObjectPoolWriter PerasRoundNo (PerasCert blk) m + +type PerasCertDiffusionInboundPipelined blk m a = + ObjectDiffusionInboundPipelined PerasRoundNo (PerasCert blk) m a + +type PerasCertDiffusionOutbound blk m a = + ObjectDiffusionOutbound PerasRoundNo (PerasCert blk) m a + +type PerasCertDiffusion blk = + ObjectDiffusion PerasRoundNo (PerasCert blk) + +type PerasCertDiffusionInboundState blk = + ObjectDiffusionInboundState blk + +type PerasCertDiffusionInboundHandle m blk = + ObjectDiffusionInboundHandle m blk + +type PerasCertDiffusionInboundHandleCollection peer m blk = + ObjectDiffusionInboundHandleCollection peer m blk diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/Util.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/Util.hs new file mode 100644 index 0000000000..58fa7d2161 --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/Util.hs @@ -0,0 +1,5 @@ +module Ouroboros.Consensus.MiniProtocol.Util + ( module Ouroboros.Consensus.MiniProtocol.Util.Idling + ) where + +import Ouroboros.Consensus.MiniProtocol.Util.Idling diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/Util/Idling.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/Util/Idling.hs new file mode 100644 index 0000000000..3962d26dd6 --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/Util/Idling.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE StandaloneDeriving #-} + +module Ouroboros.Consensus.MiniProtocol.Util.Idling + ( Idling (..) + , noIdling + ) where + +import GHC.Generics (Generic) +import Ouroboros.Consensus.Util.IOLike (IOLike, NoThunks) + +-- | Interface to manipulate the idling flag in the client state of a peer. +data Idling m = Idling + { idlingStart :: !(m ()) + -- ^ Mark the peer as being idle. + , idlingStop :: !(m ()) + -- ^ Mark the peer as not being idle. + } + deriving stock Generic + +deriving anyclass instance IOLike m => NoThunks (Idling m) + +-- | No-op implementation, for tests. +noIdling :: Applicative m => Idling m +noIdling = + Idling + { idlingStart = pure () + , idlingStop = pure () + } diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Node/Serialisation.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Node/Serialisation.hs index 6520aae47c..6a4fc87229 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Node/Serialisation.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Node/Serialisation.hs @@ -6,8 +6,11 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} -- | Serialisation for sending things across the network. @@ -33,8 +36,8 @@ module Ouroboros.Consensus.Node.Serialisation , Some (..) ) where -import Codec.CBOR.Decoding (Decoder) -import Codec.CBOR.Encoding (Encoding) +import Codec.CBOR.Decoding (Decoder, decodeListLenOf) +import Codec.CBOR.Encoding (Encoding, encodeListLen) import Codec.Serialise (Serialise (decode, encode)) import Data.Kind import Data.SOP.BasicFunctors @@ -47,7 +50,15 @@ import Ouroboros.Consensus.Ledger.SupportsMempool import Ouroboros.Consensus.Node.NetworkProtocolVersion import Ouroboros.Consensus.TypeFamilyWrappers import Ouroboros.Consensus.Util (Some (..)) -import Ouroboros.Network.Block (unwrapCBORinCBOR, wrapCBORinCBOR) +import Ouroboros.Network.Block + ( Tip + , decodePoint + , decodeTip + , encodePoint + , encodeTip + , unwrapCBORinCBOR + , wrapCBORinCBOR + ) {------------------------------------------------------------------------------- NodeToNode @@ -173,6 +184,29 @@ deriving newtype instance SerialiseNodeToNode blk (GenTxId blk) => SerialiseNodeToNode blk (WrapGenTxId blk) +instance ConvertRawHash blk => SerialiseNodeToNode blk (Point blk) where + encodeNodeToNode _ccfg _version = encodePoint $ encodeRawHash (Proxy @blk) + decodeNodeToNode _ccfg _version = decodePoint $ decodeRawHash (Proxy @blk) + +instance ConvertRawHash blk => SerialiseNodeToNode blk (Tip blk) where + encodeNodeToNode _ccfg _version = encodeTip $ encodeRawHash (Proxy @blk) + decodeNodeToNode _ccfg _version = decodeTip $ decodeRawHash (Proxy @blk) + +instance SerialiseNodeToNode blk PerasRoundNo where + encodeNodeToNode _ccfg _version = encode + decodeNodeToNode _ccfg _version = decode +instance ConvertRawHash blk => SerialiseNodeToNode blk (PerasCert blk) where + -- Consistent with the 'Serialise' instance for 'PerasCert' defined in Ouroboros.Consensus.Block.SupportsPeras + encodeNodeToNode ccfg version PerasCert{..} = + encodeListLen 2 + <> encodeNodeToNode ccfg version pcCertRound + <> encodeNodeToNode ccfg version pcCertBoostedBlock + decodeNodeToNode ccfg version = do + decodeListLenOf 2 + pcCertRound <- decodeNodeToNode ccfg version + pcCertBoostedBlock <- decodeNodeToNode ccfg version + pure $ PerasCert pcCertRound pcCertBoostedBlock + deriving newtype instance SerialiseNodeToClient blk (GenTxId blk) => SerialiseNodeToClient blk (WrapGenTxId blk) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/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) 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/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..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 @@ -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 @@ -326,9 +327,9 @@ addBlockAsync CDB{cdbTracer, cdbChainSelQueue} = addPerasCertAsync :: forall m blk. - (IOLike m, HasHeader blk) => + IOLike m => 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..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 @@ -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. @@ -606,10 +607,10 @@ 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 -> - 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..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 @@ -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)) @@ -34,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 () @@ -46,7 +55,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 8b8a33c342..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 @@ -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 @@ -78,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 } @@ -152,7 +154,7 @@ implAddCert :: , StandardHash blk ) => PerasCertDbEnv m blk -> - ValidatedPerasCert blk -> + WithArrivalTime (ValidatedPerasCert blk) -> m AddPerasCertResult implAddCert env cert = do traceWith pcdbTracer $ AddingPerasCert roundNo boostedPt @@ -169,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 @@ -219,9 +225,17 @@ 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, 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 @@ -235,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 = @@ -255,15 +271,22 @@ 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. - , pvcsCertsByTicket :: !(Map PerasCertTicketNo (ValidatedPerasCert blk)) + -- + -- INVARIANT: In sync with 'pvcsCerts'. + , pvcsCertsByTicket :: !(Map PerasCertTicketNo (WithArrivalTime (ValidatedPerasCert blk))) -- ^ The certificates by 'PerasCertTicketNo'. + -- + -- INVARIANT: In sync with 'pvcsCerts'. , pvcsLastTicketNo :: !PerasCertTicketNo -- ^ The most recent 'PerasCertTicketNo' (or 'zeroPerasCertTicketNo' -- otherwise). + , 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 @@ -276,6 +299,7 @@ initialPerasVolatileCertState = , pvcsWeightByPoint = emptyPerasWeightSnapshot , pvcsCertsByTicket = Map.empty , pvcsLastTicketNo = zeroPerasCertTicketNo + , pvcsLatestCertSeen = Nothing } (Fingerprint 0) @@ -300,7 +324,6 @@ invariantForPerasVolatileCertState pvcs = do <> " > " <> show pvcsLastTicketNo where - PerasVolatileCertState _ _ _ _keep = forgetFingerprint pvcs PerasVolatileCertState { pvcsCerts , pvcsWeightByPoint diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Orphans.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Orphans.hs index a623d0b9a9..71bc19a5f8 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Orphans.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Orphans.hs @@ -31,6 +31,7 @@ import NoThunks.Class , OnlyCheckWhnfNamed (..) , allNoThunks ) +import Ouroboros.Consensus.Node.NetworkProtocolVersion (NodeToNodeVersion) import Ouroboros.Network.Util.ShowProxy import System.FS.API (SomeHasFS) import System.FS.API.Types (FsPath, Handle) @@ -85,6 +86,9 @@ instance NoThunks a => NoThunks (MultiSet a) where showTypeOf _ = "MultiSet" wNoThunks ctxt = wNoThunks ctxt . MultiSet.toMap +-- NOTE: fixed in https://github.com/IntersectMBO/ouroboros-network/pull/5214 +instance NoThunks NodeToNodeVersion + {------------------------------------------------------------------------------- fs-api -------------------------------------------------------------------------------} diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/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/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/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/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/consensus-test/Main.hs b/ouroboros-consensus/test/consensus-test/Main.hs index beddd1f7d2..2775745a44 100644 --- a/ouroboros-consensus/test/consensus-test/Main.hs +++ b/ouroboros-consensus/test/consensus-test/Main.hs @@ -16,8 +16,12 @@ 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.Voting (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 @@ -37,6 +41,8 @@ tests = , Test.Consensus.MiniProtocol.BlockFetch.Client.tests , Test.Consensus.MiniProtocol.ChainSync.CSJ.tests , Test.Consensus.MiniProtocol.ChainSync.Client.tests + , Test.Consensus.MiniProtocol.ObjectDiffusion.Smoke.tests + , Test.Consensus.MiniProtocol.ObjectDiffusion.PerasCert.Smoke.tests , Test.Consensus.MiniProtocol.LocalStateQuery.Server.tests , testGroup "Mempool" @@ -44,9 +50,14 @@ 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 , testGroup "HardFork" [ testGroup diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/HardFork/History.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/HardFork/History.hs index 95491738d3..a2ad4d3bc8 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/HardFork/History.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/HardFork/History.hs @@ -2,6 +2,7 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -65,11 +66,11 @@ import Test.Util.QuickCheck -- General approach: -- -- * Generate a chain of events --- * Each event records its own 'RelativeTime', 'SlotNo', and 'EpochNo' +-- * Each event records its own 'RelativeTime', 'SlotNo', 'EpochNo', and 'PerasRoundNo' -- * We then construct a 'HF.Summary' from a /prefix/ of this chain -- * We then pick an arbitrary event from the (full) chain: -- a. If that event is on the prefix of the chain, or within the safe zone, we --- expect to be able to do any slot/epoch or slot/time conversion, and we +-- expect to be able to do any slot/epoch, slot/time or Peras round/slot conversion, and we -- can easily verify the result by comparing it to the values the 'Event' -- itself reports. -- b. If the event is outside of safe zone, we expect the conversion to throw @@ -96,6 +97,7 @@ tests = , testProperty "eventWallclockToSlot" eventWallclockToSlot , testProperty "epochInfoSlotToEpoch" epochInfoSlotToEpoch , testProperty "epochInfoEpochToSlot" epochInfoEpochToSlot + , testProperty "eventPerasRounNoToSlot" eventPerasRoundNoToSlot , testProperty "query vs expr" queryVsExprConsistency ] ] @@ -208,6 +210,20 @@ eventWallclockToSlot chain@ArbitraryChain{..} = diff :: NominalDiffTime diff = arbitraryDiffTime arbitraryParams +eventPerasRoundNoToSlot :: ArbitraryChain -> Property +eventPerasRoundNoToSlot chain@ArbitraryChain{..} = + testSkeleton chain (HF.perasRoundNoToSlot eventTimePerasRoundNo) $ + \case + HF.NoPerasEnabled -> property True + HF.PerasEnabled (startOfPerasRound, roundLength) -> + conjoin + [ eventTimeSlot + === (HF.addSlots eventTimeSlotInPerasRound startOfPerasRound) + , eventTimeSlotInPerasRound `lt` (unPerasRoundLength roundLength) + ] + where + EventTime{..} = eventTime arbitraryEvent + -- | Composing queries should be equivalent to composing expressions. -- -- This is a regression test. Each expression in a query should be evaluated in @@ -503,7 +519,13 @@ data EventTime = EventTime { eventTimeSlot :: SlotNo , eventTimeEpochNo :: EpochNo , eventTimeEpochSlot :: Word64 + -- ^ Relative slot withing the current epoch round, + -- needed to be able to advance the epoch number , eventTimeRelative :: RelativeTime + , eventTimePerasRoundNo :: PerasRoundNo + , eventTimeSlotInPerasRound :: Word64 + -- ^ Relative slot withing the current Peras round, + -- needed to be able to advance the round number } deriving Show @@ -514,6 +536,8 @@ initEventTime = , eventTimeEpochNo = EpochNo 0 , eventTimeEpochSlot = 0 , eventTimeRelative = RelativeTime 0 + , eventTimePerasRoundNo = PerasRoundNo 0 + , eventTimeSlotInPerasRound = 0 } -- | Next time slot @@ -526,6 +550,8 @@ stepEventTime HF.EraParams{..} EventTime{..} = , eventTimeRelative = addRelTime (getSlotLength eraSlotLength) $ eventTimeRelative + , eventTimePerasRoundNo = perasRoundNo' + , eventTimeSlotInPerasRound = slotInPerasRound' } where epoch' :: EpochNo @@ -535,6 +561,16 @@ stepEventTime HF.EraParams{..} EventTime{..} = then (succ eventTimeEpochNo, 0) else (eventTimeEpochNo, succ eventTimeEpochSlot) + perasRoundNo' :: PerasRoundNo + slotInPerasRound' :: Word64 + args@(perasRoundNo', slotInPerasRound') = + case eraPerasRoundLength of + HF.NoPerasEnabled -> args + HF.PerasEnabled (PerasRoundLength perasRoundLength) -> + if succ eventTimeSlotInPerasRound == perasRoundLength + then (succ eventTimePerasRoundNo, 0) + else (eventTimePerasRoundNo, succ eventTimeSlotInPerasRound) + {------------------------------------------------------------------------------- Chain model -----------------------------------------------------------------------------} diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/HardFork/Infra.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/HardFork/Infra.hs index 150ccda30e..4cecb8c968 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/HardFork/Infra.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/HardFork/Infra.hs @@ -35,7 +35,9 @@ import Data.SOP.Strict import Data.Word import Ouroboros.Consensus.Block import Ouroboros.Consensus.BlockchainTime +import Ouroboros.Consensus.HardFork.History (Bound (..)) import qualified Ouroboros.Consensus.HardFork.History as HF +import Ouroboros.Consensus.HardFork.History.EraParams (EraParams (..)) import Test.QuickCheck {------------------------------------------------------------------------------- @@ -121,6 +123,11 @@ genEraParams = do eraSlotLength <- slotLengthFromSec <$> choose (1, 5) eraSafeZone <- genSafeZone eraGenesisWin <- GenesisWindow <$> choose (1, 10) + -- we restrict Peras round length to divide the epoch size. + -- for testing purposes, we include Peras round length in every era. + eraPerasRoundLength <- + HF.PerasEnabled . PerasRoundLength + <$> choose (1, 10) `suchThat` (\x -> (unEpochSize eraEpochSize) `mod` x == 0) return HF.EraParams{..} where genSafeZone :: Gen HF.SafeZone @@ -154,8 +161,13 @@ genShape eras = HF.Shape <$> erasMapStateM genParams eras (EpochNo 0) genSummary :: Eras xs -> Gen (HF.Summary xs) genSummary is = - HF.Summary <$> erasUnfoldAtMost genEraSummary is HF.initBound + HF.Summary <$> erasUnfoldAtMost genEraSummary is initBoundWithPeras where + -- TODO(geo2a): revisit this hard-coding of enabling Peras when + -- we're further into the integration process + -- see https://github.com/tweag/cardano-peras/issues/112 + initBoundWithPeras = HF.initBound{boundPerasRound = HF.PerasEnabled . PerasRoundNo $ 0} + genEraSummary :: Era -> HF.Bound -> Gen (HF.EraSummary, HF.EraEnd) genEraSummary _era lo = do params <- genEraParams diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/HardFork/Summary.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/HardFork/Summary.hs index c1bc38c9f6..361e5d0966 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/HardFork/Summary.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/HardFork/Summary.hs @@ -1,5 +1,6 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE RankNTypes #-} @@ -19,6 +20,7 @@ -- * Converting slot to an epoch and then back to a slot should be an identity -- (modulo the time spent in that epoch). -- * Converting an epoch to a slot and then back should be an identity. +-- * Converting a Peras round number to a slot and then back should be an identity. module Test.Consensus.HardFork.Summary (tests) where import Data.Time @@ -50,6 +52,7 @@ tests = , testProperty "roundtripSlotWallclock" roundtripSlotWallclock , testProperty "roundtripSlotEpoch" roundtripSlotEpoch , testProperty "roundtripEpochSlot" roundtripEpochSlot + , testProperty "roundtripPerasRoundSlot" roundtripPerasRoundSlot , testProperty "reportsPastHorizon" reportsPastHorizon ] ] @@ -131,6 +134,28 @@ roundtripEpochSlot s@ArbitrarySummary{beforeHorizonEpoch = epoch} = , inEpoch + slotsLeft === unEpochSize epochSize ] +-- | Test that conversion between Peras rounds and slots roundtips. +-- Additionally, test that the relative slot in round and remaining +-- slots in round are withing the round length. +roundtripPerasRoundSlot :: ArbitrarySummary -> Property +roundtripPerasRoundSlot s@ArbitrarySummary{beforeHorizonPerasRoundNo} = + case beforeHorizonPerasRoundNo of + HF.NoPerasEnabled -> property True + HF.PerasEnabled perasRoundNo -> + noPastHorizonException s $ + HF.perasRoundNoToSlot perasRoundNo >>= \case + HF.NoPerasEnabled -> pure $ property True + HF.PerasEnabled (slot, PerasRoundLength perasRoundLength) -> do + HF.slotToPerasRoundNo slot >>= \case + HF.NoPerasEnabled -> pure $ property True + HF.PerasEnabled (perasRoundNo', slotInRound, remainingSlotsInRound) -> + pure $ + conjoin + [ perasRoundNo' === perasRoundNo + , slotInRound `lt` perasRoundLength + , remainingSlotsInRound `le` perasRoundLength + ] + reportsPastHorizon :: ArbitrarySummary -> Property reportsPastHorizon s@ArbitrarySummary{..} = conjoin @@ -146,6 +171,9 @@ reportsPastHorizon s@ArbitrarySummary{..} = , case mPastHorizonEpoch of Just x -> isPastHorizonException s $ HF.epochToSlot x Nothing -> property True + , case mPastHorizonPerasRoundNo of + Just (HF.PerasEnabled x) -> isPastHorizonException s $ HF.perasRoundNoToSlot x + _ -> property True ] {------------------------------------------------------------------------------- @@ -160,9 +188,13 @@ data ArbitrarySummary = forall xs. ArbitrarySummary , beforeHorizonTime :: RelativeTime , beforeHorizonSlot :: SlotNo , beforeHorizonEpoch :: EpochNo + , beforeHorizonPerasRoundNo :: HF.PerasEnabled PerasRoundNo + -- ^ 'PerasRoundNo' is not optional here, + -- i.e. we do not model non-Peras eras in the time conversion tests , mPastHorizonTime :: Maybe RelativeTime , mPastHorizonSlot :: Maybe SlotNo , mPastHorizonEpoch :: Maybe EpochNo + , mPastHorizonPerasRoundNo :: Maybe (HF.PerasEnabled PerasRoundNo) } deriving instance Show ArbitrarySummary @@ -181,10 +213,12 @@ instance Arbitrary ArbitrarySummary where beforeHorizonSlots <- choose (0, 100_000_000) beforeHorizonEpochs <- choose (0, 1_000_000) beforeHorizonSeconds <- choose (0, 1_000_000_000) + beforeHorizonPerasRounds <- HF.PerasEnabled <$> choose (0, 1_000) let beforeHorizonSlot :: SlotNo beforeHorizonEpoch :: EpochNo beforeHorizonTime :: RelativeTime + beforeHorizonPerasRoundNo :: HF.PerasEnabled PerasRoundNo beforeHorizonSlot = HF.addSlots @@ -198,19 +232,25 @@ instance Arbitrary ArbitrarySummary where addRelTime (realToFrac (beforeHorizonSeconds :: Double)) (HF.boundTime summaryStart) - + beforeHorizonPerasRoundNo = + HF.addPerasRounds + <$> beforeHorizonPerasRounds + <*> HF.boundPerasRound summaryStart return ArbitrarySummary { arbitrarySummary = summary , beforeHorizonTime , beforeHorizonSlot , beforeHorizonEpoch + , beforeHorizonPerasRoundNo , mPastHorizonTime = Nothing , mPastHorizonSlot = Nothing , mPastHorizonEpoch = Nothing + , mPastHorizonPerasRoundNo = Nothing } HF.EraEnd summaryEnd -> do let summarySlots, summaryEpochs :: Word64 + summaryPerasRounds :: HF.PerasEnabled Word64 summarySlots = HF.countSlots (HF.boundSlot summaryEnd) @@ -219,7 +259,10 @@ instance Arbitrary ArbitrarySummary where HF.countEpochs (HF.boundEpoch summaryEnd) (HF.boundEpoch summaryStart) - + summaryPerasRounds = + HF.countPerasRounds + <$> HF.boundPerasRound summaryEnd + <*> HF.boundPerasRound summaryStart summaryTimeSpan :: NominalDiffTime summaryTimeSpan = diffRelTime @@ -236,7 +279,9 @@ instance Arbitrary ArbitrarySummary where beforeHorizonSeconds <- choose (0, summaryTimeSpanSeconds) `suchThat` \x -> x /= summaryTimeSpanSeconds - + beforeHorizonPerasRounds <- case summaryPerasRounds of + HF.NoPerasEnabled -> pure HF.NoPerasEnabled + HF.PerasEnabled rounds -> HF.PerasEnabled <$> choose (0, rounds - 1) let beforeHorizonSlot :: SlotNo beforeHorizonEpoch :: EpochNo beforeHorizonTime :: RelativeTime @@ -253,16 +298,22 @@ instance Arbitrary ArbitrarySummary where addRelTime (realToFrac beforeHorizonSeconds) (HF.boundTime summaryStart) + beforeHorizonPerasRoundNo = + HF.addPerasRounds + <$> beforeHorizonPerasRounds + <*> HF.boundPerasRound summaryStart -- Pick arbitrary values past the horizon pastHorizonSlots :: Word64 <- choose (0, 10) pastHorizonEpochs :: Word64 <- choose (0, 10) pastHorizonSeconds :: Double <- choose (0, 10) + pastHorizonPerasRounds :: HF.PerasEnabled Word64 <- HF.PerasEnabled <$> choose (0, 10) let pastHorizonSlot :: SlotNo pastHorizonEpoch :: EpochNo pastHorizonTime :: RelativeTime + pastHorizonPerasRoundNo :: HF.PerasEnabled PerasRoundNo pastHorizonSlot = HF.addSlots @@ -276,16 +327,21 @@ instance Arbitrary ArbitrarySummary where addRelTime (realToFrac pastHorizonSeconds) (HF.boundTime summaryEnd) - + pastHorizonPerasRoundNo = + HF.addPerasRounds + <$> pastHorizonPerasRounds + <*> HF.boundPerasRound summaryEnd return ArbitrarySummary { arbitrarySummary = summary , beforeHorizonTime , beforeHorizonSlot , beforeHorizonEpoch + , beforeHorizonPerasRoundNo , mPastHorizonTime = Just pastHorizonTime , mPastHorizonSlot = Just pastHorizonSlot , mPastHorizonEpoch = Just pastHorizonEpoch + , mPastHorizonPerasRoundNo = Just pastHorizonPerasRoundNo } shrink summary@ArbitrarySummary{..} = diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasCert/Smoke.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasCert/Smoke.hs new file mode 100644 index 0000000000..8779ea0947 --- /dev/null +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasCert/Smoke.hs @@ -0,0 +1,161 @@ +{-# 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 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 (..) + , WithArrivalTime (..) + , addArrivalTime + , systemTimeCurrent + ) +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.PerasCert +import Ouroboros.Consensus.Storage.PerasCertDB.API + ( AddPerasCertResult (..) + , PerasCertDB + , PerasCertTicketNo + ) +import qualified Ouroboros.Consensus.Storage.PerasCertDB.API as PerasCertDB +import qualified Ouroboros.Consensus.Storage.PerasCertDB.Impl as PerasCertDB +import Ouroboros.Consensus.Util.IOLike (IOLike, atomically, newTVarIO, stateTVar, throwIO) +import Ouroboros.Network.Block (Point (..), SlotNo (SlotNo), StandardHash) +import Ouroboros.Network.Point (Block (Block), WithOrigin (..)) +import Ouroboros.Network.Protocol.ObjectDiffusion.Codec +import Ouroboros.Network.Protocol.ObjectDiffusion.Inbound + ( objectDiffusionInboundPeerPipelined + ) +import Ouroboros.Network.Protocol.ObjectDiffusion.Outbound (objectDiffusionOutboundPeer) +import Test.Consensus.MiniProtocol.ObjectDiffusion.Smoke + ( ListWithUniqueIds (..) + , ProtocolConstants + , WithId + , getId + , prop_smoke_object_diffusion + ) +import Test.QuickCheck +import Test.Tasty +import Test.Tasty.QuickCheck (testProperty) +import Test.Util.TestBlock + +tests :: TestTree +tests = + testGroup + "ObjectDiffusion.PerasCert.Smoke" + [ testProperty "PerasCertDiffusion smoke test" prop_smoke + ] + +perasTestCfg :: PerasCfg TestBlock +perasTestCfg = makePerasCfg Nothing + +instance Arbitrary (Point TestBlock) where + arbitrary = + -- Sometimes pick the genesis point + frequency + [ (1, pure $ Point Origin) + , + ( 4 + , do + slotNo <- SlotNo <$> arbitrary + hash <- TestHash . NE.fromList . getNonEmpty <$> arbitrary + pure $ Point (At (Block slotNo hash)) + ) + ] + +instance Arbitrary (Point blk) => Arbitrary (PerasCert blk) where + arbitrary = do + pcCertRound <- PerasRoundNo <$> arbitrary + pcCertBoostedBlock <- arbitrary + pure $ PerasCert{pcCertRound, pcCertBoostedBlock} + +instance WithId (PerasCert blk) PerasRoundNo where + getId = pcCertRound + +mockSystemTime :: IOLike m => m (SystemTime m) +mockSystemTime = do + varTime <- newTVarIO 0 + return $ + SystemTime + { systemTimeCurrent = + RelativeTime <$> atomically (stateTVar varTime (\t -> (t, t + 1))) + , systemTimeWait = + pure () + } + +newCertDB :: + (IOLike m, StandardHash blk) => + PerasCfg blk -> + SystemTime m -> + [PerasCert blk] -> + m (PerasCertDB m blk) +newCertDB perasCfg systemTime certs = do + db <- PerasCertDB.openDB (PerasCertDB.PerasCertDbArgs @Identity nullTracer) + mapM_ + ( \cert -> do + let validatedCert = + ValidatedPerasCert + { vpcCert = cert + , vpcCertBoost = perasCfgWeightBoost perasCfg + } + result <- PerasCertDB.addCert db =<< addArrivalTime systemTime validatedCert + case result of + AddedPerasCertToDB -> pure () + PerasCertAlreadyInDB -> throwIO (userError "Expected AddedPerasCertToDB, but cert was already in DB") + ) + certs + pure db + +prop_smoke :: ProtocolConstants -> ListWithUniqueIds (PerasCert TestBlock) PerasRoundNo -> Property +prop_smoke protocolConstants (ListWithUniqueIds certs) = + prop_smoke_object_diffusion protocolConstants certs runOutboundPeer runInboundPeer mkPoolInterfaces + where + runOutboundPeer outbound outboundChannel tracer = + runPeer + ((\x -> "Outbound (Client): " ++ show x) `contramap` tracer) + codecObjectDiffusionId + outboundChannel + (objectDiffusionOutboundPeer outbound) + >> pure () + runInboundPeer inbound inboundChannel tracer = + runPipelinedPeer + ((\x -> "Inbound (Server): " ++ show x) `contramap` tracer) + codecObjectDiffusionId + inboundChannel + (objectDiffusionInboundPeerPipelined inbound) + >> pure () + mkPoolInterfaces :: + forall m. + IOLike m => + m + ( ObjectPoolReader PerasRoundNo (PerasCert TestBlock) PerasCertTicketNo m + , ObjectPoolWriter PerasRoundNo (PerasCert TestBlock) m + , m [PerasCert TestBlock] + ) + mkPoolInterfaces = do + systemTime <- mockSystemTime + outboundPool <- newCertDB perasTestCfg systemTime certs + inboundPool <- newCertDB perasTestCfg systemTime [] + + let outboundPoolReader = makePerasCertPoolReaderFromCertDB outboundPool + inboundPoolWriter = makePerasCertPoolWriterFromCertDB systemTime inboundPool + getAllInboundPoolContent = do + snap <- atomically $ PerasCertDB.getCertSnapshot inboundPool + let rawContent = + Map.toAscList $ + PerasCertDB.getCertsAfter snap (PerasCertDB.zeroPerasCertTicketNo) + pure $ vpcCert . forgetArrivalTime . 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 new file mode 100644 index 0000000000..3553b8cc68 --- /dev/null +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/Smoke.hs @@ -0,0 +1,312 @@ +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Smoke tests for the object diffusion protocol. This uses a trivial object +-- pool and checks that a few objects can indeed be transferred from the +-- outbound to the inbound peer. +module Test.Consensus.MiniProtocol.ObjectDiffusion.Smoke + ( tests + , WithId (..) + , ListWithUniqueIds (..) + , ProtocolConstants + , prop_smoke_object_diffusion + ) where + +import Control.Monad.IOSim (runSimStrictShutdown) +import Control.ResourceRegistry (forkLinkedThread, waitAnyThread, withRegistry) +import Control.Tracer (Tracer, nullTracer, traceWith) +import Data.Containers.ListUtils (nubOrdOn) +import Data.Functor.Contravariant (contramap) +import Network.TypedProtocol.Channel (Channel, createConnectedChannels) +import Network.TypedProtocol.Codec (AnyMessage) +import Network.TypedProtocol.Driver.Simple (runPeer, runPipelinedPeer) +import NoThunks.Class (NoThunks) +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.V1 + ( objectDiffusionInbound + ) +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.V1.State + ( ObjectDiffusionInboundStateView (..) + ) +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API + ( ObjectPoolReader (..) + , ObjectPoolWriter (..) + ) +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Outbound (objectDiffusionOutbound) +import qualified Ouroboros.Consensus.MiniProtocol.Util.Idling as Idling +import Ouroboros.Consensus.Util.IOLike + ( IOLike + , MonadDelay (..) + , MonadSTM (..) + , StrictTVar + , modifyTVar + , readTVar + , uncheckedNewTVarM + , writeTVar + ) +import Ouroboros.Network.ControlMessage (ControlMessage (..)) +import Ouroboros.Network.NodeToNode.Version (NodeToNodeVersion (..)) +import Ouroboros.Network.Protocol.ObjectDiffusion.Codec (codecObjectDiffusionId) +import Ouroboros.Network.Protocol.ObjectDiffusion.Inbound + ( ObjectDiffusionInboundPipelined + , objectDiffusionInboundPeerPipelined + ) +import Ouroboros.Network.Protocol.ObjectDiffusion.Outbound + ( ObjectDiffusionOutbound + , objectDiffusionOutboundPeer + ) +import Ouroboros.Network.Protocol.ObjectDiffusion.Type + ( NumObjectIdsReq (..) + , NumObjectsOutstanding (..) + , NumObjectsReq (..) + , ObjectDiffusion + ) +import Test.QuickCheck +import Test.Tasty +import Test.Tasty.QuickCheck +import Test.Util.Orphans.Arbitrary () +import Test.Util.Orphans.IOLike () + +tests :: TestTree +tests = + testGroup + "ObjectDiffusion.Smoke" + [ testProperty + "ObjectDiffusion smoke test with mock objects" + prop_smoke + ] + +{------------------------------------------------------------------------------- + Provides a way to generate lists composed of objects with no duplicate ids, + with an Arbitrary instance +-------------------------------------------------------------------------------} + +class WithId a idTy | a -> idTy where + getId :: a -> idTy + +newtype ListWithUniqueIds a idTy = ListWithUniqueIds [a] + deriving (Eq, Show, Ord) + +instance (Ord idTy, WithId a idTy, Arbitrary a) => Arbitrary (ListWithUniqueIds a idTy) where + arbitrary = ListWithUniqueIds . nubOrdOn getId <$> arbitrary + +instance WithId SmokeObject SmokeObjectId where getId = getSmokeObjectId + +{------------------------------------------------------------------------------- + Mock objectPools +-------------------------------------------------------------------------------} + +newtype SmokeObjectId = SmokeObjectId Int + deriving (Eq, Ord, Show, NoThunks, Arbitrary) + +newtype SmokeObject = SmokeObject {getSmokeObjectId :: SmokeObjectId} + deriving (Eq, Ord, Show, NoThunks, Arbitrary) + +newtype SmokeObjectPool m = SmokeObjectPool (StrictTVar m [SmokeObject]) + +newObjectPool :: MonadSTM m => [SmokeObject] -> m (SmokeObjectPool m) +newObjectPool initialPoolContent = SmokeObjectPool <$> uncheckedNewTVarM initialPoolContent + +makeObjectPoolReader :: + MonadSTM m => SmokeObjectPool m -> ObjectPoolReader SmokeObjectId SmokeObject Int m +makeObjectPoolReader (SmokeObjectPool poolContentTvar) = + ObjectPoolReader + { oprObjectId = getSmokeObjectId + , oprObjectsAfter = \minTicketNo limit -> do + poolContent <- readTVar poolContentTvar + pure $ + take (fromIntegral limit) $ + drop (minTicketNo + 1) $ + ( (\(ticketNo, smokeObject) -> (ticketNo, getSmokeObjectId smokeObject, pure smokeObject)) + <$> zip [(0 :: Int) ..] poolContent + ) + , oprZeroTicketNo = -1 -- objectPoolObjectIdsAfter uses strict comparison, and first ticketNo is 0. + } + +makeObjectPoolWriter :: + MonadSTM m => SmokeObjectPool m -> ObjectPoolWriter SmokeObjectId SmokeObject m +makeObjectPoolWriter (SmokeObjectPool poolContentTvar) = + ObjectPoolWriter + { opwObjectId = getSmokeObjectId + , opwAddObjects = \objects -> do + atomically $ modifyTVar poolContentTvar (++ objects) + return () + , opwHasObject = do + poolContent <- readTVar poolContentTvar + pure $ \objectId -> any (\obj -> getSmokeObjectId obj == objectId) poolContent + } + +mkMockPoolInterfaces :: + MonadSTM m => + [SmokeObject] -> + m + ( ObjectPoolReader SmokeObjectId SmokeObject Int m + , ObjectPoolWriter SmokeObjectId SmokeObject m + , m [SmokeObject] + ) +mkMockPoolInterfaces objects = do + outboundPool <- newObjectPool objects + inboundPool@(SmokeObjectPool tvar) <- newObjectPool [] + + let outboundPoolReader = makeObjectPoolReader outboundPool + inboundPoolWriter = makeObjectPoolWriter inboundPool + + return (outboundPoolReader, inboundPoolWriter, atomically $ readTVar tvar) + +{------------------------------------------------------------------------------- + Main properties +-------------------------------------------------------------------------------} + +-- Protocol constants + +newtype ProtocolConstants + = ProtocolConstants (NumObjectsOutstanding, NumObjectIdsReq, NumObjectsReq) + deriving Show + +instance Arbitrary ProtocolConstants where + arbitrary = do + maxFifoSize <- choose (5, 20) + maxIdsToReq <- choose (3, maxFifoSize) + maxObjectsToReq <- choose (2, maxIdsToReq) + pure $ + ProtocolConstants + ( NumObjectsOutstanding maxFifoSize + , NumObjectIdsReq maxIdsToReq + , NumObjectsReq maxObjectsToReq + ) + +nodeToNodeVersion :: NodeToNodeVersion +nodeToNodeVersion = NodeToNodeV_14 + +prop_smoke :: ProtocolConstants -> ListWithUniqueIds SmokeObject idTy -> Property +prop_smoke protocolConstants (ListWithUniqueIds objects) = + prop_smoke_object_diffusion + protocolConstants + objects + runOutboundPeer + runInboundPeer + (mkMockPoolInterfaces objects) + where + runOutboundPeer outbound outboundChannel tracer = + runPeer + ((\x -> "Outbound (Server): " ++ show x) `contramap` tracer) + codecObjectDiffusionId + outboundChannel + (objectDiffusionOutboundPeer outbound) + >> pure () + + runInboundPeer inbound inboundChannel tracer = + runPipelinedPeer + ((\x -> "Inbound (Client): " ++ show x) `contramap` tracer) + codecObjectDiffusionId + inboundChannel + (objectDiffusionInboundPeerPipelined inbound) + >> pure () + +--- The core logic of the smoke test is shared between the generic smoke tests for ObjectDiffusion, and the ones specialised to PerasCert/PerasVote diffusion +prop_smoke_object_diffusion :: + ( Eq object + , Show object + , Ord objectId + , NoThunks objectId + , Show objectId + , NoThunks object + , Ord ticketNo + ) => + ProtocolConstants -> + [object] -> + ( forall m. + IOLike m => + ObjectDiffusionOutbound objectId object m () -> + Channel m (AnyMessage (ObjectDiffusion objectId object)) -> + (Tracer m String) -> + m () + ) -> + ( forall m. + IOLike m => + ObjectDiffusionInboundPipelined objectId object m () -> + (Channel m (AnyMessage (ObjectDiffusion objectId object))) -> + (Tracer m String) -> + m () + ) -> + ( forall m. + IOLike m => + m + ( ObjectPoolReader objectId object ticketNo m + , ObjectPoolWriter objectId object m + , m [object] + ) + ) -> + Property +prop_smoke_object_diffusion + (ProtocolConstants (maxFifoSize, maxIdsToReq, maxObjectsToReq)) + objects + runOutboundPeer + runInboundPeer + mkPoolInterfaces = + let + simulationResult = runSimStrictShutdown $ do + let tracer = nullTracer + + traceWith tracer "========== [ Starting ObjectDiffusion smoke test ] ==========" + traceWith tracer (show objects) + + (outboundPoolReader, inboundPoolWriter, getAllInboundPoolContent) <- mkPoolInterfaces + controlMessage <- uncheckedNewTVarM Continue + + let + inboundState = + ObjectDiffusionInboundStateView + { odisvIdling = Idling.noIdling + } + + inbound = + objectDiffusionInbound + tracer + ( maxFifoSize + , maxIdsToReq + , maxObjectsToReq + ) + inboundPoolWriter + nodeToNodeVersion + (readTVar controlMessage) + inboundState + + outbound = + objectDiffusionOutbound + tracer + maxFifoSize + outboundPoolReader + nodeToNodeVersion + + withRegistry $ \reg -> do + (outboundChannel, inboundChannel) <- createConnectedChannels + outboundThread <- + forkLinkedThread reg "ObjectDiffusion Outbound peer thread" $ + runOutboundPeer outbound outboundChannel tracer + inboundThread <- + forkLinkedThread reg "ObjectDiffusion Inbound peer thread" $ + runInboundPeer inbound inboundChannel tracer + controlMessageThread <- forkLinkedThread reg "ObjectDiffusion Control thread" $ do + threadDelay 1000 -- give a head start to the other threads + atomically $ writeTVar controlMessage Terminate + threadDelay 1000 -- wait for the other threads to finish + waitAnyThread [outboundThread, inboundThread, controlMessageThread] + + traceWith tracer "========== [ ObjectDiffusion smoke test finished ] ==========" + poolContent <- getAllInboundPoolContent + + traceWith tracer "inboundPoolContent:" + traceWith tracer (show poolContent) + traceWith tracer "========== ======================================= ==========" + pure poolContent + in + case simulationResult of + Right inboundPoolContent -> inboundPoolContent === objects + Left msg -> counterexample (show msg) $ property False diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/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 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 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 e3a787a6c6..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 @@ -73,7 +73,7 @@ module Test.Ouroboros.Storage.ChainDB.StateMachine , tests ) where -import Cardano.Ledger.BaseTypes (knownNonZeroBounded) +import Cardano.Ledger.BaseTypes (unNonZero, unsafeNonZero) import Codec.Serialise (Serialise) import Control.Monad (replicateM, void) import Control.ResourceRegistry @@ -89,6 +89,7 @@ import Data.Functor.Classes (Eq1, Show1) import Data.Functor.Identity (Identity) import Data.List (sortOn) import qualified Data.List.NonEmpty as NE +import Data.Map (Map) import qualified Data.Map.Strict as Map import Data.Maybe (fromMaybe) import Data.Ord (Down (..)) @@ -96,11 +97,17 @@ import Data.Proxy import Data.TreeDiff import Data.Typeable import Data.Void (Void) -import Data.Word (Word16) +import Data.Word (Word16, Word64) import GHC.Generics (Generic) import qualified Generics.SOP as SOP import NoThunks.Class (AllowThunk (..)) import Ouroboros.Consensus.Block +import Ouroboros.Consensus.BlockchainTime.WallClock.Types + ( RelativeTime (..) + , SystemTime (..) + , WithArrivalTime + , addArrivalTime + ) import Ouroboros.Consensus.Config import Ouroboros.Consensus.HardFork.Abstract import Ouroboros.Consensus.HardFork.Combinator.Abstract @@ -150,6 +157,7 @@ import qualified Test.Ouroboros.Storage.ChainDB.Model as Model import Test.Ouroboros.Storage.Orphans () import Test.Ouroboros.Storage.TestBlock import Test.QuickCheck hiding (forAll) +import qualified Test.QuickCheck as QC import qualified Test.QuickCheck.Monadic as QC import Test.StateMachine import qualified Test.StateMachine.Labelling as C @@ -176,10 +184,18 @@ import Test.Util.WithEq Abstract model -------------------------------------------------------------------------------} +-- | A randomly generated value that gets persisted between steps, so that we +-- can carry generator state forward between commands. See 'GenState' below for +-- more details. +newtype Persistent a = Persistent {unPersistent :: a} + deriving (Eq, Show, Functor) + -- | Commands data Cmd blk it flr - = AddBlock blk - | 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 (WithArrivalTime (ValidatedPerasCert blk)) (Persistent [blk]) | GetCurrentChain | GetTipBlock | GetTipHeader @@ -405,8 +421,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 +627,7 @@ instance Eq IsValidResult where (Just _, Nothing) -> False {------------------------------------------------------------------------------- - Instantiating the semantics + Responses -------------------------------------------------------------------------------} -- | Responses are either successful termination or an error. @@ -628,6 +644,26 @@ instance (TestConstraints blk, Eq it, Eq flr) => Eq (Resp blk it flr) where Resp (Right a) == Resp (Right a') = a == a' _ == _ = False +{------------------------------------------------------------------------------- + Bitraversable instances +-------------------------------------------------------------------------------} + +TH.deriveBifunctor ''Cmd +TH.deriveBifoldable ''Cmd +TH.deriveBitraversable ''Cmd + +TH.deriveBifunctor ''Success +TH.deriveBifoldable ''Success +TH.deriveBitraversable ''Success + +TH.deriveBifunctor ''Resp +TH.deriveBifoldable ''Resp +TH.deriveBitraversable ''Resp + +{------------------------------------------------------------------------------- + Instantiating the semantics +-------------------------------------------------------------------------------} + type DBModel blk = Model.Model blk -- We can't reuse 'run' because the 'ChainDB' API uses 'STM'. Instead, we call @@ -640,8 +676,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 +764,6 @@ iters = bifoldMap (: []) (const []) flrs :: Bitraversable t => t it flr -> [flr] flrs = bifoldMap (const []) (: []) -{------------------------------------------------------------------------------- - Bitraversable instances --------------------------------------------------------------------------------} - -TH.deriveBifunctor ''Cmd -TH.deriveBifoldable ''Cmd -TH.deriveBitraversable ''Cmd - -TH.deriveBifunctor ''Success -TH.deriveBifoldable ''Success -TH.deriveBitraversable ''Success - -TH.deriveBifunctor ''Resp -TH.deriveBifoldable ''Resp -TH.deriveBitraversable ''Resp - {------------------------------------------------------------------------------- Model -------------------------------------------------------------------------------} @@ -760,12 +780,69 @@ type FollowerRef blk m r = Reference (Opaque (TestFollower m blk)) r -- | Mapping between iterator references and mocked followers type KnownFollowers blk m r = RefEnv (Opaque (TestFollower m blk)) FollowerId r +-- | Generator state to be carried forward between commands +-- +-- NOTE: some of our generators benefit from carrying state between commands. +-- However, 'quickcheck-state-machine' does not provide much support for this, +-- so we manually carry it around as part of the evolving SUT's model--even if +-- it's technically not part of the actual model we are trying to test against. +-- +-- TODO: Explore if this can be improved by tweaking the API of +-- 'quickcheck-state-machine' to allow for the same functionality to exist +-- under the hood. +data GenState blk + = GenState + { seenBlocks :: Map (HeaderHash blk) blk + -- ^ Blocks that have been generated but not yet added to the ChainDB, e.g., + -- gap blocks generated by 'genBlockAfterGap', or boosted blocks generated by + -- 'genAddPerasCert'. We don't want to discard these because they can be used + -- to fill gaps between existing blocks added via 'AddBlock', simulating + -- blocks and certificates arriving out of order. + } + deriving Generic + +deriving instance + ( ToExpr blk + , ToExpr (HeaderHash blk) + ) => + ToExpr (GenState blk) + +deriving instance (Show blk, Show (HeaderHash blk)) => Show (GenState blk) + +emptyGenState :: GenState blk +emptyGenState = + GenState + { seenBlocks = Map.empty + } + +-- | Use the extra state stored in a generated command to update a model's +-- 'GenState' accordingly. +updateGenState :: + HasHeader blk => + At Cmd blk m r -> + GenState blk -> + GenState blk +updateGenState cmd gs = + case unAt cmd of + AddBlock _ (Persistent blks) -> saveSeenBlocks blks gs + AddPerasCert _ (Persistent blks) -> saveSeenBlocks blks gs + _ -> gs + where + saveSeenBlocks blks gs' = + gs' + { seenBlocks = + Map.union + (Map.fromList [(blockHash blk, blk) | blk <- blks]) + (seenBlocks gs') + } + -- | Execution model data Model blk m r = Model { dbModel :: DBModel blk , knownIters :: KnownIters blk m r , knownFollowers :: KnownFollowers blk m r , modelConfig :: Opaque (TopLevelConfig blk) + , genState :: GenState blk } deriving Generic @@ -784,6 +861,7 @@ initModel loe cfg initLedger = , knownIters = RE.empty , knownFollowers = RE.empty , modelConfig = QSM.Opaque cfg + , genState = emptyGenState } -- | Key property of the model is that we can go from real to mock responses @@ -871,6 +949,7 @@ lockstep model@Model{..} cmd (At resp) = } where (mockResp, dbModel') = step model cmd + genState' = updateGenState cmd genState newIters = RE.fromList $ zip (iters resp) (iters mockResp) newFollowers = RE.fromList $ zip (flrs resp) (flrs mockResp) model' = case unAt cmd of @@ -879,18 +958,21 @@ lockstep model@Model{..} cmd (At resp) = Close -> model { dbModel = dbModel' + , genState = genState' , knownIters = RE.empty , knownFollowers = RE.empty } WipeVolatileDB -> model { dbModel = dbModel' + , genState = genState' , knownIters = RE.empty , knownFollowers = RE.empty } _ -> model { dbModel = dbModel' + , genState = genState' , knownIters = knownIters `RE.union` newIters , knownFollowers = knownFollowers `RE.union` newFollowers } @@ -899,25 +981,23 @@ lockstep model@Model{..} cmd (At resp) = Generator -------------------------------------------------------------------------------} -type BlockGen blk m = Model blk m Symbolic -> Gen blk - -- | Generate a 'Cmd' generator :: forall blk m. TestConstraints blk => LoE () -> - BlockGen blk m -> + (Model blk m Symbolic -> Gen (blk, Persistent [blk])) -> Model blk m Symbolic -> Gen (At Cmd blk m Symbolic) generator loe genBlock m@Model{..} = At <$> frequency - [ (30, genAddBlock) + [ (100, genAddBlock) , let freq = case loe of - LoEDisabled -> 10 + LoEDisabled -> 100 -- 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 +1053,7 @@ generator loe genBlock m@Model{..} = followers = RE.keys knownFollowers genRandomPoint :: Gen (RealPoint blk) - genRandomPoint = blockRealPoint <$> genBlock m + genRandomPoint = blockRealPoint . fst <$> genBlock m blocksInDB :: Map.Map (HeaderHash blk) blk blocksInDB = Model.blocks dbModel @@ -994,7 +1074,7 @@ generator loe genBlock m@Model{..} = anchor <- elements $ AF.AnchorGenesis : fmap AF.anchorFromBlock immutableBlocks - blk <- genBlock m + (blk, _) <- genBlock m tip <- frequency [ (1, pure $ Chain.headHash immutableChain) @@ -1016,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 @@ -1033,6 +1118,7 @@ generator loe genBlock m@Model{..} = genGetIsValid :: Gen (Cmd blk it flr) genGetIsValid = GetIsValid <$> genRealPoint + genGetBlockComponent :: Gen (Cmd blk it flr) genGetBlockComponent = do pt <- genRealPoint @@ -1041,25 +1127,44 @@ 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) - pure $ - ValidatedPerasCert - { vpcCert = - PerasCert - { pcCertRound = roundNo - , pcCertBoostedBlock = blockPoint blk - } - , vpcCertBoost = boostPerCert - } + -- Generate an almost-always-valid boost, i.e., below the maximum rollback + let k = unPerasWeight (maxRollbackWeight secParam) + boost <- + PerasWeight + <$> frequency + [ (10, choose (1, k - 1)) + , (1, choose (k, k + 1)) + ] + -- Put together the certificate and attach a random arrival time + systemTime <- genSystemTime + validatedCert <- + addArrivalTime systemTime $ + ValidatedPerasCert + { vpcCert = + PerasCert + { pcCertRound = roundNo + , pcCertBoostedBlock = blockPoint blk + } + , vpcCertBoost = boost + } + + -- Include the boosted block itself in the persisted seenBlocks + let seenBlks = fmap (blk :) gapBlks + + pure $ AddPerasCert validatedCert seenBlks genBounds :: Gen (StreamFrom blk, StreamTo blk) genBounds = @@ -1302,7 +1407,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 @@ -1486,21 +1591,34 @@ 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 - modelSupportsEBBs = ImmutableDB.chunkInfoSupportsEBBs chunkInfo - canContainEBB = const modelSupportsEBBs -- TODO: we could be more precise - empty :: Bool - empty = Map.null blocksInChainDB + noBlocksInChainDB = Map.null blocksInChainDB + + savedGapBlocks = seenBlocks genState + noSavedGapBlocks = Map.null savedGapBlocks + withoutGapBlocks = fmap (,Persistent []) + + 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 isValid <- @@ -1533,20 +1651,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 @@ -1607,40 +1733,51 @@ 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 + {------------------------------------------------------------------------------- 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. @@ -1648,15 +1785,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) -> @@ -1719,26 +1856,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 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..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,13 +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, forgetArrivalTime) import Ouroboros.Consensus.Peras.Weight ( PerasWeightSnapshot , mkPerasWeightSnapshot ) +import Ouroboros.Consensus.Util (safeMaximumOn) data Model blk = Model - { certs :: Set (ValidatedPerasCert blk) + { certs :: Set (WithArrivalTime (ValidatedPerasCert blk)) + , latestCertSeen :: Maybe (WithArrivalTime (ValidatedPerasCert blk)) , open :: Bool } deriving Generic @@ -33,25 +37,27 @@ 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 -> 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} + | otherwise = model{certs = certs', latestCertSeen = safeMaximumOn roundNo (Set.toList certs')} + where + certs' = Set.insert cert certs + roundNo = getPerasCertRound . forgetArrivalTime 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) @@ -65,7 +71,12 @@ getWeightSnapshot Model{certs} = | cert <- Set.toList certs ] -garbageCollect :: StandardHash blk => SlotNo -> Model blk -> Model blk +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} where 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..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 @@ -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 @@ -45,6 +55,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 @@ -57,8 +70,9 @@ 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) + GetLatestCertSeen :: Action Model (Maybe (WithArrivalTime (ValidatedPerasCert TestBlock))) GarbageCollect :: SlotNo -> Action Model () arbitraryAction _ (Model model) @@ -67,23 +81,30 @@ 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 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 = boostPerCert - } + 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 @@ -109,11 +130,21 @@ 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 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 + GetLatestCertSeen -> True + GarbageCollect _slot -> True deriving stock instance Show (Action Model a) deriving stock instance Eq (Action Model a) @@ -135,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 @@ -150,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 =