LedgerSupportsPeerSelection: return peers registered in ledger state

Fixes #2535. For Shelley, this returns the stake pool relays ordered by descending stake.
IntersectMBO · Aug 25, 2020 · 602c946 · 602c946
1 parent 2988a23
commit 602c946
Show file tree

Hide file tree

Showing 16 changed files with 152 additions and 0 deletions.
diff --git a/ouroboros-consensus-byron/src/Ouroboros/Consensus/Byron/Ledger/Ledger.hs b/ouroboros-consensus-byron/src/Ouroboros/Consensus/Byron/Ledger/Ledger.hs
@@ -67,6 +67,7 @@ import           Ouroboros.Consensus.HeaderValidation
 import           Ouroboros.Consensus.Ledger.Abstract
 import           Ouroboros.Consensus.Ledger.CommonProtocolParams
 import           Ouroboros.Consensus.Ledger.Extended
+import           Ouroboros.Consensus.Ledger.SupportsPeerSelection
 import           Ouroboros.Consensus.Ledger.SupportsProtocol
 import           Ouroboros.Consensus.Protocol.PBFT (Ticked (..))
 import           Ouroboros.Consensus.Util (ShowProxy (..))
@@ -191,6 +192,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-shelley/ouroboros-consensus-shelley.cabal b/ouroboros-consensus-shelley/ouroboros-consensus-shelley.cabal
@@ -35,6 +35,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
@@ -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
@@ -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/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Ledger/Block.hs b/ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Ledger/Block.hs
@@ -87,6 +87,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/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
@@ -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
@@ -33,6 +33,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
@@ -57,6 +58,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
@@ -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
@@ -81,6 +81,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
@@ -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
@@ -31,6 +31,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
@@ -81,6 +82,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
@@ -20,6 +20,7 @@ module Ouroboros.Consensus.NodeKernel (
   , initNodeKernel
   , getMempoolReader
   , getMempoolWriter
+  , getPeersFromCurrentLedger
   ) where
 
 import           Control.Monad
@@ -55,6 +56,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.Mempool.TxSeq (TicketNo)
@@ -580,3 +582,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-consensus/test-consensus/Test/Consensus/HardFork/Combinator/A.hs b/ouroboros-consensus/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-consensus/Test/Consensus/HardFork/Combinator/B.hs b/ouroboros-consensus/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-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)