{-# LANGUAGE DataKinds #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wno-orphans #-} module Ouroboros.Consensus.Shelley.Ledger.PeerSelection () where import Control.DeepSeq (force) 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, mapMaybe) import Data.Ord (Down (..)) import Data.Text.Encoding (encodeUtf8) import Ouroboros.Consensus.Ledger.SupportsPeerSelection import Cardano.Ledger.BaseTypes import qualified Cardano.Ledger.Keys as SL import qualified Cardano.Ledger.PoolDistr as SL import qualified Cardano.Ledger.Shelley.LedgerState as SL import qualified Cardano.Ledger.Shelley.TxBody as SL import Ouroboros.Consensus.Shelley.Eras (EraCrypto) import Ouroboros.Consensus.Shelley.Ledger.Block import Ouroboros.Consensus.Shelley.Ledger.Ledger instance c ~ EraCrypto era => LedgerSupportsPeerSelection (ShelleyBlock proto era) where getPeers :: LedgerState (ShelleyBlock proto era) -> [(PoolStake, NonEmpty StakePoolRelay)] getPeers ShelleyLedgerState { shelleyLedgerState } = [Maybe (PoolStake, NonEmpty StakePoolRelay)] -> [(PoolStake, NonEmpty StakePoolRelay)] forall a. [Maybe a] -> [a] catMaybes [ (PoolStake poolStake,) (NonEmpty StakePoolRelay -> (PoolStake, NonEmpty StakePoolRelay)) -> Maybe (NonEmpty StakePoolRelay) -> Maybe (PoolStake, NonEmpty StakePoolRelay) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> KeyHash 'StakePool c -> Map (KeyHash 'StakePool c) (NonEmpty StakePoolRelay) -> Maybe (NonEmpty StakePoolRelay) forall k a. Ord k => k -> Map k a -> Maybe a Map.lookup KeyHash 'StakePool c stakePool Map (KeyHash 'StakePool c) (NonEmpty StakePoolRelay) poolRelayAccessPoints | (KeyHash 'StakePool c stakePool, PoolStake poolStake) <- PoolDistr c -> [(KeyHash 'StakePool c, PoolStake)] orderByStake PoolDistr c poolDistr ] where poolDistr :: SL.PoolDistr c poolDistr :: PoolDistr c poolDistr = NewEpochState era -> PoolDistr (EraCrypto era) forall era. NewEpochState era -> PoolDistr (Crypto era) SL.nesPd NewEpochState era shelleyLedgerState -- | Sort stake pools by descending stake orderByStake :: SL.PoolDistr c -> [(SL.KeyHash 'SL.StakePool c, PoolStake)] orderByStake :: PoolDistr c -> [(KeyHash 'StakePool c, PoolStake)] orderByStake = ((KeyHash 'StakePool c, PoolStake) -> Down PoolStake) -> [(KeyHash 'StakePool c, PoolStake)] -> [(KeyHash 'StakePool c, PoolStake)] forall b a. Ord b => (a -> b) -> [a] -> [a] sortOn (PoolStake -> Down PoolStake forall a. a -> Down a Down (PoolStake -> Down PoolStake) -> ((KeyHash 'StakePool c, PoolStake) -> PoolStake) -> (KeyHash 'StakePool c, PoolStake) -> Down PoolStake forall b c a. (b -> c) -> (a -> b) -> a -> c . (KeyHash 'StakePool c, PoolStake) -> PoolStake forall a b. (a, b) -> b snd) ([(KeyHash 'StakePool c, PoolStake)] -> [(KeyHash 'StakePool c, PoolStake)]) -> (PoolDistr c -> [(KeyHash 'StakePool c, PoolStake)]) -> PoolDistr c -> [(KeyHash 'StakePool c, PoolStake)] forall b c a. (b -> c) -> (a -> b) -> a -> c . ((KeyHash 'StakePool c, IndividualPoolStake c) -> (KeyHash 'StakePool c, PoolStake)) -> [(KeyHash 'StakePool c, IndividualPoolStake c)] -> [(KeyHash 'StakePool c, PoolStake)] forall a b. (a -> b) -> [a] -> [b] map ((IndividualPoolStake c -> PoolStake) -> (KeyHash 'StakePool c, IndividualPoolStake c) -> (KeyHash 'StakePool c, PoolStake) forall (p :: * -> * -> *) b c a. Bifunctor p => (b -> c) -> p a b -> p a c second (Rational -> PoolStake PoolStake (Rational -> PoolStake) -> (IndividualPoolStake c -> Rational) -> IndividualPoolStake c -> PoolStake forall b c a. (b -> c) -> (a -> b) -> a -> c . IndividualPoolStake c -> Rational forall crypto. IndividualPoolStake crypto -> Rational SL.individualPoolStake)) ([(KeyHash 'StakePool c, IndividualPoolStake c)] -> [(KeyHash 'StakePool c, PoolStake)]) -> (PoolDistr c -> [(KeyHash 'StakePool c, IndividualPoolStake c)]) -> PoolDistr c -> [(KeyHash 'StakePool c, PoolStake)] forall b c a. (b -> c) -> (a -> b) -> a -> c . Map (KeyHash 'StakePool c) (IndividualPoolStake c) -> [(KeyHash 'StakePool c, IndividualPoolStake c)] forall k a. Map k a -> [(k, a)] Map.toList (Map (KeyHash 'StakePool c) (IndividualPoolStake c) -> [(KeyHash 'StakePool c, IndividualPoolStake c)]) -> (PoolDistr c -> Map (KeyHash 'StakePool c) (IndividualPoolStake c)) -> PoolDistr c -> [(KeyHash 'StakePool c, IndividualPoolStake c)] forall b c a. (b -> c) -> (a -> b) -> a -> c . PoolDistr c -> Map (KeyHash 'StakePool c) (IndividualPoolStake c) forall crypto. PoolDistr crypto -> Map (KeyHash 'StakePool crypto) (IndividualPoolStake crypto) SL.unPoolDistr futurePoolParams, poolParams :: Map (SL.KeyHash 'SL.StakePool c) (SL.PoolParams c) (Map (KeyHash 'StakePool c) (PoolParams c) futurePoolParams, Map (KeyHash 'StakePool c) (PoolParams c) poolParams) = (PState c -> Map (KeyHash 'StakePool c) (PoolParams c) forall crypto. PState crypto -> Map (KeyHash 'StakePool crypto) (PoolParams crypto) SL._fPParams PState c pstate, PState c -> Map (KeyHash 'StakePool c) (PoolParams c) forall crypto. PState crypto -> Map (KeyHash 'StakePool crypto) (PoolParams crypto) SL._pParams PState c pstate) where pstate :: SL.PState c pstate :: PState c pstate = DPState c -> PState c forall crypto. DPState crypto -> PState crypto SL.dpsPState (DPState c -> PState c) -> (NewEpochState era -> DPState c) -> NewEpochState era -> PState c forall b c a. (b -> c) -> (a -> b) -> a -> c . LedgerState era -> DPState c forall era. LedgerState era -> DPState (Crypto era) SL.lsDPState (LedgerState era -> DPState c) -> (NewEpochState era -> LedgerState era) -> NewEpochState era -> DPState c forall b c a. (b -> c) -> (a -> b) -> a -> c . EpochState era -> LedgerState era forall era. EpochState era -> LedgerState era SL.esLState (EpochState era -> LedgerState era) -> (NewEpochState era -> EpochState era) -> NewEpochState era -> LedgerState era forall b c a. (b -> c) -> (a -> b) -> a -> c . NewEpochState era -> EpochState era forall era. NewEpochState era -> EpochState era SL.nesEs (NewEpochState era -> PState c) -> NewEpochState era -> PState c forall a b. (a -> b) -> a -> b $ NewEpochState era shelleyLedgerState relayToRelayAccessPoint :: SL.StakePoolRelay -> Maybe RelayAccessPoint relayToRelayAccessPoint :: StakePoolRelay -> Maybe RelayAccessPoint relayToRelayAccessPoint (SL.SingleHostAddr (SJust (Port Word16 port)) (SJust IPv4 ipv4) StrictMaybe IPv6 _) = RelayAccessPoint -> Maybe RelayAccessPoint forall a. a -> Maybe a Just (RelayAccessPoint -> Maybe RelayAccessPoint) -> RelayAccessPoint -> Maybe RelayAccessPoint forall a b. (a -> b) -> a -> b $ IP -> PortNumber -> RelayAccessPoint RelayAccessAddress (IPv4 -> IP IPv4 IPv4 ipv4) (Word16 -> PortNumber forall a b. (Integral a, Num b) => a -> b fromIntegral Word16 port) relayToRelayAccessPoint (SL.SingleHostAddr (SJust (Port Word16 port)) StrictMaybe IPv4 SNothing (SJust IPv6 ipv6)) = RelayAccessPoint -> Maybe RelayAccessPoint forall a. a -> Maybe a Just (RelayAccessPoint -> Maybe RelayAccessPoint) -> RelayAccessPoint -> Maybe RelayAccessPoint forall a b. (a -> b) -> a -> b $ IP -> PortNumber -> RelayAccessPoint RelayAccessAddress (IPv6 -> IP IPv6 IPv6 ipv6) (Word16 -> PortNumber forall a b. (Integral a, Num b) => a -> b fromIntegral Word16 port) relayToRelayAccessPoint (SL.SingleHostName (SJust (Port Word16 port)) DnsName dnsName) = RelayAccessPoint -> Maybe RelayAccessPoint forall a. a -> Maybe a Just (RelayAccessPoint -> Maybe RelayAccessPoint) -> RelayAccessPoint -> Maybe RelayAccessPoint forall a b. (a -> b) -> a -> b $ Domain -> PortNumber -> RelayAccessPoint RelayAccessDomain (Text -> Domain encodeUtf8 (Text -> Domain) -> Text -> Domain forall a b. (a -> b) -> a -> b $ DnsName -> Text dnsToText DnsName dnsName) (Word16 -> PortNumber forall a b. (Integral a, Num b) => a -> b fromIntegral Word16 port) relayToRelayAccessPoint StakePoolRelay _ = -- This could be an unsupported relay (SRV records) or an unusable -- relay such as a relay with an IP address but without a port number. Maybe RelayAccessPoint forall a. Maybe a Nothing -- | Note that a stake pool can have multiple registered relays pparamsRelayAccessPoints :: (RelayAccessPoint -> StakePoolRelay) -> SL.PoolParams c -> Maybe (NonEmpty StakePoolRelay) pparamsRelayAccessPoints :: (RelayAccessPoint -> StakePoolRelay) -> PoolParams c -> Maybe (NonEmpty StakePoolRelay) pparamsRelayAccessPoints RelayAccessPoint -> StakePoolRelay injStakePoolRelay = [StakePoolRelay] -> Maybe (NonEmpty StakePoolRelay) forall a. [a] -> Maybe (NonEmpty a) NE.nonEmpty ([StakePoolRelay] -> Maybe (NonEmpty StakePoolRelay)) -> (PoolParams c -> [StakePoolRelay]) -> PoolParams c -> Maybe (NonEmpty StakePoolRelay) forall b c a. (b -> c) -> (a -> b) -> a -> c . [StakePoolRelay] -> [StakePoolRelay] forall a. NFData a => a -> a force ([StakePoolRelay] -> [StakePoolRelay]) -> (PoolParams c -> [StakePoolRelay]) -> PoolParams c -> [StakePoolRelay] forall b c a. (b -> c) -> (a -> b) -> a -> c . (StakePoolRelay -> Maybe StakePoolRelay) -> [StakePoolRelay] -> [StakePoolRelay] forall a b. (a -> Maybe b) -> [a] -> [b] mapMaybe ((RelayAccessPoint -> StakePoolRelay) -> Maybe RelayAccessPoint -> Maybe StakePoolRelay forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap RelayAccessPoint -> StakePoolRelay injStakePoolRelay (Maybe RelayAccessPoint -> Maybe StakePoolRelay) -> (StakePoolRelay -> Maybe RelayAccessPoint) -> StakePoolRelay -> Maybe StakePoolRelay forall b c a. (b -> c) -> (a -> b) -> a -> c . StakePoolRelay -> Maybe RelayAccessPoint relayToRelayAccessPoint) ([StakePoolRelay] -> [StakePoolRelay]) -> (PoolParams c -> [StakePoolRelay]) -> PoolParams c -> [StakePoolRelay] forall b c a. (b -> c) -> (a -> b) -> a -> c . StrictSeq StakePoolRelay -> [StakePoolRelay] forall (t :: * -> *) a. Foldable t => t a -> [a] toList (StrictSeq StakePoolRelay -> [StakePoolRelay]) -> (PoolParams c -> StrictSeq StakePoolRelay) -> PoolParams c -> [StakePoolRelay] forall b c a. (b -> c) -> (a -> b) -> a -> c . PoolParams c -> StrictSeq StakePoolRelay forall crypto. PoolParams crypto -> StrictSeq StakePoolRelay SL._poolRelays -- | Combine the stake pools registered in the future and the current pool -- parameters, and remove duplicates. poolRelayAccessPoints :: Map (SL.KeyHash 'SL.StakePool c) (NonEmpty StakePoolRelay) poolRelayAccessPoints :: Map (KeyHash 'StakePool c) (NonEmpty StakePoolRelay) poolRelayAccessPoints = (NonEmpty StakePoolRelay -> NonEmpty StakePoolRelay -> NonEmpty StakePoolRelay) -> Map (KeyHash 'StakePool c) (NonEmpty StakePoolRelay) -> Map (KeyHash 'StakePool c) (NonEmpty StakePoolRelay) -> Map (KeyHash 'StakePool c) (NonEmpty StakePoolRelay) forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a Map.unionWith (\NonEmpty StakePoolRelay futureRelays NonEmpty StakePoolRelay currentRelays -> NonEmpty StakePoolRelay -> NonEmpty StakePoolRelay forall a. Eq a => NonEmpty a -> NonEmpty a NE.nub (NonEmpty StakePoolRelay futureRelays NonEmpty StakePoolRelay -> NonEmpty StakePoolRelay -> NonEmpty StakePoolRelay forall a. Semigroup a => a -> a -> a <> NonEmpty StakePoolRelay currentRelays)) ((PoolParams c -> Maybe (NonEmpty StakePoolRelay)) -> Map (KeyHash 'StakePool c) (PoolParams c) -> Map (KeyHash 'StakePool c) (NonEmpty StakePoolRelay) forall a b k. (a -> Maybe b) -> Map k a -> Map k b Map.mapMaybe ((RelayAccessPoint -> StakePoolRelay) -> PoolParams c -> Maybe (NonEmpty StakePoolRelay) pparamsRelayAccessPoints RelayAccessPoint -> StakePoolRelay FutureRelay) Map (KeyHash 'StakePool c) (PoolParams c) futurePoolParams) ((PoolParams c -> Maybe (NonEmpty StakePoolRelay)) -> Map (KeyHash 'StakePool c) (PoolParams c) -> Map (KeyHash 'StakePool c) (NonEmpty StakePoolRelay) forall a b k. (a -> Maybe b) -> Map k a -> Map k b Map.mapMaybe ((RelayAccessPoint -> StakePoolRelay) -> PoolParams c -> Maybe (NonEmpty StakePoolRelay) pparamsRelayAccessPoints RelayAccessPoint -> StakePoolRelay CurrentRelay) Map (KeyHash 'StakePool c) (PoolParams c) poolParams)