-
Notifications
You must be signed in to change notification settings - Fork 86
Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
LedgerSupportsPeerSelection: return peers registered in ledger state
Fixes #2535.
- Loading branch information
Showing
17 changed files
with
186 additions
and
0 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
80 changes: 80 additions & 0 deletions
80
ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/PeerSelection.hs
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,80 @@ | ||
| {-# LANGUAGE DataKinds #-} | ||
| {-# LANGUAGE NamedFieldPuns #-} | ||
| {-# LANGUAGE ScopedTypeVariables #-} | ||
| {-# LANGUAGE TupleSections #-} | ||
|
|
||
| {-# 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.List.NonEmpty (NonEmpty) | ||
| import qualified Data.List.NonEmpty as NE | ||
| import Data.Map.Strict (Map) | ||
| import qualified Data.Map.Strict as Map | ||
| import Data.Maybe (catMaybes) | ||
| 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.TxBody as SL | ||
|
|
||
| import Ouroboros.Consensus.Shelley.Eras (EraCrypto) | ||
| import Ouroboros.Consensus.Shelley.Ledger.Block | ||
| import Ouroboros.Consensus.Shelley.Ledger.Ledger | ||
|
|
||
| instance LedgerSupportsPeerSelection (ShelleyBlock era) where | ||
| getPeers ShelleyLedgerState { shelleyLedgerState } = catMaybes | ||
| [ (poolStake,) <$> Map.lookup stakePool poolDomainAddresses | ||
| | (stakePool, poolStake) <- orderByStake poolDistr | ||
| ] | ||
| where | ||
| poolDistr :: SL.PoolDistr (EraCrypto era) | ||
| poolDistr = SL.nesPd shelleyLedgerState | ||
|
|
||
| -- | Sort stake pools by descending stake | ||
| orderByStake :: | ||
| SL.PoolDistr (EraCrypto era) | ||
| -> [(SL.KeyHash 'SL.StakePool (EraCrypto era), PoolStake)] | ||
| orderByStake = | ||
| sortOn (Down . snd) | ||
| . map (second SL.individualPoolStake) | ||
| . Map.toList | ||
| . SL.unPoolDistr | ||
|
|
||
| futurePoolParams, poolParams :: | ||
| Map (SL.KeyHash 'SL.StakePool (EraCrypto era)) (SL.PoolParams era) | ||
| (futurePoolParams, poolParams) = | ||
| (SL._fPParams pstate, SL._pParams pstate) | ||
| where | ||
| pstate :: SL.PState era | ||
| pstate = | ||
| SL._pstate | ||
| . SL._delegationState | ||
| . SL.esLState | ||
| . SL.nesEs | ||
| $ shelleyLedgerState | ||
|
|
||
| relayToDomainAddress :: SL.StakePoolRelay -> DomainAddress | ||
| relayToDomainAddress = undefined | ||
|
|
||
| -- | Note that a stake pool can have multiple registered relays | ||
| pparamsDomainAddresses :: | ||
| SL.PoolParams era | ||
| -> Maybe (NonEmpty DomainAddress) | ||
| pparamsDomainAddresses = | ||
| NE.nonEmpty . map relayToDomainAddress . toList . SL._poolRelays | ||
|
|
||
| -- | Combine the stake pools registered in the future and the current pool | ||
| -- parameters, and remove duplicates. | ||
| poolDomainAddresses :: | ||
| Map (SL.KeyHash 'SL.StakePool (EraCrypto era)) (NonEmpty DomainAddress) | ||
| poolDomainAddresses = | ||
| Map.unionWith | ||
| (\futureRelays currentRelays -> NE.nub (futureRelays <> currentRelays)) | ||
| (Map.mapMaybe pparamsDomainAddresses futurePoolParams) | ||
| (Map.mapMaybe pparamsDomainAddresses poolParams) |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
18 changes: 18 additions & 0 deletions
18
ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Ledger/PeerSelection.hs
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -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 |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
27 changes: 27 additions & 0 deletions
27
ouroboros-consensus/src/Ouroboros/Consensus/Ledger/SupportsPeerSelection.hs
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,27 @@ | ||
| module Ouroboros.Consensus.Ledger.SupportsPeerSelection ( | ||
| LedgerSupportsPeerSelection (..) | ||
| , PoolStake | ||
| -- * Re-exports for convenience | ||
| , DomainAddress (..) | ||
| , Domain | ||
| , PortNumber | ||
| ) where | ||
|
|
||
| import Data.List.NonEmpty (NonEmpty) | ||
|
|
||
| import Ouroboros.Network.PeerSelection.RootPeersDNS (Domain, | ||
| DomainAddress (..), PortNumber) | ||
|
|
||
| import Ouroboros.Consensus.Ledger.Abstract (LedgerState) | ||
|
|
||
| -- | The relative stake of the stakepool. A value in the [0, 1] range. | ||
| type PoolStake = Rational | ||
|
|
||
| class LedgerSupportsPeerSelection blk where | ||
| -- | Return peers registered in the ledger ordered by descending 'PoolStake'. | ||
| -- | ||
| -- For example, for Shelley, the relays that have been registered in the | ||
| -- ledger for the respective stake pools will be returned. | ||
| -- | ||
| -- Ledgers/blocks that don't support staking can return an empty list. | ||
| getPeers :: LedgerState blk -> [(PoolStake, NonEmpty DomainAddress)] |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters