diff --git a/cardano-diffusion/api/lib/Cardano/Network/NodeToClient/Version.hs b/cardano-diffusion/api/lib/Cardano/Network/NodeToClient/Version.hs index b74593ab2de..9fb0538daf8 100644 --- a/cardano-diffusion/api/lib/Cardano/Network/NodeToClient/Version.hs +++ b/cardano-diffusion/api/lib/Cardano/Network/NodeToClient/Version.hs @@ -56,8 +56,13 @@ data NodeToClientVersion -- ^ new codecs for @PParams@ and @CompactGenesis@ | NodeToClientV_22 -- ^ support SRV records in @GetBigLedgerPeerSnapshot@ query + -- TODO: remove CBOR instances from LedgerPeers.Type when V22 support + -- is removed, update {To,From}JSON LedgerPeerSnapshot instances + -- and update LedgerPeerSnapshot query encoding in consensus. + -- marked with TODO's. | NodeToClientV_23 -- ^ added @QueryDRepsDelegations@, + -- LedgerPeerSnapshot CBOR encoding contains block hash and NetworkMagic deriving (Eq, Ord, Enum, Bounded, Show, Generic, NFData) -- | We set 16ths bit to distinguish `NodeToNodeVersion` and diff --git a/cardano-diffusion/cardano-diffusion.cabal b/cardano-diffusion/cardano-diffusion.cabal index 7b1eb44914b..b1280402932 100644 --- a/cardano-diffusion/cardano-diffusion.cabal +++ b/cardano-diffusion/cardano-diffusion.cabal @@ -151,6 +151,7 @@ library aeson, base >=4.14 && <4.22, bytestring, + cardano-crypto-class, cardano-diffusion:{api, protocols}, containers, contra-tracer, diff --git a/cardano-diffusion/changelog.d/20251028_162450_crocodile-dentist_ledgerpeersnapshot_hash.md b/cardano-diffusion/changelog.d/20251028_162450_crocodile-dentist_ledgerpeersnapshot_hash.md new file mode 100644 index 00000000000..817fddffd6f --- /dev/null +++ b/cardano-diffusion/changelog.d/20251028_162450_crocodile-dentist_ledgerpeersnapshot_hash.md @@ -0,0 +1,16 @@ + + +### Breaking + +cardano-diffusion: +- added `lpGetBlockInfo` to `LedgerPeersConsensusInterface` + +### Non-Breaking + +cardano-diffusion: +- moved `jobVerifyPeerSnapshot` from o-n diff --git a/cardano-diffusion/lib/Cardano/Network/LedgerPeerConsensusInterface.hs b/cardano-diffusion/lib/Cardano/Network/LedgerPeerConsensusInterface.hs index 615cb5a3edb..1f5d3198738 100644 --- a/cardano-diffusion/lib/Cardano/Network/LedgerPeerConsensusInterface.hs +++ b/cardano-diffusion/lib/Cardano/Network/LedgerPeerConsensusInterface.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE RankNTypes #-} + module Cardano.Network.LedgerPeerConsensusInterface ( LedgerPeersConsensusInterface (..) -- * Re-exports @@ -8,11 +10,14 @@ module Cardano.Network.LedgerPeerConsensusInterface import Control.Concurrent.Class.MonadSTM (MonadSTM (..)) -import Ouroboros.Network.BlockFetch.ConsensusInterface (FetchMode (..)) - +import Cardano.Crypto.Hash (Blake2b_256, Hash) import Cardano.Network.LedgerStateJudgement import Cardano.Network.PeerSelection.LocalRootPeers (OutboundConnectionsState (..)) +import Ouroboros.Network.Block (SlotNo) +import Ouroboros.Network.BlockFetch.ConsensusInterface (FetchMode (..)) +import Ouroboros.Network.Point (Block) + -- | Cardano Node specific consensus interface actions. -- @@ -31,4 +36,6 @@ data LedgerPeersConsensusInterface m = -- it only has local peers. -- , updateOutboundConnectionsState :: OutboundConnectionsState -> STM m () + + , getBlockHash :: forall a. SlotNo -> STM m (Block SlotNo (Hash Blake2b_256 a)) } diff --git a/cardano-diffusion/lib/Cardano/Network/PeerSelection/Governor/Monitor.hs b/cardano-diffusion/lib/Cardano/Network/PeerSelection/Governor/Monitor.hs index 18a44512f7f..658c3ae45ee 100644 --- a/cardano-diffusion/lib/Cardano/Network/PeerSelection/Governor/Monitor.hs +++ b/cardano-diffusion/lib/Cardano/Network/PeerSelection/Governor/Monitor.hs @@ -1,6 +1,10 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} -- | This module contains governor decisions for monitoring tasks: -- @@ -18,14 +22,18 @@ module Cardano.Network.PeerSelection.Governor.Monitor , ExtraTrace (..) ) where -import Data.Set qualified as Set - +import Control.Concurrent.JobPool (Job (..)) +import Control.Exception (assert) import Control.Monad.Class.MonadSTM import Control.Monad.Class.MonadTime.SI import Control.Monad.Class.MonadTimer.SI +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Set (Set) +import Data.Set qualified as Set +import Cardano.Crypto.Hash as Crypto (castHash) import Cardano.Network.ConsensusMode -import Cardano.Network.Diffusion.Configuration qualified as Cardano (srvPrefix) import Cardano.Network.LedgerPeerConsensusInterface qualified as Cardano import Cardano.Network.LedgerStateJudgement import Cardano.Network.PeerSelection.Bootstrap (UseBootstrapPeers (..), @@ -37,23 +45,22 @@ import Cardano.Network.PeerSelection.Governor.PeerSelectionState qualified as Ca import Cardano.Network.PeerSelection.PeerTrustable (PeerTrustable (..)) import Cardano.Network.PeerSelection.PublicRootPeers qualified as Cardano.PublicRootPeers import Cardano.Network.PeerSelection.State.LocalRootPeers qualified as LocalRootPeers -import Control.Exception (assert) -import Data.Map.Strict (Map) -import Data.Map.Strict qualified as Map -import Data.Set (Set) +import Ouroboros.Network.Block (HeaderHash, SlotNo, atSlot, pattern BlockPoint, + withHash) import Ouroboros.Network.PeerSelection.Governor.ActivePeers (jobDemoteActivePeer) -import Ouroboros.Network.PeerSelection.Governor.Monitor (jobVerifyPeerSnapshot) import Ouroboros.Network.PeerSelection.Governor.Types hiding (PeerSelectionCounters) import Ouroboros.Network.PeerSelection.LedgerPeers.Type - (LedgerPeersConsensusInterface (..)) + (LedgerPeerSnapshot (..), LedgerPeersConsensusInterface (..), + LedgerPeersKind (..)) import Ouroboros.Network.PeerSelection.PublicRootPeers qualified as PublicRootPeers import Ouroboros.Network.PeerSelection.State.EstablishedPeers qualified as EstablishedPeers import Ouroboros.Network.PeerSelection.State.KnownPeers qualified as KnownPeers import Ouroboros.Network.PeerSelection.State.LocalRootPeers (LocalRootConfig (..)) import Ouroboros.Network.PeerSelection.Types +import Ouroboros.Network.Point (Block (..)) -- | Used to set 'bootstrapPeersTimeout' for crashing the node in a critical @@ -495,8 +502,8 @@ monitorLedgerStateJudgement (TimedDecision m Cardano.ExtraState extraDebugState extraFlags (Cardano.ExtraPeers peeraddr) ExtraTrace peeraddr peerconn) monitorLedgerStateJudgement PeerSelectionActions{ - getLedgerStateCtx = ledgerCtx@LedgerPeersConsensusInterface { - lpExtraAPI = Cardano.LedgerPeersConsensusInterface { + getLedgerStateCtx = LedgerPeersConsensusInterface { + lpExtraAPI = lpExtraAPI@Cardano.LedgerPeersConsensusInterface { Cardano.getLedgerStateJudgement = readLedgerStateJudgement } } @@ -523,8 +530,9 @@ monitorLedgerStateJudgement PeerSelectionActions{ Decision { decisionTrace = [ExtraTrace (TraceLedgerStateJudgementChanged lsj)], decisionJobs = case (lsj, ledgerPeerSnapshot) of - (TooOld, Just ledgerPeerSnapshot') -> - [jobVerifyPeerSnapshot Cardano.srvPrefix ledgerPeerSnapshot' ledgerCtx] + (TooOld, Just (LedgerBigPeerSnapshotV23 point _magic _pools)) + | BlockPoint { atSlot, withHash } <- point -> + [jobVerifyPeerSnapshot (atSlot, withHash) lpExtraAPI] _otherwise -> [], decisionState = st { extraState = cpst { @@ -675,6 +683,35 @@ waitForSystemToQuiesce st@PeerSelectionState{ | otherwise = GuardedSkip Nothing +-- |This job, which is initiated by monitorLedgerStateJudgement job, +-- verifies whether the provided big ledger pools match up with the +-- ledger state once the node catches up to the slot at which the +-- snapshot was ostensibly taken +-- +jobVerifyPeerSnapshot :: (MonadSTM m) + => (SlotNo, HeaderHash (LedgerPeerSnapshot BigLedgerPeers)) + -> Cardano.LedgerPeersConsensusInterface m + -> Job () m (Completion m extraState extraDebugState extraFlags extraPeers extraTrace peeraddr peerconn) +jobVerifyPeerSnapshot (slotNo, theHash) + Cardano.LedgerPeersConsensusInterface { getBlockHash } + = Job job (const (completion False)) () "jobVerifyPeerSnapshot" + where + completion result = return . Completion $ \st _now -> + Decision { + decisionTrace = [TraceVerifyPeerSnapshot result], + decisionState = st, + decisionJobs = [] } + + job = do + Block { blockPointHash } <- atomically $ getBlockHash slotNo + let result = theHash == Crypto.castHash blockPointHash + return . Completion $ \st _now -> + Decision { + decisionTrace = [TraceVerifyPeerSnapshot result], + decisionState = st, + decisionJobs = [] } + + -- | Extra trace points for `TracePeerSelection`. -- -- TODO: it ought to be moved to `Types`, but that introduces a circular diff --git a/cardano-diffusion/protocols/cddl/specs/handshake-node-to-client.cddl b/cardano-diffusion/protocols/cddl/specs/handshake-node-to-client.cddl index 3d917758421..8715996714a 100644 --- a/cardano-diffusion/protocols/cddl/specs/handshake-node-to-client.cddl +++ b/cardano-diffusion/protocols/cddl/specs/handshake-node-to-client.cddl @@ -19,7 +19,7 @@ versionTable = { * versionNumber => nodeToClientVersionData } ; as of version 2 (which is no longer supported) we set 16th bit to 1 -; 16 / 17 / 18 / 19 / 20 / 21 / 22 / 23 +; 16 / 17 / 18 / 19 / 20 / 21 / 22 / 23 versionNumber = 32784 / 32785 / 32786 / 32787 / 32788 / 32789 / 32790 / 32791 ; As of version 15 and higher diff --git a/cardano-diffusion/tests/lib/Test/Cardano/Network/Diffusion/Testnet/Simulation.hs b/cardano-diffusion/tests/lib/Test/Cardano/Network/Diffusion/Testnet/Simulation.hs index bb54b757666..33987ca51d1 100644 --- a/cardano-diffusion/tests/lib/Test/Cardano/Network/Diffusion/Testnet/Simulation.hs +++ b/cardano-diffusion/tests/lib/Test/Cardano/Network/Diffusion/Testnet/Simulation.hs @@ -1245,6 +1245,7 @@ diffusionSimulationM Cardano.LedgerPeersConsensusInterface { Cardano.readFetchMode = pure (PraosFetchMode FetchModeDeadline) , Cardano.getLedgerStateJudgement = pure TooOld + , Cardano.getBlockHash = const retry , Cardano.updateOutboundConnectionsState = \a -> do a' <- readTVar onlyOutboundConnectionsStateVar diff --git a/cardano-diffusion/tests/lib/Test/Cardano/Network/PeerSelection.hs b/cardano-diffusion/tests/lib/Test/Cardano/Network/PeerSelection.hs index 246500f48da..bb73269c9d9 100644 --- a/cardano-diffusion/tests/lib/Test/Cardano/Network/PeerSelection.hs +++ b/cardano-diffusion/tests/lib/Test/Cardano/Network/PeerSelection.hs @@ -69,6 +69,7 @@ import Ouroboros.Network.PeerSelection.State.KnownPeers qualified as KnownPeers import Ouroboros.Network.PeerSelection.State.LocalRootPeers (LocalRootPeers (..)) import Ouroboros.Network.Point +import Ouroboros.Network.Socket () import Test.Cardano.Network.PeerSelection.MockEnvironment hiding (tests) import Test.Cardano.Network.PeerSelection.Utils @@ -4382,6 +4383,7 @@ _governorFindingPublicRoots targetNumberOfRootPeers readDomains readUseBootstrap lpExtraAPI = Cardano.LedgerPeersConsensusInterface { readFetchMode = pure (PraosFetchMode FetchModeDeadline), getLedgerStateJudgement = readLedgerStateJudgement, + getBlockHash = const retry, updateOutboundConnectionsState = \a -> do a' <- readTVar olocVar when (a /= a') $ diff --git a/cardano-diffusion/tests/lib/Test/Cardano/Network/PeerSelection/MockEnvironment.hs b/cardano-diffusion/tests/lib/Test/Cardano/Network/PeerSelection/MockEnvironment.hs index dfe7d0e344b..dca9de812d9 100644 --- a/cardano-diffusion/tests/lib/Test/Cardano/Network/PeerSelection/MockEnvironment.hs +++ b/cardano-diffusion/tests/lib/Test/Cardano/Network/PeerSelection/MockEnvironment.hs @@ -485,6 +485,7 @@ mockPeerSelectionActions' tracer lpExtraAPI = Cardano.LedgerPeersConsensusInterface { readFetchMode = pure (PraosFetchMode FetchModeDeadline), getLedgerStateJudgement = readLedgerStateJudgement, + getBlockHash = const retry, updateOutboundConnectionsState = \a -> do a' <- readTVar outboundConnectionsStateVar when (a /= a') $ diff --git a/cardano-ping/changelog.d/20251028_162800_crocodile-dentist_ledgerpeersnapshot_hash.md b/cardano-ping/changelog.d/20251028_162800_crocodile-dentist_ledgerpeersnapshot_hash.md new file mode 100644 index 00000000000..d161d5d0209 --- /dev/null +++ b/cardano-ping/changelog.d/20251028_162800_crocodile-dentist_ledgerpeersnapshot_hash.md @@ -0,0 +1,11 @@ + + + +### Breaking + +- Added `NodeToClientVersionV23` diff --git a/cardano-ping/src/Cardano/Network/Ping.hs b/cardano-ping/src/Cardano/Network/Ping.hs index ae723af712b..1b38178e4b1 100644 --- a/cardano-ping/src/Cardano/Network/Ping.hs +++ b/cardano-ping/src/Cardano/Network/Ping.hs @@ -154,6 +154,7 @@ supportedNodeToClientVersions magic = , NodeToClientVersionV20 magic , NodeToClientVersionV21 magic , NodeToClientVersionV22 magic + , NodeToClientVersionV23 magic ] data InitiatorOnly = InitiatorOnly | InitiatorAndResponder @@ -193,6 +194,7 @@ data NodeVersion | NodeToClientVersionV20 Word32 | NodeToClientVersionV21 Word32 | NodeToClientVersionV22 Word32 + | NodeToClientVersionV23 Word32 | NodeToNodeVersionV1 Word32 | NodeToNodeVersionV2 Word32 | NodeToNodeVersionV3 Word32 @@ -212,32 +214,33 @@ data NodeVersion instance ToJSON NodeVersion where toJSON nv = object $ case nv of - NodeToClientVersionV9 m -> go2 "NodeToClientVersionV9" m - NodeToClientVersionV10 m -> go2 "NodeToClientVersionV10" m - NodeToClientVersionV11 m -> go2 "NodeToClientVersionV11" m - NodeToClientVersionV12 m -> go2 "NodeToClientVersionV12" m - NodeToClientVersionV13 m -> go2 "NodeToClientVersionV13" m - NodeToClientVersionV14 m -> go2 "NodeToClientVersionV14" m - NodeToClientVersionV15 m -> go2 "NodeToClientVersionV15" m - NodeToClientVersionV16 m -> go2 "NodeToClientVersionV16" m - NodeToClientVersionV17 m -> go2 "NodeToClientVersionV17" m - NodeToClientVersionV18 m -> go2 "NodeToClientVersionV18" m - NodeToClientVersionV19 m -> go2 "NodeToClientVersionV19" m - NodeToClientVersionV20 m -> go2 "NodeToClientVersionV20" m - NodeToClientVersionV21 m -> go2 "NodeToClientVersionV21" m - NodeToClientVersionV22 m -> go2 "NodeToClientVersionV22" m - NodeToNodeVersionV1 m -> go2 "NodeToNodeVersionV1" m - NodeToNodeVersionV2 m -> go2 "NodeToNodeVersionV2" m - NodeToNodeVersionV3 m -> go2 "NodeToNodeVersionV3" m - NodeToNodeVersionV4 m i -> go3 "NodeToNodeVersionV4" m i - NodeToNodeVersionV5 m i -> go3 "NodeToNodeVersionV5" m i - NodeToNodeVersionV6 m i -> go3 "NodeToNodeVersionV6" m i - NodeToNodeVersionV7 m i -> go3 "NodeToNodeVersionV7" m i - NodeToNodeVersionV8 m i -> go3 "NodeToNodeVersionV8" m i - NodeToNodeVersionV9 m i -> go3 "NodeToNodeVersionV9" m i - NodeToNodeVersionV10 m i -> go3 "NodeToNodeVersionV10" m i - NodeToNodeVersionV11 m i -> go3 "NodeToNodeVersionV11" m i - NodeToNodeVersionV12 m i -> go3 "NodeToNodeVersionV12" m i + NodeToClientVersionV9 m -> go2 "NodeToClientVersionV9" m + NodeToClientVersionV10 m -> go2 "NodeToClientVersionV10" m + NodeToClientVersionV11 m -> go2 "NodeToClientVersionV11" m + NodeToClientVersionV12 m -> go2 "NodeToClientVersionV12" m + NodeToClientVersionV13 m -> go2 "NodeToClientVersionV13" m + NodeToClientVersionV14 m -> go2 "NodeToClientVersionV14" m + NodeToClientVersionV15 m -> go2 "NodeToClientVersionV15" m + NodeToClientVersionV16 m -> go2 "NodeToClientVersionV16" m + NodeToClientVersionV17 m -> go2 "NodeToClientVersionV17" m + NodeToClientVersionV18 m -> go2 "NodeToClientVersionV18" m + NodeToClientVersionV19 m -> go2 "NodeToClientVersionV19" m + NodeToClientVersionV20 m -> go2 "NodeToClientVersionV20" m + NodeToClientVersionV21 m -> go2 "NodeToClientVersionV21" m + NodeToClientVersionV22 m -> go2 "NodeToClientVersionV22" m + NodeToClientVersionV23 m -> go2 "NodeToClientVersionV23" m + NodeToNodeVersionV1 m -> go2 "NodeToNodeVersionV1" m + NodeToNodeVersionV2 m -> go2 "NodeToNodeVersionV2" m + NodeToNodeVersionV3 m -> go2 "NodeToNodeVersionV3" m + NodeToNodeVersionV4 m i -> go3 "NodeToNodeVersionV4" m i + NodeToNodeVersionV5 m i -> go3 "NodeToNodeVersionV5" m i + NodeToNodeVersionV6 m i -> go3 "NodeToNodeVersionV6" m i + NodeToNodeVersionV7 m i -> go3 "NodeToNodeVersionV7" m i + NodeToNodeVersionV8 m i -> go3 "NodeToNodeVersionV8" m i + NodeToNodeVersionV9 m i -> go3 "NodeToNodeVersionV9" m i + NodeToNodeVersionV10 m i -> go3 "NodeToNodeVersionV10" m i + NodeToNodeVersionV11 m i -> go3 "NodeToNodeVersionV11" m i + NodeToNodeVersionV12 m i -> go3 "NodeToNodeVersionV12" m i NodeToNodeVersionV13 m i ps -> go4 "NodeToNodeVersionV13" m i ps NodeToNodeVersionV14 m i ps -> go4 "NodeToNodeVersionV14" m i ps where @@ -377,6 +380,9 @@ handshakeReqEnc versions query = encodeVersion (NodeToClientVersionV22 magic) = CBOR.encodeWord (22 `setBit` nodeToClientVersionBit) <> nodeToClientDataWithQuery magic + encodeVersion (NodeToClientVersionV23 magic) = + CBOR.encodeWord (23 `setBit` nodeToClientVersionBit) + <> nodeToClientDataWithQuery magic -- node-to-node encodeVersion (NodeToNodeVersionV1 magic) = @@ -528,6 +534,7 @@ handshakeDec = do (20, True) -> Right . NodeToClientVersionV20 <$> (CBOR.decodeListLen *> CBOR.decodeWord32 <* (modeFromBool <$> CBOR.decodeBool)) (21, True) -> Right . NodeToClientVersionV21 <$> (CBOR.decodeListLen *> CBOR.decodeWord32 <* (modeFromBool <$> CBOR.decodeBool)) (22, True) -> Right . NodeToClientVersionV22 <$> (CBOR.decodeListLen *> CBOR.decodeWord32 <* (modeFromBool <$> CBOR.decodeBool)) + (23, True) -> Right . NodeToClientVersionV23 <$> (CBOR.decodeListLen *> CBOR.decodeWord32 <* (modeFromBool <$> CBOR.decodeBool)) _ -> return $ Left $ UnknownVersionInRsp version decodeWithMode :: (Word32 -> InitiatorOnly -> NodeVersion) -> CBOR.Decoder s (Either HandshakeFailure NodeVersion) @@ -839,31 +846,32 @@ pingClient stdout stderr PingOpts{..} versions peer = bracket isSameVersionAndMagic :: NodeVersion -> NodeVersion -> Bool isSameVersionAndMagic v1 v2 = extract v1 == extract v2 where extract :: NodeVersion -> (Int, Word32) - extract (NodeToClientVersionV9 m) = (-9, m) - extract (NodeToClientVersionV10 m) = (-10, m) - extract (NodeToClientVersionV11 m) = (-11, m) - extract (NodeToClientVersionV12 m) = (-12, m) - extract (NodeToClientVersionV13 m) = (-13, m) - extract (NodeToClientVersionV14 m) = (-14, m) - extract (NodeToClientVersionV15 m) = (-15, m) - extract (NodeToClientVersionV16 m) = (-16, m) - extract (NodeToClientVersionV17 m) = (-17, m) - extract (NodeToClientVersionV18 m) = (-18, m) - extract (NodeToClientVersionV19 m) = (-19, m) - extract (NodeToClientVersionV20 m) = (-20, m) - extract (NodeToClientVersionV21 m) = (-21, m) - extract (NodeToClientVersionV22 m) = (-22, m) - extract (NodeToNodeVersionV1 m) = (1, m) - extract (NodeToNodeVersionV2 m) = (2, m) - extract (NodeToNodeVersionV3 m) = (3, m) - extract (NodeToNodeVersionV4 m _) = (4, m) - extract (NodeToNodeVersionV5 m _) = (5, m) - extract (NodeToNodeVersionV6 m _) = (6, m) - extract (NodeToNodeVersionV7 m _) = (7, m) - extract (NodeToNodeVersionV8 m _) = (8, m) - extract (NodeToNodeVersionV9 m _) = (9, m) - extract (NodeToNodeVersionV10 m _) = (10, m) - extract (NodeToNodeVersionV11 m _) = (11, m) - extract (NodeToNodeVersionV12 m _) = (12, m) + extract (NodeToClientVersionV9 m) = (-9, m) + extract (NodeToClientVersionV10 m) = (-10, m) + extract (NodeToClientVersionV11 m) = (-11, m) + extract (NodeToClientVersionV12 m) = (-12, m) + extract (NodeToClientVersionV13 m) = (-13, m) + extract (NodeToClientVersionV14 m) = (-14, m) + extract (NodeToClientVersionV15 m) = (-15, m) + extract (NodeToClientVersionV16 m) = (-16, m) + extract (NodeToClientVersionV17 m) = (-17, m) + extract (NodeToClientVersionV18 m) = (-18, m) + extract (NodeToClientVersionV19 m) = (-19, m) + extract (NodeToClientVersionV20 m) = (-20, m) + extract (NodeToClientVersionV21 m) = (-21, m) + extract (NodeToClientVersionV22 m) = (-22, m) + extract (NodeToClientVersionV23 m) = (-23, m) + extract (NodeToNodeVersionV1 m) = (1, m) + extract (NodeToNodeVersionV2 m) = (2, m) + extract (NodeToNodeVersionV3 m) = (3, m) + extract (NodeToNodeVersionV4 m _) = (4, m) + extract (NodeToNodeVersionV5 m _) = (5, m) + extract (NodeToNodeVersionV6 m _) = (6, m) + extract (NodeToNodeVersionV7 m _) = (7, m) + extract (NodeToNodeVersionV8 m _) = (8, m) + extract (NodeToNodeVersionV9 m _) = (9, m) + extract (NodeToNodeVersionV10 m _) = (10, m) + extract (NodeToNodeVersionV11 m _) = (11, m) + extract (NodeToNodeVersionV12 m _) = (12, m) extract (NodeToNodeVersionV13 m _ _) = (13, m) extract (NodeToNodeVersionV14 m _ _) = (14, m) diff --git a/dmq-node/changelog.d/20251030_162643_crocodile-dentist_ledgerpeersnapshot_hash.md b/dmq-node/changelog.d/20251030_162643_crocodile-dentist_ledgerpeersnapshot_hash.md new file mode 100644 index 00000000000..200772f8c93 --- /dev/null +++ b/dmq-node/changelog.d/20251030_162643_crocodile-dentist_ledgerpeersnapshot_hash.md @@ -0,0 +1,17 @@ + + + + +### Non-Breaking + +- update to new LedgerPeerSnapshot definition diff --git a/dmq-node/src/DMQ/Configuration.hs b/dmq-node/src/DMQ/Configuration.hs index d3b9c8c69aa..f3ec0bb0f4e 100644 --- a/dmq-node/src/DMQ/Configuration.hs +++ b/dmq-node/src/DMQ/Configuration.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} @@ -69,7 +70,7 @@ import Ouroboros.Network.OrphanInstances () import Ouroboros.Network.PeerSelection.Governor.Types (PeerSelectionTargets (..), makePublicPeerSelectionStateVar) import Ouroboros.Network.PeerSelection.LedgerPeers.Type - (LedgerPeerSnapshot (..)) + (LedgerPeerSnapshot (..), LedgerPeersKind (..)) import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing (..)) import Ouroboros.Network.Server.RateLimiting (AcceptedConnectionsLimit (..)) import Ouroboros.Network.Snocket (LocalAddress (..), RemoteAddress) @@ -569,8 +570,8 @@ mkDiffusionConfiguration updateLedgerPeerSnapshot :: HasCallStack => FilePath -> STM IO (Maybe FilePath) - -> (Maybe LedgerPeerSnapshot -> STM IO ()) - -> IO (Maybe LedgerPeerSnapshot) + -> (Maybe (LedgerPeerSnapshot BigLedgerPeers) -> STM IO ()) + -> IO (Maybe (LedgerPeerSnapshot BigLedgerPeers)) updateLedgerPeerSnapshot topologyDir readLedgerPeerPath writeVar = do mPeerSnapshotFile <- atomically readLedgerPeerPath mLedgerPeerSnapshot <- case mPeerSnapshotFile of @@ -604,5 +605,3 @@ data ConfigurationError = instance Exception ConfigurationError where displayException NoAddressInformation = "no ipv4 or ipv6 address specified, use --host-addr or --host-ipv6-addr" - - diff --git a/dmq-node/src/DMQ/Configuration/Topology.hs b/dmq-node/src/DMQ/Configuration/Topology.hs index 23f33f861d0..c5857ac0b00 100644 --- a/dmq-node/src/DMQ/Configuration/Topology.hs +++ b/dmq-node/src/DMQ/Configuration/Topology.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE NamedFieldPuns #-} @@ -16,7 +17,8 @@ import Data.Text qualified as Text import Ouroboros.Network.Diffusion.Topology (NetworkTopology (..)) import Ouroboros.Network.OrphanInstances (localRootPeersGroupsFromJSON, networkTopologyFromJSON, networkTopologyToJSON) -import Ouroboros.Network.PeerSelection.LedgerPeers.Type (LedgerPeerSnapshot) +import Ouroboros.Network.PeerSelection.LedgerPeers.Type (LedgerPeerSnapshot, + LedgerPeersKind (..)) import System.Exit (die) data NoExtraConfig = NoExtraConfig @@ -69,7 +71,7 @@ readTopologyFileOrError nc = >>= either (die . Text.unpack) pure -readPeerSnapshotFile :: FilePath -> IO (Either Text LedgerPeerSnapshot) +readPeerSnapshotFile :: FilePath -> IO (Either Text (LedgerPeerSnapshot BigLedgerPeers)) readPeerSnapshotFile psf = do eBs <- try $ BS.readFile psf case eBs of @@ -89,7 +91,7 @@ readPeerSnapshotFile psf = do , Text.pack err ] -readPeerSnapshotFileOrError :: FilePath -> IO LedgerPeerSnapshot +readPeerSnapshotFileOrError :: FilePath -> IO (LedgerPeerSnapshot BigLedgerPeers) readPeerSnapshotFileOrError psf = readPeerSnapshotFile psf >>= either (die . Text.unpack) diff --git a/nix/ouroboros-network.nix b/nix/ouroboros-network.nix index c819a4d09d0..ef1ace4da9c 100644 --- a/nix/ouroboros-network.nix +++ b/nix/ouroboros-network.nix @@ -137,6 +137,19 @@ let "-L${lib.getLib static-secp256k1}/lib" "-L${lib.getLib static-libblst}/lib" ]; + packages.cardano-diffusion.ghcOptions = with pkgs; [ + "-L${lib.getLib static-gmp}/lib" + "-L${lib.getLib static-libsodium-vrf}/lib" + "-L${lib.getLib static-secp256k1}/lib" + "-L${lib.getLib static-libblst}/lib" + ]; + # for api-bench + packages.ouroboros-network.ghcOptions = with pkgs; [ + "-L${lib.getLib static-gmp}/lib" + "-L${lib.getLib static-libsodium-vrf}/lib" + "-L${lib.getLib static-secp256k1}/lib" + "-L${lib.getLib static-libblst}/lib" + ]; }) ]; }); diff --git a/ouroboros-network/api/lib/Ouroboros/Network/Block.hs b/ouroboros-network/api/lib/Ouroboros/Network/Block.hs index e39f8608ff5..7bcdd080bf3 100644 --- a/ouroboros-network/api/lib/Ouroboros/Network/Block.hs +++ b/ouroboros-network/api/lib/Ouroboros/Network/Block.hs @@ -79,6 +79,7 @@ import Codec.CBOR.Read qualified as Read import Codec.CBOR.Write qualified as Write import Codec.Serialise (Serialise (..)) import Control.Monad (when) +import Data.Aeson (FromJSON, ToJSON) import Data.ByteString.Base16.Lazy qualified as B16 import Data.ByteString.Lazy qualified as Lazy import Data.ByteString.Lazy.Char8 qualified as BSC @@ -216,6 +217,8 @@ deriving newtype instance StandardHash block => Ord (Point block) deriving via (Quiet (Point block)) instance StandardHash block => Show (Point block) deriving newtype instance StandardHash block => NoThunks (Point block) +deriving newtype instance ToJSON (Point.Block SlotNo (HeaderHash block)) => ToJSON (Point block) +deriving newtype instance FromJSON (Point.Block SlotNo (HeaderHash block)) => FromJSON (Point block) instance ShowProxy block => ShowProxy (Point block) where showProxy _ = "Point " ++ showProxy (Proxy :: Proxy block) diff --git a/ouroboros-network/api/lib/Ouroboros/Network/Magic.hs b/ouroboros-network/api/lib/Ouroboros/Network/Magic.hs index 8974d95de63..d5d4dfed0f5 100644 --- a/ouroboros-network/api/lib/Ouroboros/Network/Magic.hs +++ b/ouroboros-network/api/lib/Ouroboros/Network/Magic.hs @@ -3,6 +3,7 @@ module Ouroboros.Network.Magic where +import Control.DeepSeq (NFData) import Data.Word (Word32) import GHC.Generics (Generic) import NoThunks.Class (NoThunks) @@ -11,3 +12,5 @@ import NoThunks.Class (NoThunks) -- | NetworkMagic is used to differentiate between different networks during the initial handshake. newtype NetworkMagic = NetworkMagic { unNetworkMagic :: Word32 } deriving (Show, Eq, Generic, NoThunks) + +instance NFData NetworkMagic diff --git a/ouroboros-network/api/lib/Ouroboros/Network/PeerSelection/LedgerPeers/Type.hs b/ouroboros-network/api/lib/Ouroboros/Network/PeerSelection/LedgerPeers/Type.hs index ca92eecdff4..73b53f915dc 100644 --- a/ouroboros-network/api/lib/Ouroboros/Network/PeerSelection/LedgerPeers/Type.hs +++ b/ouroboros-network/api/lib/Ouroboros/Network/PeerSelection/LedgerPeers/Type.hs @@ -1,17 +1,18 @@ {-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} - -{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE TypeFamilies #-} -- | Various types related to ledger peers. This module is re-exported from -- "Ouroboros.Network.PeerSelection.LedgerPeers". @@ -27,13 +28,23 @@ module Ouroboros.Network.PeerSelection.LedgerPeers.Type , UseLedgerPeers (..) , AfterSlot (..) , LedgerPeersKind (..) - , LedgerPeerSnapshot (.., LedgerPeerSnapshot) + , LedgerPeerSnapshot (..) + , SomeLedgerPeerSnapshot (..) , LedgerPeerSnapshotSRVSupport (..) , encodeLedgerPeerSnapshot + , encodeLedgerPeerSnapshot' , decodeLedgerPeerSnapshot - , getRelayAccessPointsFromLedgerPeerSnapshot + , encodeWithOrigin + , decodeWithOrigin + , encodeLedgerPeerSnapshotPoint + , decodeLedgerPeerSnapshotPoint + , encodeBigStakePools + , decodeBigStakePools + , encodeAllStakePools + , decodeAllStakePools + , getRelayAccessPointsFromBigLedgerPeersSnapshot + , getRelayAccessPointsFromAllLedgerPeersSnapshot , isLedgerPeersEnabled - , compareLedgerPeerSnapshotApproximate -- * Re-exports , SRVPrefix , RelayAccessPoint (..) @@ -41,214 +52,359 @@ module Ouroboros.Network.PeerSelection.LedgerPeers.Type , prefixLedgerRelayAccessPoint ) where -import GHC.Generics (Generic) --- TODO: remove `FromCBOR` and `ToCBOR` type classes -import Cardano.Binary (FromCBOR (..), ToCBOR (..)) -import Cardano.Binary qualified as Codec -import Cardano.Slotting.Slot (SlotNo (..), WithOrigin (..)) +import Control.Applicative ((<|>)) import Control.Concurrent.Class.MonadSTM import Control.DeepSeq (NFData (..)) import Control.Monad (forM) import Data.Aeson -import Data.Bifunctor (first, second) +import Data.Bifunctor (second) import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty qualified as NonEmpty +import Data.Typeable +import GHC.Generics (Generic) import NoThunks.Class +-- TODO: remove `FromCBOR` and `ToCBOR` instances when ntc V22 is no longer supported +import Cardano.Binary (FromCBOR (..), ToCBOR (..)) +import Cardano.Binary qualified as Codec +import Cardano.Crypto.Hash (Blake2b_256, Hash) +import Ouroboros.Network.Block +import Ouroboros.Network.Magic import Ouroboros.Network.PeerSelection.RelayAccessPoint +import Ouroboros.Network.Point --- |The type of big ledger peers that is serialised or later --- provided by node configuration for the networking layer --- to connect to when syncing. +-- | A snapshot of ledger peers extracted from the ledger state at some point -- -data LedgerPeerSnapshot = - LedgerPeerSnapshotV2 (WithOrigin SlotNo, [(AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))]) - -- ^ Internal use for version 2, use pattern synonym for public API - deriving (Eq, Show) +data LedgerPeerSnapshot (a :: LedgerPeersKind) where + LedgerPeerSnapshotV2 + :: (WithOrigin SlotNo, [(AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))]) + -> LedgerPeerSnapshot BigLedgerPeers + LedgerBigPeerSnapshotV23 + :: !(Point (LedgerPeerSnapshot BigLedgerPeers)) + -> !NetworkMagic + -> ![(AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))] + -> LedgerPeerSnapshot BigLedgerPeers + LedgerAllPeerSnapshotV23 + :: !(Point (LedgerPeerSnapshot AllLedgerPeers)) + -> !NetworkMagic + -> ![(PoolStake, NonEmpty LedgerRelayAccessPoint)] + -> LedgerPeerSnapshot AllLedgerPeers + +deriving instance Eq (LedgerPeerSnapshot a) +deriving instance Show (LedgerPeerSnapshot a) +instance Typeable a => StandardHash (LedgerPeerSnapshot a) +type instance HeaderHash (LedgerPeerSnapshot a) = Hash Blake2b_256 (LedgerPeerSnapshot a) + +-- | facility for encoding the snapshot +-- +data SomeLedgerPeerSnapshot = forall k. SomeLedgerPeerSnapshot (LedgerPeerSnapshot k) +deriving instance Show SomeLedgerPeerSnapshot -getRelayAccessPointsFromLedgerPeerSnapshot +getRelayAccessPointsFromBigLedgerPeersSnapshot :: SRVPrefix - -> LedgerPeerSnapshot + -> LedgerPeerSnapshot BigLedgerPeers -> (WithOrigin SlotNo, [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]) -getRelayAccessPointsFromLedgerPeerSnapshot srvPrefix (LedgerPeerSnapshotV2 as) = +getRelayAccessPointsFromBigLedgerPeersSnapshot srvPrefix = \case + LedgerPeerSnapshotV2 as -> fmap (fmap (fmap (fmap (fmap (prefixLedgerRelayAccessPoint srvPrefix))))) as + LedgerBigPeerSnapshotV23 pt _magic as -> + let as' = fmap (fmap (fmap (fmap (prefixLedgerRelayAccessPoint srvPrefix)))) as + in (pointSlot pt, as') --- |Public API to access snapshot data. Currently access to only most recent version is available. --- Nonetheless, serialisation from the node into JSON is supported for older versions via internal --- api so that newer CLI can still support older node formats. --- -pattern LedgerPeerSnapshot :: (WithOrigin SlotNo, [(AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))]) - -> LedgerPeerSnapshot -pattern LedgerPeerSnapshot payload <- LedgerPeerSnapshotV2 payload where - LedgerPeerSnapshot payload = LedgerPeerSnapshotV2 payload - -{-# COMPLETE LedgerPeerSnapshot #-} - --- | Since ledger peer snapshot is serialised with all domain names --- fully qualified, and all stake values are approximate in floating --- point, comparison is necessarily approximate as well. --- The candidate argument is processed here to simulate a round trip --- by the serialisation mechanism and then compared to the baseline --- argument, which is assumed that it was actually processed this way --- when a snapshot was created earlier, and hence it is approximate as well. --- The two approximate values should be equal if they were created --- from the same 'faithful' data. --- -compareLedgerPeerSnapshotApproximate :: [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))] - -> [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))] - -> Bool -compareLedgerPeerSnapshotApproximate baseline candidate = - case tripIt of - Success candidate' -> candidate' == baseline - Error _ -> False - where - tripIt = fmap (fmap (fmap (first unPoolStakeCoded))) - . fmap (fmap (first unAccPoolStakeCoded)) - . fromJSON - . toJSON - . fmap (fmap (first PoolStakeCoded)) - . fmap (first AccPoolStakeCoded) - $ candidate - --- | In case the format changes in the future, this function provides a migration functionality --- when possible. --- -migrateLedgerPeerSnapshot - :: LedgerPeerSnapshot - -> Maybe LedgerPeerSnapshot -migrateLedgerPeerSnapshot snapshot@LedgerPeerSnapshotV2{} = Just snapshot +getRelayAccessPointsFromAllLedgerPeersSnapshot + :: SRVPrefix + -> LedgerPeerSnapshot AllLedgerPeers + -> (WithOrigin SlotNo, [(PoolStake, NonEmpty RelayAccessPoint)]) +getRelayAccessPointsFromAllLedgerPeersSnapshot srvPrefix = \case + LedgerAllPeerSnapshotV23 pt _magic as -> + let as' = fmap (fmap (fmap (prefixLedgerRelayAccessPoint srvPrefix))) as + in (pointSlot pt, as') + -instance ToJSON LedgerPeerSnapshot where +instance ToJSON (LedgerPeerSnapshot a) where toJSON (LedgerPeerSnapshotV2 (slot, pools)) = object [ "version" .= (2 :: Int) , "slotNo" .= slot , "bigLedgerPools" .= [ object [ "accumulatedStake" .= fromRational @Double accStake - , "relativeStake" .= fromRational @Double relStake - , "relays" .= relays] + , "relativeStake" .= fromRational @Double relStake + , "relays" .= relays] + | (AccPoolStake accStake, (PoolStake relStake, relays)) <- pools + ]] + toJSON (LedgerAllPeerSnapshotV23 pt magic pools) = + object [ "NodeToClientVersion" .= (23 :: Int) + , "Point" .= toJSON pt + , "NetworkMagic" .= unNetworkMagic magic + , "allLedgerPools" .= [ object + [ "relativeStake" .= fromRational @Double relStake + , "relays" .= relays] + | (PoolStake relStake, relays) <- pools + ]] + toJSON (LedgerBigPeerSnapshotV23 pt magic pools) = + object [ "NodeToClientVersion" .= (23 :: Int) + , "Point" .= toJSON pt + , "NetworkMagic" .= unNetworkMagic magic + , "bigLedgerPools" .= [ object + [ "accumulatedStake" .= fromRational @Double accStake + , "relativeStake" .= fromRational @Double relStake + , "relays" .= relays] | (AccPoolStake accStake, (PoolStake relStake, relays)) <- pools ]] -instance FromJSON LedgerPeerSnapshot where - parseJSON = withObject "LedgerPeerSnapshot" $ \v -> do - vNum :: Int <- v .: "version" - ledgerPeerSnapshot <- - case vNum of - 1 -> do - slot <- v .: "slotNo" - bigPools <- v .: "bigLedgerPools" - bigPools' <- forM (zip [0 :: Int ..] bigPools) \(idx, poolO) -> do - let f poolV = do - AccPoolStakeCoded accStake <- poolV .: "accumulatedStake" - PoolStakeCoded reStake <- poolV .: "relativeStake" - -- decode using `LedgerRelayAccessPointV1` instance - relays <- fmap getLedgerReelayAccessPointV1 <$> poolV .: "relays" - return (accStake, (reStake, relays)) - withObject ("bigLedgerPools[" <> show idx <> "]") f (Object poolO) - - return $ LedgerPeerSnapshotV2 (slot, bigPools') - 2 -> do - slot <- v .: "slotNo" - bigPools <- v .: "bigLedgerPools" - bigPools' <- forM (zip [0 :: Int ..] bigPools) \(idx, poolO) -> do - let f poolV = do - AccPoolStakeCoded accStake <- poolV .: "accumulatedStake" - PoolStakeCoded reStake <- poolV .: "relativeStake" - relays <- poolV .: "relays" - return (accStake, (reStake, relays)) - withObject ("bigLedgerPools[" <> show idx <> "]") f (Object poolO) - - return $ LedgerPeerSnapshotV2 (slot, bigPools') - _ -> fail $ "Network.LedgerPeers.Type: parseJSON: failed to parse unsupported version " <> show vNum - case migrateLedgerPeerSnapshot ledgerPeerSnapshot of - Just ledgerPeerSnapshot' -> return ledgerPeerSnapshot' - Nothing -> fail "Network.LedgerPeers.Type: parseJSON: failed to migrate big ledger peer snapshot" +instance FromJSON (LedgerPeerSnapshot AllLedgerPeers) where + parseJSON = withObject "LedgerPeerSnapshot" \v -> do + -- TODO: remove "version" key after NtC V22 support is removed + vNum :: Int <- v .: "version" <|> v .: "NodeToClientVersion" + allPools <- v .: "allLedgerPools" + case vNum of + 23 -> do + point <- v .: "Point" + magic <- v .: "NetworkMagic" + allPools' <- forM (zip [0 :: Int ..] allPools) \(idx, poolO) -> do + let f poolV = do + reStake <- poolV .: "relativeStake" + relays <- poolV .: "relays" + return (reStake, relays) + withObject ("allLedgerPools[" <> show idx <> "]") f (Object poolO) + + return $ LedgerAllPeerSnapshotV23 point (NetworkMagic magic) allPools' + _ -> + fail $ "Network.LedgerPeers.Type: parseJSON: failed to parse unsupported version " + <> show vNum + +instance FromJSON (LedgerPeerSnapshot BigLedgerPeers) where + parseJSON = withObject "LedgerPeerSnapshot" \v -> do + -- TODO: remove "version" key after NtC V22 support is removed + vNum :: Int <- v .: "version" <|> v .: "NodeToClientVersion" + case vNum of + 1 -> do + slot <- v .: "slotNo" + bigPools <- v .: "bigLedgerPools" + bigPools' <- forM (zip [0 :: Int ..] bigPools) \(idx, poolO) -> do + let f poolV = do + accStake <- poolV .: "accumulatedStake" + reStake <- poolV .: "relativeStake" + -- decode using `LedgerRelayAccessPointV1` instance + relays <- fmap getLedgerReelayAccessPointV1 <$> poolV .: "relays" + return (accStake, (reStake, relays)) + withObject ("bigLedgerPools[" <> show idx <> "]") f (Object poolO) + + return $ LedgerPeerSnapshotV2 (slot, bigPools') + 2 -> do + slot <- v .: "slotNo" + bigPools <- v .: "bigLedgerPools" + bigPools' <- forM (zip [0 :: Int ..] bigPools) \(idx, poolO) -> do + let f poolV = do + accStake <- poolV .: "accumulatedStake" + reStake <- poolV .: "relativeStake" + relays <- poolV .: "relays" + return (accStake, (reStake, relays)) + withObject ("bigLedgerPools[" <> show idx <> "]") f (Object poolO) + + return $ LedgerPeerSnapshotV2 (slot, bigPools') + 23 -> do + point <- v .: "Point" + magic <- v .: "NetworkMagic" + bigPools <- v .: "bigLedgerPools" + bigPools' <- forM (zip [0 :: Int ..] bigPools) \(idx, poolO) -> do + let f poolV = do + accStake <- poolV .: "accumulatedStake" + reStake <- poolV .: "relativeStake" + relays <- poolV .: "relays" + return (accStake, (reStake, relays)) + withObject ("bigLedgerPools[" <> show idx <> "]") f (Object poolO) + + return $ LedgerBigPeerSnapshotV23 point (NetworkMagic magic) bigPools' + _ -> + fail $ "Network.LedgerPeers.Type: parseJSON: failed to parse unsupported version " + <> show vNum + + +data LedgerPeerSnapshotSRVSupport + = LedgerPeerSnapshotSupportsSRV + -- ^ since `NodeToClientV_22` + | LedgerPeerSnapshotDoesntSupportSRV + deriving (Show, Eq) + + +encodeLedgerPeerSnapshot' :: LedgerPeerSnapshotSRVSupport -> SomeLedgerPeerSnapshot -> Codec.Encoding +encodeLedgerPeerSnapshot' srvSupport (SomeLedgerPeerSnapshot lps) = encodeLedgerPeerSnapshot srvSupport lps +{-# INLINE encodeLedgerPeerSnapshot' #-} + + +encodeLedgerPeerSnapshot :: LedgerPeerSnapshotSRVSupport -> LedgerPeerSnapshot a -> Codec.Encoding +encodeLedgerPeerSnapshot LedgerPeerSnapshotDoesntSupportSRV (LedgerPeerSnapshotV2 (wOrigin, pools)) = + Codec.encodeListLen 2 + <> Codec.encodeWord8 1 -- internal version + <> Codec.encodeListLen 2 + <> encodeWithOrigin wOrigin + <> toCBOR pools' + where + pools' = + [(accPoolStake, (relStake, NonEmpty.fromList relays)) + | (accPoolStake, (relStake, relays)) <- + -- filter out SRV domains, not supported by `< NodeToClientV_22` + map + (second $ second $ NonEmpty.filter + (\case + LedgerRelayAccessSRVDomain {} -> False + _ -> True) + ) + pools + , not (null relays) + ] + +encodeLedgerPeerSnapshot LedgerPeerSnapshotSupportsSRV (LedgerPeerSnapshotV2 (wOrigin, pools)) = + Codec.encodeListLen 2 + <> Codec.encodeWord8 1 -- internal version + <> Codec.encodeListLen 2 + <> encodeWithOrigin wOrigin + <> toCBOR pools + +encodeLedgerPeerSnapshot _LedgerPeerSnapshotSupportsSRV (LedgerBigPeerSnapshotV23 pt magic pools) = + Codec.encodeListLen 2 + <> Codec.encodeWord8 2 -- internal version + <> Codec.encodeListLen 3 + <> encodeLedgerPeerSnapshotPoint pt + <> Codec.encodeWord32 (unNetworkMagic magic) + <> encodeBigStakePools pools + +encodeLedgerPeerSnapshot _LedgerPeerSnapshotSupportsSRV (LedgerAllPeerSnapshotV23 pt magic pools) = + Codec.encodeListLen 2 + <> Codec.encodeWord8 3 -- internal version + <> Codec.encodeListLen 3 + <> encodeLedgerPeerSnapshotPoint pt + <> Codec.encodeWord32 (unNetworkMagic magic) + <> encodeAllStakePools pools + + +decodeLedgerPeerSnapshot :: Codec.Decoder s SomeLedgerPeerSnapshot +decodeLedgerPeerSnapshot = do + Codec.decodeListLenOf 2 + version <- Codec.decodeWord8 + case version of + 1 -> Codec.decodeListLenOf 2 >> + SomeLedgerPeerSnapshot . + LedgerPeerSnapshotV2 <$> ((,) <$> decodeWithOrigin <*> fromCBOR) + 2 -> Codec.decodeListLenOf 3 >> + SomeLedgerPeerSnapshot <$> + (LedgerBigPeerSnapshotV23 <$> decodeLedgerPeerSnapshotPoint + <*> (NetworkMagic <$> Codec.decodeWord32) + <*> decodeBigStakePools) + 3 -> Codec.decodeListLenOf 3 >> + SomeLedgerPeerSnapshot <$> + (LedgerAllPeerSnapshotV23 <$> decodeLedgerPeerSnapshotPoint + <*> (NetworkMagic <$> Codec.decodeWord32) + <*> decodeAllStakePools) + _ -> fail $ "LedgerPeers.Type: no decoder could be found for version " <> show version encodeWithOrigin :: WithOrigin SlotNo -> Codec.Encoding encodeWithOrigin Origin = Codec.encodeListLen 1 <> Codec.encodeWord8 0 encodeWithOrigin (At slotNo) = Codec.encodeListLen 2 <> Codec.encodeWord8 1 <> toCBOR slotNo + decodeWithOrigin :: Codec.Decoder s (WithOrigin SlotNo) decodeWithOrigin = do listLen <- Codec.decodeListLen - tag <- Codec.decodeWord8 + tag <- Codec.decodeWord8 case (listLen, tag) of - (1, 0) -> pure $ Origin + (1, 0) -> pure Origin (1, _) -> fail "LedgerPeers.Type: Expected tag for Origin constructor" (2, 1) -> At <$> fromCBOR (2, _) -> fail "LedgerPeers.Type: Expected tag for At constructor" _ -> fail "LedgerPeers.Type: Unrecognized list length while decoding WithOrigin SlotNo" -data LedgerPeerSnapshotSRVSupport - = LedgerPeerSnapshotSupportsSRV - -- ^ since `NodeToClientV_22` - | LedgerPeerSnapshotDoesntSupportSRV - deriving (Show, Eq) - -encodeLedgerPeerSnapshot :: LedgerPeerSnapshotSRVSupport -> LedgerPeerSnapshot -> Codec.Encoding -encodeLedgerPeerSnapshot LedgerPeerSnapshotDoesntSupportSRV (LedgerPeerSnapshotV2 (wOrigin, pools)) = - Codec.encodeListLen 2 - <> Codec.encodeWord8 1 -- internal version - <> Codec.encodeListLen 2 - <> encodeWithOrigin wOrigin - <> toCBOR pools' - where - pools' = - [(AccPoolStakeCoded accPoolStake, (PoolStakeCoded relStake, relays)) - | (accPoolStake, (relStake, relays)) <- - -- filter out SRV domains, not supported by `< NodeToClientV_22` - map - (second $ second $ NonEmpty.filter - (\case - LedgerRelayAccessSRVDomain {} -> False - _ -> True) - ) - pools - , not (null relays) - ] -encodeLedgerPeerSnapshot LedgerPeerSnapshotSupportsSRV (LedgerPeerSnapshotV2 (wOrigin, pools)) = - Codec.encodeListLen 2 - <> Codec.encodeWord8 1 -- internal version - <> Codec.encodeListLen 2 - <> encodeWithOrigin wOrigin - <> toCBOR pools' - where - pools' = - [(AccPoolStakeCoded accPoolStake, (PoolStakeCoded relStake, relays)) - | (accPoolStake, (relStake, relays)) <- pools - ] - -decodeLedgerPeerSnapshot :: LedgerPeerSnapshotSRVSupport -> Codec.Decoder s LedgerPeerSnapshot -decodeLedgerPeerSnapshot _ = do - Codec.decodeListLenOf 2 - version <- Codec.decodeWord8 - case version of - 1 -> LedgerPeerSnapshotV2 <$> do - Codec.decodeListLenOf 2 - wOrigin <- decodeWithOrigin - pools <- fromCBOR - let pools' = [(accStake, (relStake, relays)) - | (AccPoolStakeCoded accStake, (PoolStakeCoded relStake, relays)) <- pools - ] - return (wOrigin, pools') - _ -> fail $ "LedgerPeers.Type: no decoder could be found for version " <> show version - --- | Which ledger peers to pick. +encodeLedgerPeerSnapshotPoint :: Typeable a => Point (LedgerPeerSnapshot a) -> Codec.Encoding +encodeLedgerPeerSnapshotPoint = \case + GenesisPoint -> Codec.encodeListLen 1 <> Codec.encodeWord8 0 + BlockPoint { atSlot, withHash } -> + Codec.encodeListLen 3 <> Codec.encodeWord8 1 + <> Codec.toCBOR atSlot <> Codec.toCBOR withHash + + +decodeLedgerPeerSnapshotPoint :: Typeable a => Codec.Decoder s (Point (LedgerPeerSnapshot a)) +decodeLedgerPeerSnapshotPoint = do + listLen <- Codec.decodeListLen + tag <- Codec.decodeWord8 + case (tag, listLen) of + (0, 1) -> pure $ Point Origin + (0, n) -> fail $ "LedgerPeers.Type: invalid listLen for Origin tag, expected 1 got " <> show n + (1, 3) -> Point . At <$> (Block <$> fromCBOR <*> fromCBOR) + (1, n) -> fail $ "LedgerPeers.Type: invalid listLen for At tag, expected 3 got " <> show n + _ -> fail "LedgerPeers.Type: Unrecognized CBOR encoding of Point for LedgerPeerSnapshot" + + +encodeBigStakePools :: [(AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))] + -> Codec.Encoding +encodeBigStakePools pools = + Codec.encodeListLenIndef + <> foldMap (\(AccPoolStake accPoolStake, (PoolStake poolStake, relays)) -> + Codec.encodeListLen 3 + <> toCBOR accPoolStake + <> toCBOR poolStake + <> toCBOR relays + ) + pools + <> Codec.encodeBreak + + +decodeBigStakePools :: Codec.Decoder s [(AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))] +decodeBigStakePools = do + Codec.decodeListLenIndef + Codec.decodeSequenceLenIndef + (flip (:)) [] reverse + do + Codec.decodeListLenOf 3 + accPoolStake <- AccPoolStake <$> fromCBOR + poolStake <- PoolStake <$> fromCBOR + relays <- fromCBOR + return (accPoolStake, (poolStake, relays)) + + +encodeAllStakePools :: [(PoolStake, NonEmpty LedgerRelayAccessPoint)] + -> Codec.Encoding +encodeAllStakePools pools = + Codec.encodeListLenIndef + <> foldMap (\(PoolStake poolStake, relays) -> + Codec.encodeListLen 2 + <> toCBOR poolStake + <> toCBOR relays + ) + pools + <> Codec.encodeBreak + + +decodeAllStakePools :: Codec.Decoder s [(PoolStake, NonEmpty LedgerRelayAccessPoint)] +decodeAllStakePools = do + Codec.decodeListLenIndef + Codec.decodeSequenceLenIndef + (flip (:)) [] reverse + do + Codec.decodeListLenOf 2 + poolStake <- PoolStake <$> fromCBOR + relays <- fromCBOR + return (poolStake, relays) + + +-- | Used by functions to indicate what kind of ledger peer to process -- data LedgerPeersKind = AllLedgerPeers | BigLedgerPeers - deriving Show + deriving (Eq, Show) + -- | Only use the ledger after the given slot number. +-- data UseLedgerPeers = DontUseLedgerPeers | UseLedgerPeers AfterSlot deriving (Eq, Show, Generic, NoThunks) -- | Only use the ledger after the given slot number. +-- data AfterSlot = Always | After SlotNo deriving (Eq, Show, Generic) @@ -258,25 +414,24 @@ isLedgerPeersEnabled :: UseLedgerPeers -> Bool isLedgerPeersEnabled DontUseLedgerPeers = False isLedgerPeersEnabled UseLedgerPeers {} = True + -- | The relative stake of a stakepool in relation to the total amount staked. -- A value in the [0, 1] range. -- newtype PoolStake = PoolStake { unPoolStake :: Rational } deriving (Eq, Ord, Show) - deriving newtype (Fractional, Num, NFData) + deriving newtype (Fractional, Num, NFData, FromJSON, ToJSON, ToCBOR, FromCBOR) + -- the ToCBOR and FromCBOR instances can be removed once V22 is no longer supported -newtype PoolStakeCoded = PoolStakeCoded { unPoolStakeCoded :: PoolStake } - deriving (ToCBOR, FromCBOR, FromJSON, ToJSON) via Rational -- | The accumulated relative stake of a stake pool, like PoolStake but it also includes the -- relative stake of all preceding pools. A value in the range [0, 1]. -- newtype AccPoolStake = AccPoolStake { unAccPoolStake :: Rational } - deriving (Eq, Ord, Show) - deriving newtype (Fractional, Num) + deriving (Eq, Ord, Show) + deriving newtype (Fractional, Num, NFData, FromJSON, ToJSON, FromCBOR, ToCBOR) + -- the ToCBOR and FromCBOR instances can be removed once V22 is no longer supported -newtype AccPoolStakeCoded = AccPoolStakeCoded { unAccPoolStakeCoded :: AccPoolStake } - deriving (ToCBOR, FromCBOR, FromJSON, ToJSON) via Rational -- | Identifies a peer as coming from ledger or not. data IsLedgerPeer = IsLedgerPeer diff --git a/ouroboros-network/api/lib/Ouroboros/Network/PeerSelection/LedgerPeers/Utils.hs b/ouroboros-network/api/lib/Ouroboros/Network/PeerSelection/LedgerPeers/Utils.hs index 3cf28aa7f10..5d3f7894872 100644 --- a/ouroboros-network/api/lib/Ouroboros/Network/PeerSelection/LedgerPeers/Utils.hs +++ b/ouroboros-network/api/lib/Ouroboros/Network/PeerSelection/LedgerPeers/Utils.hs @@ -20,7 +20,8 @@ import Data.Ratio ((%)) import Ouroboros.Network.PeerSelection.LedgerPeers.Type --- | The total accumulated stake of big ledger peers. +-- | Big ledger peers are those ledger peers, which when sorted down by their +-- relative stake, in the aggregate hold 90% of the total stake in the network. -- bigLedgerPeerQuota :: AccPoolStake bigLedgerPeerQuota = 0.9 diff --git a/ouroboros-network/api/lib/Ouroboros/Network/Point.hs b/ouroboros-network/api/lib/Ouroboros/Network/Point.hs index 8f09b55cec1..cd49f242a8a 100644 --- a/ouroboros-network/api/lib/Ouroboros/Network/Point.hs +++ b/ouroboros-network/api/lib/Ouroboros/Network/Point.hs @@ -16,6 +16,7 @@ module Ouroboros.Network.Point , withOriginFromMaybe ) where +import Data.Aeson import GHC.Generics (Generic) import NoThunks.Class (NoThunks) @@ -25,7 +26,7 @@ data Block slot hash = Block { blockPointSlot :: !slot , blockPointHash :: !hash } - deriving (Eq, Ord, Show, Generic, NoThunks) + deriving (Eq, Ord, Show, ToJSON, FromJSON, Generic, NoThunks) block :: slot -> hash -> WithOrigin (Block slot hash) block slot hash = at (Block slot hash) diff --git a/ouroboros-network/changelog.d/20251028_160648_crocodile-dentist_ledgerpeersnapshot_hash.md b/ouroboros-network/changelog.d/20251028_160648_crocodile-dentist_ledgerpeersnapshot_hash.md new file mode 100644 index 00000000000..d064b8de6f3 --- /dev/null +++ b/ouroboros-network/changelog.d/20251028_160648_crocodile-dentist_ledgerpeersnapshot_hash.md @@ -0,0 +1,23 @@ + + +### Breaking + +o-n-api: +- Added tag `LedgerPeerSnapshotV3` +- removed compareLedgerPeerSnapshotApproximate + +### Non-Breaking + +o-n-api: +- Added {To,From}JSON instances to `Point` and `Block` +- added {encode,decode}LedgerPeerSnapshotPoint +- added {encode,decode}StakePools + +o-n: +- Removed cardano-slotting dependency +- moved `jobVerifyPeerSnapshot` to cardano-diffusion diff --git a/ouroboros-network/lib/Ouroboros/Network/BlockFetch/Decision/Genesis.hs b/ouroboros-network/lib/Ouroboros/Network/BlockFetch/Decision/Genesis.hs index 4071a5d6fe3..19566c7e6d5 100644 --- a/ouroboros-network/lib/Ouroboros/Network/BlockFetch/Decision/Genesis.hs +++ b/ouroboros-network/lib/Ouroboros/Network/BlockFetch/Decision/Genesis.hs @@ -149,10 +149,9 @@ import Ouroboros.Network.BlockFetch.ClientState (FetchRequest (..), import Ouroboros.Network.BlockFetch.ConsensusInterface (ChainComparison(..), ChainSelStarvation (..), FetchMode (..)) import Ouroboros.Network.BlockFetch.DeltaQ (calculatePeerFetchInFlightLimits) - -import Cardano.Slotting.Slot (WithOrigin) import Ouroboros.Network.BlockFetch.Decision import Ouroboros.Network.BlockFetch.Decision.Trace (TraceDecisionEvent (..)) +import Ouroboros.Network.Point (WithOrigin) type WithDeclined peer = Writer (DList (FetchDecline, peer)) diff --git a/ouroboros-network/lib/Ouroboros/Network/Diffusion/Types.hs b/ouroboros-network/lib/Ouroboros/Network/Diffusion/Types.hs index cca8c7912dd..40ab961efc3 100644 --- a/ouroboros-network/lib/Ouroboros/Network/Diffusion/Types.hs +++ b/ouroboros-network/lib/Ouroboros/Network/Diffusion/Types.hs @@ -473,7 +473,7 @@ data Configuration extraFlags m ntnFd ntnAddr ntcFd ntcAddr = Configuration { -- These peers may be selected by ledgerPeersThread when requested -- by the peer selection governor when the node is syncing up. -- This is especially useful for Genesis consensus mode. - , dcReadLedgerPeerSnapshot :: STM m (Maybe LedgerPeerSnapshot) + , dcReadLedgerPeerSnapshot :: STM m (Maybe (LedgerPeerSnapshot BigLedgerPeers)) -- | `UseLedgerPeers` from topology file. -- diff --git a/ouroboros-network/lib/Ouroboros/Network/PeerSelection/Governor/Monitor.hs b/ouroboros-network/lib/Ouroboros/Network/PeerSelection/Governor/Monitor.hs index 875cfef0128..61b0f865bce 100644 --- a/ouroboros-network/lib/Ouroboros/Network/PeerSelection/Governor/Monitor.hs +++ b/ouroboros-network/lib/Ouroboros/Network/PeerSelection/Governor/Monitor.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE GADTs #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -11,7 +12,6 @@ module Ouroboros.Network.PeerSelection.Governor.Monitor ( targetPeers , jobs - , jobVerifyPeerSnapshot , connections , localRoots , ledgerPeerSnapshotChange @@ -23,7 +23,7 @@ import Data.Maybe (fromMaybe, isJust) import Data.Set (Set) import Data.Set qualified as Set -import Control.Concurrent.JobPool (Job (..), JobPool) +import Control.Concurrent.JobPool (JobPool) import Control.Concurrent.JobPool qualified as JobPool import Control.Exception (assert) import Control.Monad.Class.MonadSTM @@ -38,11 +38,7 @@ import Ouroboros.Network.PeerSelection.Governor.ActivePeers import Ouroboros.Network.PeerSelection.Governor.Types hiding (PeerSelectionCounters) import Ouroboros.Network.PeerSelection.LedgerPeers.Type - (LedgerPeerSnapshot (..), LedgerPeersConsensusInterface (..), - SRVPrefix, compareLedgerPeerSnapshotApproximate, - getRelayAccessPointsFromLedger, - getRelayAccessPointsFromLedgerPeerSnapshot) -import Ouroboros.Network.PeerSelection.LedgerPeers.Utils + (LedgerPeerSnapshot (..)) import Ouroboros.Network.PeerSelection.PublicRootPeers qualified as PublicRootPeers import Ouroboros.Network.PeerSelection.State.EstablishedPeers qualified as EstablishedPeers import Ouroboros.Network.PeerSelection.State.KnownPeers qualified as KnownPeers @@ -409,38 +405,6 @@ localRoots actions@PeerSelectionActions{ readLocalRootPeers | (peeraddr, peerconn) <- Map.assocs selectedToDemote' ] } --- |This job, which is initiated by monitorLedgerStateJudgement job, --- verifies whether the provided big ledger pools match up with the --- ledger state once the node catches up to the slot at which the --- snapshot was ostensibly taken --- -jobVerifyPeerSnapshot :: MonadSTM m - => SRVPrefix - -> LedgerPeerSnapshot - -> LedgerPeersConsensusInterface extraAPI m - -> Job () m (Completion m extraState extraDebugState extraFlags extraPeers extraTrace peeraddr peerconn) -jobVerifyPeerSnapshot srvPrefix - ledgerPeerSnapshot - ledgerCtx@LedgerPeersConsensusInterface { lpGetLatestSlot } - = Job job (const (completion False)) () "jobVerifyPeerSnapshot" - where - (slot, snapshotPeers) = - getRelayAccessPointsFromLedgerPeerSnapshot srvPrefix ledgerPeerSnapshot - - completion result = return . Completion $ \st _now -> - Decision { - decisionTrace = [TraceVerifyPeerSnapshot result], - decisionState = st, - decisionJobs = [] } - - job = do - ledgerPeers <- - atomically $ do - check . (>= slot) =<< lpGetLatestSlot - accumulateBigLedgerStake <$> getRelayAccessPointsFromLedger srvPrefix ledgerCtx - completion $ snapshotPeers - `compareLedgerPeerSnapshotApproximate` - ledgerPeers -- |This job monitors for any changes in the big ledger peer snapshot -- and flips ledger state judgement private state so that monitoring action @@ -463,8 +427,9 @@ ledgerPeerSnapshotChange extraStateChange ledgerPeerSnapshot' <- readLedgerPeerSnapshot case (ledgerPeerSnapshot', ledgerPeerSnapshot) of (Nothing, _) -> retry - (Just (LedgerPeerSnapshot (slot, _)), Just (LedgerPeerSnapshot (slot', _))) - | slot == slot' -> retry + (Just (LedgerBigPeerSnapshotV23 point _magic _pools), + Just (LedgerBigPeerSnapshotV23 point' _magic' _pools')) + | point == point' -> retry _otherwise -> return $ \_now -> Decision { decisionTrace = [], diff --git a/ouroboros-network/lib/Ouroboros/Network/PeerSelection/Governor/Types.hs b/ouroboros-network/lib/Ouroboros/Network/PeerSelection/Governor/Types.hs index be3d925f5bb..4fa65dbb288 100644 --- a/ouroboros-network/lib/Ouroboros/Network/PeerSelection/Governor/Types.hs +++ b/ouroboros-network/lib/Ouroboros/Network/PeerSelection/Governor/Types.hs @@ -1,5 +1,6 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} @@ -9,6 +10,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} #if __GLASGOW_HASKELL__ < 904 @@ -70,6 +72,11 @@ module Ouroboros.Network.PeerSelection.Governor.Types , DemotionTimeoutException (..) ) where +import Control.Applicative (Alternative) +import Control.Concurrent.Class.MonadSTM.Strict +import Control.Concurrent.JobPool (Job) +import Control.Exception (Exception (..), SomeException, assert) +import Control.Monad.Class.MonadTime.SI import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map import Data.Maybe (fromMaybe) @@ -81,12 +88,6 @@ import Data.Set qualified as Set import GHC.Stack (HasCallStack) import System.Random (StdGen) -import Control.Applicative (Alternative) -import Control.Concurrent.Class.MonadSTM.Strict -import Control.Concurrent.JobPool (Job) -import Control.Exception (Exception (..), SomeException, assert) -import Control.Monad.Class.MonadTime.SI - import Ouroboros.Network.DiffusionMode import Ouroboros.Network.ExitPolicy import Ouroboros.Network.PeerSelection.LedgerPeers.Type @@ -351,7 +352,7 @@ data PeerSelectionActions extraState extraFlags extraPeers extraAPI extraCounter -- | Read the current state of ledger peer snapshot -- - readLedgerPeerSnapshot :: STM m (Maybe LedgerPeerSnapshot) + readLedgerPeerSnapshot :: STM m (Maybe (LedgerPeerSnapshot BigLedgerPeers)) } -- | Interfaces required by the peer selection governor, which do not need to @@ -646,7 +647,7 @@ data PeerSelectionState extraState extraFlags extraPeers peeraddr peerconn = -- | Internal state of ledger peer snapshot -- - ledgerPeerSnapshot :: Maybe LedgerPeerSnapshot, + ledgerPeerSnapshot :: Maybe (LedgerPeerSnapshot BigLedgerPeers), -- | Extension point so that 3rd party users can plug their own peer -- selection state if needed diff --git a/ouroboros-network/lib/Ouroboros/Network/PeerSelection/LedgerPeers.hs b/ouroboros-network/lib/Ouroboros/Network/PeerSelection/LedgerPeers.hs index 17141285f20..371d98d77dc 100644 --- a/ouroboros-network/lib/Ouroboros/Network/PeerSelection/LedgerPeers.hs +++ b/ouroboros-network/lib/Ouroboros/Network/PeerSelection/LedgerPeers.hs @@ -1,5 +1,6 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} @@ -36,9 +37,11 @@ module Ouroboros.Network.PeerSelection.LedgerPeers , resolveLedgerPeers ) where +import Control.Concurrent.Class.MonadSTM.Strict import Control.Monad (when) import Control.Monad.Class.MonadAsync import Control.Monad.Class.MonadFork +import Control.Monad.Class.MonadThrow import Control.Monad.Class.MonadTime.SI import Control.Tracer (Tracer, traceWith) import Data.IP qualified as IP @@ -49,22 +52,21 @@ import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map import Data.Maybe (isJust) import Data.Ratio -import System.Random -import Text.Printf - -import Cardano.Slotting.Slot (SlotNo (..), WithOrigin (..)) -import Control.Concurrent.Class.MonadSTM.Strict -import Control.Monad.Class.MonadThrow import Data.Set (Set) import Data.Set qualified as Set import Data.Void (Void) import Data.Word (Word16, Word64) import Network.DNS qualified as DNS +import System.Random +import Text.Printf + +import Ouroboros.Network.Block (SlotNo) import Ouroboros.Network.PeerSelection.LedgerPeers.Type import Ouroboros.Network.PeerSelection.LedgerPeers.Utils (accumulateBigLedgerStake, bigLedgerPeerQuota, recomputeRelativeStake) import Ouroboros.Network.PeerSelection.RootPeersDNS +import Ouroboros.Network.Point (WithOrigin (..)) -- | Ledger Peer request result -- @@ -380,7 +382,7 @@ ledgerPeersThread PeerActionsDNS { data StakeMapOverSource = StakeMapOverSource { ledgerWithOrigin :: WithOrigin SlotNo, ledgerPeers :: LedgerPeers, - peerSnapshot :: Maybe LedgerPeerSnapshot, + peerSnapshot :: Maybe (LedgerPeerSnapshot BigLedgerPeers), cachedSlot :: Maybe SlotNo, peerMap :: Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint), bigPeerMap :: Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint), @@ -411,7 +413,7 @@ stakeMapWithSlotOverSource StakeMapOverSource { -- check if we can use the snapshot first (ledgerSlotNo, _, Just ledgerPeerSnapshot) | (At snapshotSlotNo, snapshotRelays) - <- getRelayAccessPointsFromLedgerPeerSnapshot srvPrefix ledgerPeerSnapshot + <- getRelayAccessPointsFromBigLedgerPeersSnapshot srvPrefix ledgerPeerSnapshot , snapshotSlotNo >= ledgerSlotNo' , snapshotSlotNo >= useLedgerAfter' -> -- we cache the peers from the snapshot @@ -447,7 +449,7 @@ data WithLedgerPeersArgs extraAPI m = WithLedgerPeersArgs { -- ^ Get Ledger Peers comes from here wlpGetUseLedgerPeers :: STM m UseLedgerPeers, -- ^ Get Use Ledger After value - wlpGetLedgerPeerSnapshot :: STM m (Maybe LedgerPeerSnapshot), + wlpGetLedgerPeerSnapshot :: STM m (Maybe (LedgerPeerSnapshot BigLedgerPeers)), -- ^ Get ledger peer snapshot from file read by node wlpSemaphore :: DNSSemaphore m, wlpSRVPrefix :: SRVPrefix diff --git a/ouroboros-network/lib/Ouroboros/Network/PeerSelection/PeerMetric.hs b/ouroboros-network/lib/Ouroboros/Network/PeerSelection/PeerMetric.hs index fdafe499f4f..6eb33a5f6ca 100644 --- a/ouroboros-network/lib/Ouroboros/Network/PeerSelection/PeerMetric.hs +++ b/ouroboros-network/lib/Ouroboros/Network/PeerSelection/PeerMetric.hs @@ -50,7 +50,7 @@ import GHC.Generics import NoThunks.Class import NoThunks.Class.Orphans () -import Cardano.Slotting.Slot (SlotNo (..)) +import Ouroboros.Network.Block (SlotNo (..)) import Ouroboros.Network.ConnectionId (ConnectionId (..)) import Ouroboros.Network.DeltaQ (SizeInBytes) import Ouroboros.Network.PeerSelection.PeerMetric.Type diff --git a/ouroboros-network/ouroboros-network.cabal b/ouroboros-network/ouroboros-network.cabal index fa18938acb1..96f2f83481b 100644 --- a/ouroboros-network/ouroboros-network.cabal +++ b/ouroboros-network/ouroboros-network.cabal @@ -93,6 +93,7 @@ library api base16-bytestring, bytestring >=0.10 && <0.13, cardano-binary, + cardano-crypto-class, cardano-slotting, cardano-strict-containers, cborg >=0.2.1 && <0.3, @@ -283,7 +284,6 @@ library base >=4.14 && <4.22, bytestring >=0.10 && <0.13, cardano-prelude, - cardano-slotting, cardano-strict-containers >=0.1.4, cborg >=0.2.1 && <0.3, containers, @@ -826,8 +826,9 @@ library ouroboros-network-tests-lib aeson, array, base >=4.14 && <4.22, + binary, bytestring, - cardano-slotting, + cardano-crypto-class, cardano-strict-containers, cborg, containers, diff --git a/ouroboros-network/tests/lib/Test/Ouroboros/Network/LedgerPeers.hs b/ouroboros-network/tests/lib/Test/Ouroboros/Network/LedgerPeers.hs index 9bedaa6b23f..7ec202237e3 100644 --- a/ouroboros-network/tests/lib/Test/Ouroboros/Network/LedgerPeers.hs +++ b/ouroboros-network/tests/lib/Test/Ouroboros/Network/LedgerPeers.hs @@ -1,9 +1,12 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingVia #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -26,6 +29,7 @@ import Control.Monad.IOSim hiding (SimResult) import Control.Tracer (Tracer (..), nullTracer, traceWith) import Data.Aeson import Data.Aeson.Types as Aeson +import Data.Binary as Binary (encode) import Data.ByteString.Char8 qualified as BS import Data.IP qualified as IP import Data.List as List (foldl', intercalate, isPrefixOf, nub, sortOn) @@ -42,11 +46,14 @@ import System.Random import Network.DNS (Domain) -import Cardano.Slotting.Slot (SlotNo (..), WithOrigin (..)) +import Cardano.Crypto.Hash.Class (hashWith) +import Ouroboros.Network.Block +import Ouroboros.Network.Magic import Ouroboros.Network.PeerSelection.LedgerPeers import Ouroboros.Network.PeerSelection.LedgerPeers.Utils (recomputeRelativeStake) import Ouroboros.Network.PeerSelection.RootPeersDNS +import Ouroboros.Network.Point (WithOrigin (..)) import Test.Ouroboros.Network.Data.Script import Test.Ouroboros.Network.PeerSelection.RootPeersDNS @@ -63,7 +70,8 @@ tests = testGroup "Ouroboros.Network.LedgerPeers" , testProperty "recomputeRelativeStake" prop_recomputeRelativeStake , testProperty "getLedgerPeers invariants" prop_getLedgerPeers , testProperty "LedgerPeerSnapshot CBOR version 2" prop_ledgerPeerSnapshotCBORV2 - , testProperty "LedgerPeerSnapshot JSON version 2" prop_ledgerPeerSnapshotJSONV2 + , testProperty "LedgerPeerSnapshot CBOR version 3" prop_ledgerPeerSnapshotCBORV3 + , testProperty "LedgerPeerSnapshot JSON version 2/3" prop_ledgerPeerSnapshotJSON ] type ExtraTestInterface = () @@ -209,8 +217,10 @@ prop_ledgerPeerSnapshot_requests bigPoolRelays = fmap (snd . snd) . Map.toList $ bigPoolMap poolRelays = fmap (snd . snd) . Map.toList $ poolMap in case (ledgerWithOrigin, ledgerPeers, peerSnapshot) of - (At t, LedgerPeers ledgerPools, Just (LedgerPeerSnapshot (At t', snapshotAccStake))) - | t' >= t -> + (At t, + LedgerPeers ledgerPools, + Just (LedgerBigPeerSnapshotV23 BlockPoint { atSlot } _magic snapshotAccStake)) + | atSlot >= t -> snapshotRelays === bigPoolRelays .&&. bigPoolRelays === poolRelays | otherwise -> bigPoolRelays === ledgerBigPoolRelays @@ -228,12 +238,14 @@ prop_ledgerPeerSnapshot_requests ledgerBigPoolRelays = fmap (snd . snd) (accumulateBigLedgerStake ledgerPools) ledgerRelays = fmap (snd . snd) . Map.toList $ accPoolStake ledgerPools - (_, _, Just (LedgerPeerSnapshot (At t', snapshotAccStake))) - | After slot <- useLedgerAfter, t' >= slot -> + (_, _, Just (LedgerBigPeerSnapshotV23 BlockPoint { atSlot } _magic snapshotAccStake)) + | After slot <- useLedgerAfter, atSlot >= slot -> snapshotRelays === bigPoolRelays .&&. bigPoolRelays === poolRelays where snapshotRelays :: [NonEmpty RelayAccessPoint] - snapshotRelays = fmap (fmap (prefixLedgerRelayAccessPoint cardanoSRVPrefix) . snd . snd) snapshotAccStake + snapshotRelays = + fmap (fmap (prefixLedgerRelayAccessPoint cardanoSRVPrefix) . snd . snd) + snapshotAccStake _otherwise -> bigPoolRelays === [] .&&. poolRelays === [] @@ -511,59 +523,108 @@ prop_ledgerPeerSnapshotCBORV2 :: LedgerPeerSnapshotSRVSupport -> Property prop_ledgerPeerSnapshotCBORV2 srvSupport slotNo ledgerPools = - counterexample (show snapshot) $ + counterexample (show someSnapshot) $ counterexample ("Invalid CBOR encoding" <> show encoded) (validFlatTerm encoded) .&&. either ((`counterexample` False) . ("CBOR decode failed: " <>)) (counterexample . ("CBOR round trip failed: " <>) . show <*> (result ==)) decoded where - snapshot = snapshotV2 slotNo ledgerPools - encoded = toFlatTerm . encodeLedgerPeerSnapshot srvSupport $ snapshot - decoded = fromFlatTerm (decodeLedgerPeerSnapshot srvSupport) encoded - - result = case srvSupport of - LedgerPeerSnapshotSupportsSRV -> snapshot - LedgerPeerSnapshotDoesntSupportSRV -> - -- filter out SRV records - LedgerPeerSnapshotV2 - ( slotNo' - , [ (accStake, (stake, NonEmpty.fromList relays')) - | (accStake, (stake, relays)) <- peers - , let relays' = NonEmpty.filter - (\case - LedgerRelayAccessSRVDomain {} -> False - _ -> True - ) - relays - , not (null relays') - ] - ) - where - LedgerPeerSnapshotV2 (slotNo', peers) = snapshot + someSnapshot = snapshotV2 slotNo ledgerPools + encoded = toFlatTerm . encodeLedgerPeerSnapshot' srvSupport $ someSnapshot + decoded = unwrap <$> fromFlatTerm decodeLedgerPeerSnapshot encoded + unwrap :: SomeLedgerPeerSnapshot -> LedgerPeerSnapshot BigLedgerPeers + unwrap = \case + SomeLedgerPeerSnapshot lps@LedgerPeerSnapshotV2{} -> lps + _otherwise -> error "impossible" + + result = case someSnapshot of + SomeLedgerPeerSnapshot lps@(LedgerPeerSnapshotV2 (slotNo', peers)) -> + case srvSupport of + LedgerPeerSnapshotSupportsSRV -> lps + LedgerPeerSnapshotDoesntSupportSRV -> + LedgerPeerSnapshotV2 + ( slotNo' + , [ (accStake, (stake, NonEmpty.fromList relays')) + | (accStake, (stake, relays)) <- peers + , let relays' = NonEmpty.filter + (\case + LedgerRelayAccessSRVDomain {} -> False + _ -> True + ) + relays + , not (null relays') + ] + ) + _otherwise -> error "impossible" + + +-- TODO: move to `ouroboros-network-api:test` +prop_ledgerPeerSnapshotCBORV3 :: SlotNo -> Word32 -> LedgerPools -> Bool -> Property +prop_ledgerPeerSnapshotCBORV3 slotNo magic ledgerPools big = + counterexample (show someSnapshot) $ + counterexample ("Invalid CBOR encoding" <> show encoded) + (validFlatTerm encoded) + .&&. either ((`counterexample` False) . ("CBOR decode failed: " <>)) + (counterexample . ("CBOR round trip failed: " <>) . show <*> cmp) + decoded + where + someSnapshot = snapshotV3 slotNo (NetworkMagic magic) ledgerPools big + encoded = toFlatTerm . encodeLedgerPeerSnapshot' LedgerPeerSnapshotSupportsSRV $ someSnapshot + decoded = fromFlatTerm decodeLedgerPeerSnapshot encoded + cmp decoded' = case (someSnapshot, decoded') of + (SomeLedgerPeerSnapshot someSnapshot', + SomeLedgerPeerSnapshot decoded'')-> case (someSnapshot', decoded'') of + (lps@LedgerBigPeerSnapshotV23{}, lps'@LedgerBigPeerSnapshotV23{}) -> lps == lps' + (lps@LedgerAllPeerSnapshotV23{}, lps'@LedgerAllPeerSnapshotV23{}) -> lps == lps' + _otherwise -> False + -- | Tests if LedgerPeerSnapshot JSON round trip is the identity function -- -- TODO: move to `ouroboros-network-api:test` -prop_ledgerPeerSnapshotJSONV2 :: SlotNo - -> LedgerPools - -> Property -prop_ledgerPeerSnapshotJSONV2 slotNo - ledgerPools = - counterexample (show snapshot) $ - either ((`counterexample` False) . ("JSON decode failed: " <>)) - (counterexample . ("JSON round trip failed: " <>) . show <*> nearlyEqualModuloFullyQualified snapshot) - roundTrip +prop_ledgerPeerSnapshotJSON :: SlotNo + -> (Bool, Bool) + -> Word32 + -> LedgerPools + -> Property +prop_ledgerPeerSnapshotJSON slotNo (v3, big) pureMagic ledgerPools = + counterexample (show someSnapshot) $ + either ((`counterexample` False) . renderMsg) + ( counterexample . ("JSON round trip failed: " <>) . show + <*> nearlyEqualModuloFullyQualified someSnapshot) + someRoundTrip where - snapshot = snapshotV2 slotNo ledgerPools - roundTrip = case fromJSON . toJSON $ snapshot of - Aeson.Success s -> Right s - Error str -> Left str - - nearlyEqualModuloFullyQualified snapshotOriginal snapshotRoundTripped = - let LedgerPeerSnapshotV2 (wOrigin, relaysWithAccStake) = snapshotOriginal - strippedRelaysWithAccStake = stripFQN <$> relaysWithAccStake - LedgerPeerSnapshotV2 (wOrigin', relaysWithAccStake') = snapshotRoundTripped + renderMsg msg = mconcat ["JSON decode failed: " + , show msg + , "\nNB. JSON encoding: ", show $ case someSnapshot of + SomeLedgerPeerSnapshot lps -> toJSON lps + ] + + someSnapshot = + if v3 + then snapshotV3 slotNo (NetworkMagic pureMagic) ledgerPools big + else snapshotV2 slotNo ledgerPools + + jsonResult = case someSnapshot of + SomeLedgerPeerSnapshot lps -> case lps of + lps'@LedgerBigPeerSnapshotV23{} -> + SomeLedgerPeerSnapshot <$> (fromJSON @(LedgerPeerSnapshot BigLedgerPeers) . toJSON $ lps') + lps'@LedgerAllPeerSnapshotV23{} -> + SomeLedgerPeerSnapshot <$> (fromJSON @(LedgerPeerSnapshot AllLedgerPeers) . toJSON $ lps') + lps'@LedgerPeerSnapshotV2{} -> + SomeLedgerPeerSnapshot <$> (fromJSON @(LedgerPeerSnapshot BigLedgerPeers) . toJSON $ lps') + + someRoundTrip = case jsonResult of + Aeson.Success s -> Right $ s + Error str -> Left str + + nearlyEqualModuloFullyQualified :: SomeLedgerPeerSnapshot -> SomeLedgerPeerSnapshot -> Property + nearlyEqualModuloFullyQualified (SomeLedgerPeerSnapshot + (LedgerPeerSnapshotV2 (wOrigin, relaysWithAccStake))) + (SomeLedgerPeerSnapshot + (LedgerPeerSnapshotV2 (wOrigin', relaysWithAccStake'))) = + let strippedRelaysWithAccStake = stripFQN <$> relaysWithAccStake strippedRelaysWithAccStake' = stripFQN <$> relaysWithAccStake' in wOrigin === wOrigin' @@ -572,6 +633,34 @@ prop_ledgerPeerSnapshotJSONV2 slotNo .&&. counterexample "approximation error" (compareApprox relaysWithAccStake relaysWithAccStake') + nearlyEqualModuloFullyQualified (SomeLedgerPeerSnapshot + (LedgerBigPeerSnapshotV23 point magic relaysWithAccStake)) + (SomeLedgerPeerSnapshot + (LedgerBigPeerSnapshotV23 point' magic' relaysWithAccStake')) = + let strippedRelaysWithAccStake = stripFQN <$> relaysWithAccStake + strippedRelaysWithAccStake' = stripFQN <$> relaysWithAccStake' + in + point === point' + .&&. magic === magic' + .&&. counterexample "fully qualified name" + (strippedRelaysWithAccStake === strippedRelaysWithAccStake') + .&&. counterexample "approximation error" + (compareApprox relaysWithAccStake relaysWithAccStake') + + nearlyEqualModuloFullyQualified (SomeLedgerPeerSnapshot + (LedgerAllPeerSnapshotV23 point magic relays)) + (SomeLedgerPeerSnapshot + (LedgerAllPeerSnapshotV23 point' magic' relays')) = + let strippedRelays = stripFQN <$> zip (repeat (0 :: Int)) relays + strippedRelays' = stripFQN <$> zip (repeat (0 :: Int)) relays' + in + point === point' + .&&. magic === magic' + .&&. counterexample "fully qualified name" + (strippedRelays === strippedRelays') + + nearlyEqualModuloFullyQualified _ _ = property False + stripFQN (_, (_, relays)) = step <$> relays step it@(LedgerRelayAccessDomain domain port) = case BS.unsnoc domain of @@ -601,15 +690,32 @@ prop_ledgerPeerSnapshotJSONV2 slotNo -- snapshotV2 :: SlotNo -> LedgerPools - -> LedgerPeerSnapshot + -> SomeLedgerPeerSnapshot snapshotV2 slot - (LedgerPools pools) = LedgerPeerSnapshotV2 (originOrSlot, poolStakeWithAccumulation) + (LedgerPools pools) = + SomeLedgerPeerSnapshot $ LedgerPeerSnapshotV2 (originOrSlot, poolStakeWithAccumulation) where poolStakeWithAccumulation = Map.assocs . accPoolStake $ pools originOrSlot = if slot == 0 then Origin else At slot +snapshotV3 :: SlotNo -> NetworkMagic -> LedgerPools -> Bool -> SomeLedgerPeerSnapshot +snapshotV3 slotNo magic (LedgerPools pools) big = snapshot + where + snapshot = + if big + then let point = BlockPoint slotNo hash + bigPools = Map.assocs . accPoolStake $ pools + lps = LedgerBigPeerSnapshotV23 point magic bigPools + hash = hashWith (BS.toStrict . Binary.encode . const (unSlotNo slotNo)) lps + in SomeLedgerPeerSnapshot lps + else let point = BlockPoint slotNo hash + lps = LedgerAllPeerSnapshotV23 point magic pools + hash = hashWith (BS.toStrict . Binary.encode . const (unSlotNo slotNo)) lps + in SomeLedgerPeerSnapshot lps + + -- TODO: Belongs in iosim. data SimResult a = SimReturn a [String] | SimException SomeException [String] diff --git a/ouroboros-network/tests/lib/Test/Ouroboros/Network/PeerSelection/Instances.hs b/ouroboros-network/tests/lib/Test/Ouroboros/Network/PeerSelection/Instances.hs index f1896197a3d..db60c6db3c6 100644 --- a/ouroboros-network/tests/lib/Test/Ouroboros/Network/PeerSelection/Instances.hs +++ b/ouroboros-network/tests/lib/Test/Ouroboros/Network/PeerSelection/Instances.hs @@ -24,11 +24,9 @@ import Data.Hashable import Data.IP qualified as IP import Data.Word (Word16, Word32, Word64) -import Cardano.Slotting.Slot (SlotNo (..)) - +import Ouroboros.Network.Block (SlotNo (..)) import Ouroboros.Network.DiffusionMode import Ouroboros.Network.PeerSelection.Governor - import Ouroboros.Network.PeerSelection.LedgerPeers.Type (AfterSlot (..), UseLedgerPeers (..)) import Ouroboros.Network.PeerSelection.PeerAdvertise (PeerAdvertise (..)) diff --git a/ouroboros-network/tests/lib/Test/Ouroboros/Network/PeerSelection/PeerMetric.hs b/ouroboros-network/tests/lib/Test/Ouroboros/Network/PeerSelection/PeerMetric.hs index 297b9b02074..fa9ec6f75ef 100644 --- a/ouroboros-network/tests/lib/Test/Ouroboros/Network/PeerSelection/PeerMetric.hs +++ b/ouroboros-network/tests/lib/Test/Ouroboros/Network/PeerSelection/PeerMetric.hs @@ -33,6 +33,7 @@ import GHC.Generics import Network.Mux.Trace (TraceLabelPeer (..)) +import Ouroboros.Network.Block (SlotNo (..)) import Ouroboros.Network.ConnectionId import Ouroboros.Network.PeerSelection.PeerMetric (PeerMetrics, PeerMetricsConfiguration (..), ReportPeerMetrics (..), @@ -40,7 +41,6 @@ import Ouroboros.Network.PeerSelection.PeerMetric (PeerMetrics, reportMetric, upstreamyness) import Ouroboros.Network.SizeInBytes -import Cardano.Slotting.Slot (SlotNo (..)) import Control.Monad.IOSim