From 225a16ed5db08123064c2d03bdeac111b056c4ea Mon Sep 17 00:00:00 2001 From: Thomas Winant Date: Mon, 24 Aug 2020 15:23:30 +0200 Subject: [PATCH] LedgerSupportsPeerSelection: return peers registered in ledger state Fixes #2535. For Shelley, this returns the stake pool relays ordered by descending stake. --- .../Consensus/Byron/Ledger/Ledger.hs | 4 ++ .../Ouroboros/Consensus/Mock/Ledger/Block.hs | 4 ++ .../ouroboros-consensus-shelley.cabal | 1 + .../src/Ouroboros/Consensus/Shelley/Ledger.hs | 1 + .../Consensus/Shelley/Ledger/PeerSelection.hs | 55 +++++++++++++++++++ .../Test/Consensus/HardFork/Combinator/A.hs | 4 ++ .../Test/Consensus/HardFork/Combinator/B.hs | 4 ++ ouroboros-consensus/ouroboros-consensus.cabal | 2 + .../Consensus/HardFork/Combinator.hs | 4 ++ .../Combinator/Abstract/SingleEraBlock.hs | 2 + .../Combinator/Ledger/PeerSelection.hs | 18 ++++++ .../src/Ouroboros/Consensus/Ledger/Dual.hs | 10 ++++ .../Consensus/Ledger/SupportsPeerSelection.hs | 21 +++++++ .../src/Ouroboros/Consensus/Node/Run.hs | 2 + .../src/Ouroboros/Consensus/NodeKernel.hs | 17 ++++++ .../Network/PeerSelection/RootPeersDNS.hs | 3 + 16 files changed, 152 insertions(+) create mode 100644 ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/PeerSelection.hs create mode 100644 ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Ledger/PeerSelection.hs create mode 100644 ouroboros-consensus/src/Ouroboros/Consensus/Ledger/SupportsPeerSelection.hs diff --git a/ouroboros-consensus-byron/src/Ouroboros/Consensus/Byron/Ledger/Ledger.hs b/ouroboros-consensus-byron/src/Ouroboros/Consensus/Byron/Ledger/Ledger.hs index 47690e22be7..68de41cca5d 100644 --- a/ouroboros-consensus-byron/src/Ouroboros/Consensus/Byron/Ledger/Ledger.hs +++ b/ouroboros-consensus-byron/src/Ouroboros/Consensus/Byron/Ledger/Ledger.hs @@ -72,6 +72,7 @@ import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.CommonProtocolParams import Ouroboros.Consensus.Ledger.Extended import qualified Ouroboros.Consensus.Ledger.History as History +import Ouroboros.Consensus.Ledger.SupportsPeerSelection import Ouroboros.Consensus.Ledger.SupportsProtocol import Ouroboros.Consensus.Protocol.PBFT import Ouroboros.Consensus.Util (ShowProxy (..)) @@ -188,6 +189,9 @@ instance ShowQuery (Query ByronBlock) where instance ShowProxy (Query ByronBlock) where +instance LedgerSupportsPeerSelection ByronBlock where + getPeers = const [] + instance CommonProtocolParams ByronBlock where maxHeaderSize = fromIntegral . Update.ppMaxHeaderSize . getProtocolParameters maxTxSize = fromIntegral . Update.ppMaxTxSize . getProtocolParameters diff --git a/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Ledger/Block.hs b/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Ledger/Block.hs index 026eddb55b2..90e35e02683 100644 --- a/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Ledger/Block.hs +++ b/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Ledger/Block.hs @@ -88,6 +88,7 @@ import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.CommonProtocolParams import Ouroboros.Consensus.Ledger.Inspect import Ouroboros.Consensus.Ledger.SupportsMempool +import Ouroboros.Consensus.Ledger.SupportsPeerSelection import Ouroboros.Consensus.Mock.Ledger.Address import Ouroboros.Consensus.Mock.Ledger.State import qualified Ouroboros.Consensus.Mock.Ledger.UTxO as Mock @@ -395,6 +396,9 @@ instance MockProtocolSpecific c ext => CommonProtocolParams (SimpleBlock c ext) maxHeaderSize = const 2000000 maxTxSize = const 2000000 +instance LedgerSupportsPeerSelection (SimpleBlock c ext) where + getPeers = const [] + {------------------------------------------------------------------------------- Support for the mempool -------------------------------------------------------------------------------} diff --git a/ouroboros-consensus-shelley/ouroboros-consensus-shelley.cabal b/ouroboros-consensus-shelley/ouroboros-consensus-shelley.cabal index 100302b9404..c2004ee5fbf 100644 --- a/ouroboros-consensus-shelley/ouroboros-consensus-shelley.cabal +++ b/ouroboros-consensus-shelley/ouroboros-consensus-shelley.cabal @@ -34,6 +34,7 @@ library Ouroboros.Consensus.Shelley.Ledger.Ledger Ouroboros.Consensus.Shelley.Ledger.Mempool Ouroboros.Consensus.Shelley.Ledger.NetworkProtocolVersion + Ouroboros.Consensus.Shelley.Ledger.PeerSelection Ouroboros.Consensus.Shelley.Ledger.TPraos Ouroboros.Consensus.Shelley.Node Ouroboros.Consensus.Shelley.Node.Serialisation diff --git a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger.hs b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger.hs index 99dc1d60bc9..de0d177e4b2 100644 --- a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger.hs +++ b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger.hs @@ -9,3 +9,4 @@ import Ouroboros.Consensus.Shelley.Ledger.Integrity as X import Ouroboros.Consensus.Shelley.Ledger.Ledger as X import Ouroboros.Consensus.Shelley.Ledger.Mempool as X import Ouroboros.Consensus.Shelley.Ledger.NetworkProtocolVersion as X +import Ouroboros.Consensus.Shelley.Ledger.PeerSelection as X () diff --git a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/PeerSelection.hs b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/PeerSelection.hs new file mode 100644 index 00000000000..9239c7ff853 --- /dev/null +++ b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/PeerSelection.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{-# OPTIONS_GHC -Wno-orphans #-} +module Ouroboros.Consensus.Shelley.Ledger.PeerSelection () where + +import Data.Bifunctor (second) +import Data.Foldable (toList) +import Data.List (sortOn) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Ord (Down (..)) + +import Ouroboros.Consensus.Ledger.SupportsPeerSelection + +import qualified Shelley.Spec.Ledger.Delegation.Certificates as SL +import qualified Shelley.Spec.Ledger.Keys as SL +import qualified Shelley.Spec.Ledger.LedgerState as SL +import qualified Shelley.Spec.Ledger.TxData as SL + +import Ouroboros.Consensus.Shelley.Ledger.Block +import Ouroboros.Consensus.Shelley.Ledger.Ledger + +instance LedgerSupportsPeerSelection (ShelleyBlock c) where + getPeers ShelleyLedgerState { shelleyState } = concat + [ Map.findWithDefault [] stakePool poolDomainAddresses + | stakePool <- orderByStake poolDistr + ] + where + poolDistr :: SL.PoolDistr c + poolDistr = SL.nesPd shelleyState + + -- | Sort stake pools by descending stake + orderByStake :: SL.PoolDistr c -> [SL.KeyHash 'SL.StakePool c] + orderByStake = + map fst + . sortOn (Down . snd) + . map (second SL.individualPoolStake) + . Map.toList + . SL.unPoolDistr + + -- | Note that a stake pool can have multiple registered relays + poolDomainAddresses :: Map (SL.KeyHash 'SL.StakePool c) [DomainAddress] + poolDomainAddresses = + Map.map (map relayToDomainAddress . toList . SL._poolRelays) + . SL._pParams + . SL._pstate + . SL._delegationState + . SL.esLState + . SL.nesEs + $ shelleyState + + relayToDomainAddress :: SL.StakePoolRelay -> DomainAddress + relayToDomainAddress = undefined diff --git a/ouroboros-consensus-test/test-consensus/Test/Consensus/HardFork/Combinator/A.hs b/ouroboros-consensus-test/test-consensus/Test/Consensus/HardFork/Combinator/A.hs index 0ad2bccf42f..3c198706a53 100644 --- a/ouroboros-consensus-test/test-consensus/Test/Consensus/HardFork/Combinator/A.hs +++ b/ouroboros-consensus-test/test-consensus/Test/Consensus/HardFork/Combinator/A.hs @@ -76,6 +76,7 @@ import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.CommonProtocolParams import Ouroboros.Consensus.Ledger.Inspect import Ouroboros.Consensus.Ledger.SupportsMempool +import Ouroboros.Consensus.Ledger.SupportsPeerSelection import Ouroboros.Consensus.Ledger.SupportsProtocol import Ouroboros.Consensus.Node.NetworkProtocolVersion import Ouroboros.Consensus.Node.Run @@ -367,6 +368,9 @@ instance HasNestedContent Header BlockA where instance ReconstructNestedCtxt Header BlockA -- Use defaults +instance LedgerSupportsPeerSelection BlockA where + getPeers = const [] + data UpdateA = ProposalSubmitted | ProposalStable diff --git a/ouroboros-consensus-test/test-consensus/Test/Consensus/HardFork/Combinator/B.hs b/ouroboros-consensus-test/test-consensus/Test/Consensus/HardFork/Combinator/B.hs index 1624e35daf3..0d95f31af41 100644 --- a/ouroboros-consensus-test/test-consensus/Test/Consensus/HardFork/Combinator/B.hs +++ b/ouroboros-consensus-test/test-consensus/Test/Consensus/HardFork/Combinator/B.hs @@ -65,6 +65,7 @@ import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.CommonProtocolParams import Ouroboros.Consensus.Ledger.Inspect import Ouroboros.Consensus.Ledger.SupportsMempool +import Ouroboros.Consensus.Ledger.SupportsPeerSelection import Ouroboros.Consensus.Ledger.SupportsProtocol import Ouroboros.Consensus.Node.NetworkProtocolVersion import Ouroboros.Consensus.Node.Run @@ -314,6 +315,9 @@ instance ReconstructNestedCtxt Header BlockB instance InspectLedger BlockB where -- Use defaults +instance LedgerSupportsPeerSelection BlockB where + getPeers = const [] + instance SingleEraBlock BlockB where singleEraInfo _ = SingleEraInfo "B" singleEraTransition = \_ _ _ _ -> Nothing diff --git a/ouroboros-consensus/ouroboros-consensus.cabal b/ouroboros-consensus/ouroboros-consensus.cabal index dfab9e7d5a3..6eb8f4d9cd8 100644 --- a/ouroboros-consensus/ouroboros-consensus.cabal +++ b/ouroboros-consensus/ouroboros-consensus.cabal @@ -70,6 +70,7 @@ library Ouroboros.Consensus.HardFork.Combinator.InjectTxs Ouroboros.Consensus.HardFork.Combinator.Ledger Ouroboros.Consensus.HardFork.Combinator.Ledger.CommonProtocolParams + Ouroboros.Consensus.HardFork.Combinator.Ledger.PeerSelection Ouroboros.Consensus.HardFork.Combinator.Ledger.Query Ouroboros.Consensus.HardFork.Combinator.Mempool Ouroboros.Consensus.HardFork.Combinator.Node @@ -110,6 +111,7 @@ library Ouroboros.Consensus.Ledger.History Ouroboros.Consensus.Ledger.Inspect Ouroboros.Consensus.Ledger.SupportsMempool + Ouroboros.Consensus.Ledger.SupportsPeerSelection Ouroboros.Consensus.Ledger.SupportsProtocol Ouroboros.Consensus.Mempool Ouroboros.Consensus.Mempool.API diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator.hs b/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator.hs index ee299336740..c07a8345575 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator.hs @@ -36,6 +36,10 @@ import Ouroboros.Consensus.HardFork.Combinator.Protocol as X import Ouroboros.Consensus.HardFork.Combinator.Ledger.CommonProtocolParams as X () +-- Instance for 'PeerSelection' +import Ouroboros.Consensus.HardFork.Combinator.Ledger.PeerSelection as X + () + -- Instances for 'ShowQuery' and 'QueryLedger' -- Definition of 'Query', required for serialisation code import Ouroboros.Consensus.HardFork.Combinator.Ledger.Query as X diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Abstract/SingleEraBlock.hs b/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Abstract/SingleEraBlock.hs index 5c2ebdcee8d..7d58e3221ea 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Abstract/SingleEraBlock.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Abstract/SingleEraBlock.hs @@ -32,6 +32,7 @@ import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.CommonProtocolParams import Ouroboros.Consensus.Ledger.Inspect import Ouroboros.Consensus.Ledger.SupportsMempool +import Ouroboros.Consensus.Ledger.SupportsPeerSelection import Ouroboros.Consensus.Ledger.SupportsProtocol import Ouroboros.Consensus.Storage.ChainDB.Serialisation import Ouroboros.Consensus.Util.Condense @@ -56,6 +57,7 @@ class ( LedgerSupportsProtocol blk , ConvertRawHash blk , ReconstructNestedCtxt Header blk , CommonProtocolParams blk + , LedgerSupportsPeerSelection blk -- Instances required to support testing , Eq (GenTx blk) , Eq (ApplyTxErr blk) diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Ledger/PeerSelection.hs b/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Ledger/PeerSelection.hs new file mode 100644 index 00000000000..d95591f384a --- /dev/null +++ b/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Ledger/PeerSelection.hs @@ -0,0 +1,18 @@ +{-# OPTIONS_GHC -Wno-orphans #-} +module Ouroboros.Consensus.HardFork.Combinator.Ledger.PeerSelection () where + +import Data.SOP.Strict + +import Ouroboros.Consensus.Ledger.SupportsPeerSelection + +import Ouroboros.Consensus.HardFork.Combinator.Abstract +import Ouroboros.Consensus.HardFork.Combinator.Basics +import Ouroboros.Consensus.HardFork.Combinator.Ledger () +import qualified Ouroboros.Consensus.HardFork.Combinator.State as State + +instance CanHardFork xs => LedgerSupportsPeerSelection (HardForkBlock xs) where + getPeers = + hcollapse + . hcmap proxySingle (K . getPeers) + . State.tip + . hardForkLedgerStatePerEra diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Dual.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Dual.hs index 3d9ee56db3c..b74ac6717b0 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Dual.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Dual.hs @@ -82,6 +82,7 @@ import Ouroboros.Consensus.Ledger.CommonProtocolParams import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Ledger.Inspect import Ouroboros.Consensus.Ledger.SupportsMempool +import Ouroboros.Consensus.Ledger.SupportsPeerSelection import Ouroboros.Consensus.Ledger.SupportsProtocol import Ouroboros.Consensus.Util (ShowProxy (..)) import Ouroboros.Consensus.Util.Condense @@ -696,6 +697,15 @@ instance InspectLedger m => InspectLedger (DualBlock m a) where (dualLedgerStateMain before) (dualLedgerStateMain after) + +{------------------------------------------------------------------------------- + PeerSelection +-------------------------------------------------------------------------------} + +instance LedgerSupportsPeerSelection m + => LedgerSupportsPeerSelection (DualBlock m a) where + getPeers = getPeers . dualLedgerStateMain + {------------------------------------------------------------------------------- Forging -------------------------------------------------------------------------------} diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/SupportsPeerSelection.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/SupportsPeerSelection.hs new file mode 100644 index 00000000000..038bbf4772d --- /dev/null +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/SupportsPeerSelection.hs @@ -0,0 +1,21 @@ +module Ouroboros.Consensus.Ledger.SupportsPeerSelection ( + LedgerSupportsPeerSelection (..) + -- * Re-exports for convenience + , DomainAddress (..) + , Domain + , PortNumber + ) where + +import Ouroboros.Network.PeerSelection.RootPeersDNS (Domain, + DomainAddress (..), PortNumber) + +import Ouroboros.Consensus.Ledger.Abstract (LedgerState) + +class LedgerSupportsPeerSelection blk where + -- | Return peers registered in the ledger ordered by descending some + -- /preference/. + -- + -- For example, for Shelley, this should return the stake pool relays that + -- have been registered. The /preference/ should be the /stake/, i.e., the + -- stake pools with the most stake will come first in the list. + getPeers :: LedgerState blk -> [DomainAddress] diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Node/Run.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Node/Run.hs index 30f2510a668..a62e295c229 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Node/Run.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Node/Run.hs @@ -28,6 +28,7 @@ import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.CommonProtocolParams import Ouroboros.Consensus.Ledger.Inspect import Ouroboros.Consensus.Ledger.SupportsMempool +import Ouroboros.Consensus.Ledger.SupportsPeerSelection import Ouroboros.Consensus.Ledger.SupportsProtocol import Ouroboros.Consensus.Node.NetworkProtocolVersion import Ouroboros.Consensus.Node.Serialisation @@ -78,6 +79,7 @@ class ( LedgerSupportsProtocol blk , SerialiseDiskConstraints blk , SerialiseNodeToNodeConstraints blk , SerialiseNodeToClientConstraints blk + , LedgerSupportsPeerSelection blk , Show (CannotForge blk) , Show (ForgeStateInfo blk) , Show (ForgeStateUpdateError blk) diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/NodeKernel.hs b/ouroboros-consensus/src/Ouroboros/Consensus/NodeKernel.hs index c00ec095b8f..baf46beed00 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/NodeKernel.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/NodeKernel.hs @@ -20,6 +20,7 @@ module Ouroboros.Consensus.NodeKernel ( , initNodeKernel , getMempoolReader , getMempoolWriter + , getPeersFromCurrentLedger ) where import Control.Monad @@ -54,6 +55,7 @@ import Ouroboros.Consensus.HeaderValidation import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Ledger.SupportsMempool +import Ouroboros.Consensus.Ledger.SupportsPeerSelection import Ouroboros.Consensus.Ledger.SupportsProtocol import Ouroboros.Consensus.Mempool import Ouroboros.Consensus.Node.Run @@ -584,3 +586,18 @@ getMempoolWriter mempool = Inbound.TxSubmissionMempoolWriter map (txId . fst) . filter (isMempoolTxAdded . snd) <$> addTxs mempool txs } + +{------------------------------------------------------------------------------- + PeerSelection integration +-------------------------------------------------------------------------------} + +-- | Retrieve the peers registered in the current chain/ledger state by +-- descending preference. +-- +-- For example, for Shelley, this will return the stake pool relays ordered by +-- descending stake. +getPeersFromCurrentLedger :: + (IOLike m, LedgerSupportsPeerSelection blk) + => NodeKernel m remotePeer localPeer blk -> STM m [DomainAddress] +getPeersFromCurrentLedger kernel = + getPeers . ledgerState <$> ChainDB.getCurrentLedger (getChainDB kernel) diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/RootPeersDNS.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/RootPeersDNS.hs index 7bf3f8ef3ab..bb81303c422 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSelection/RootPeersDNS.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/RootPeersDNS.hs @@ -24,6 +24,9 @@ module Ouroboros.Network.PeerSelection.RootPeersDNS ( DNS.Domain, DNS.TTL, IPv4, + + -- * Socket type re-exports + Socket.PortNumber, ) where import Data.Word (Word32)