{-# LANGUAGE DataKinds #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Ouroboros.Consensus.Shelley.Ledger.PeerSelection () where

import Cardano.Ledger.BaseTypes
import qualified Cardano.Ledger.Keys as SL
import qualified Cardano.Ledger.Shelley.API as SL
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 Lens.Micro.Extras (view)
import Ouroboros.Consensus.Ledger.SupportsPeerSelection
import Ouroboros.Consensus.Shelley.Ledger.Block
import Ouroboros.Consensus.Shelley.Ledger.Ledger

instance SL.EraCertState era => LedgerSupportsPeerSelection (ShelleyBlock proto era) where
  getPeers :: forall (mk :: MapKind).
LedgerState (ShelleyBlock proto era) mk
-> [(PoolStake, NonEmpty StakePoolRelay)]
getPeers ShelleyLedgerState{NewEpochState era
shelleyLedgerState :: NewEpochState era
shelleyLedgerState :: forall proto era (mk :: MapKind).
LedgerState (ShelleyBlock proto era) mk -> NewEpochState era
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
-> Map (KeyHash 'StakePool) (NonEmpty StakePoolRelay)
-> Maybe (NonEmpty StakePoolRelay)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup KeyHash 'StakePool
stakePool Map (KeyHash 'StakePool) (NonEmpty StakePoolRelay)
poolLedgerRelayAccessPoints
      | (KeyHash 'StakePool
stakePool, PoolStake
poolStake) <- PoolDistr -> [(KeyHash 'StakePool, PoolStake)]
orderByStake PoolDistr
poolDistr
      ]
   where
    poolDistr :: SL.PoolDistr
    poolDistr :: PoolDistr
poolDistr = NewEpochState era -> PoolDistr
forall era. NewEpochState era -> PoolDistr
SL.nesPd NewEpochState era
shelleyLedgerState

    -- \| Sort stake pools by descending stake
    orderByStake ::
      SL.PoolDistr ->
      [(SL.KeyHash 'SL.StakePool, PoolStake)]
    orderByStake :: PoolDistr -> [(KeyHash 'StakePool, PoolStake)]
orderByStake =
      ((KeyHash 'StakePool, PoolStake) -> Down PoolStake)
-> [(KeyHash 'StakePool, PoolStake)]
-> [(KeyHash 'StakePool, 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, PoolStake) -> PoolStake)
-> (KeyHash 'StakePool, PoolStake)
-> Down PoolStake
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (KeyHash 'StakePool, PoolStake) -> PoolStake
forall a b. (a, b) -> b
snd)
        ([(KeyHash 'StakePool, PoolStake)]
 -> [(KeyHash 'StakePool, PoolStake)])
-> (PoolDistr -> [(KeyHash 'StakePool, PoolStake)])
-> PoolDistr
-> [(KeyHash 'StakePool, PoolStake)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((KeyHash 'StakePool, IndividualPoolStake)
 -> (KeyHash 'StakePool, PoolStake))
-> [(KeyHash 'StakePool, IndividualPoolStake)]
-> [(KeyHash 'StakePool, PoolStake)]
forall a b. (a -> b) -> [a] -> [b]
map ((IndividualPoolStake -> PoolStake)
-> (KeyHash 'StakePool, IndividualPoolStake)
-> (KeyHash 'StakePool, PoolStake)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: MapKind) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (Rational -> PoolStake
PoolStake (Rational -> PoolStake)
-> (IndividualPoolStake -> Rational)
-> IndividualPoolStake
-> PoolStake
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IndividualPoolStake -> Rational
SL.individualPoolStake))
        ([(KeyHash 'StakePool, IndividualPoolStake)]
 -> [(KeyHash 'StakePool, PoolStake)])
-> (PoolDistr -> [(KeyHash 'StakePool, IndividualPoolStake)])
-> PoolDistr
-> [(KeyHash 'StakePool, PoolStake)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map (KeyHash 'StakePool) IndividualPoolStake
-> [(KeyHash 'StakePool, IndividualPoolStake)]
forall k a. Map k a -> [(k, a)]
Map.toList
        (Map (KeyHash 'StakePool) IndividualPoolStake
 -> [(KeyHash 'StakePool, IndividualPoolStake)])
-> (PoolDistr -> Map (KeyHash 'StakePool) IndividualPoolStake)
-> PoolDistr
-> [(KeyHash 'StakePool, IndividualPoolStake)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PoolDistr -> Map (KeyHash 'StakePool) IndividualPoolStake
SL.unPoolDistr

    futurePoolParams
      , poolParams ::
        Map (SL.KeyHash 'SL.StakePool) SL.PoolParams
    (Map (KeyHash 'StakePool) PoolParams
futurePoolParams, Map (KeyHash 'StakePool) PoolParams
poolParams) =
      (PState era -> Map (KeyHash 'StakePool) PoolParams
forall era. PState era -> Map (KeyHash 'StakePool) PoolParams
SL.psFutureStakePoolParams PState era
pstate, PState era -> Map (KeyHash 'StakePool) PoolParams
forall era. PState era -> Map (KeyHash 'StakePool) PoolParams
SL.psStakePoolParams PState era
pstate)
     where
      pstate :: SL.PState era
      pstate :: PState era
pstate =
        Getting (PState era) (CertState era) (PState era)
-> CertState era -> PState era
forall a s. Getting a s a -> s -> a
view Getting (PState era) (CertState era) (PState era)
forall era. EraCertState era => Lens' (CertState era) (PState era)
Lens' (CertState era) (PState era)
SL.certPStateL
          (CertState era -> PState era)
-> (NewEpochState era -> CertState era)
-> NewEpochState era
-> PState era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerState era -> CertState era
forall era. LedgerState era -> CertState era
SL.lsCertState
          (LedgerState era -> CertState era)
-> (NewEpochState era -> LedgerState era)
-> NewEpochState era
-> CertState era
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 era)
-> NewEpochState era -> PState era
forall a b. (a -> b) -> a -> b
$ NewEpochState era
shelleyLedgerState

    relayToLedgerRelayAccessPoint :: SL.StakePoolRelay -> Maybe LedgerRelayAccessPoint
    relayToLedgerRelayAccessPoint :: StakePoolRelay -> Maybe LedgerRelayAccessPoint
relayToLedgerRelayAccessPoint (SL.SingleHostAddr (SJust (Port Word16
port)) (SJust IPv4
ipv4) StrictMaybe IPv6
_) =
      LedgerRelayAccessPoint -> Maybe LedgerRelayAccessPoint
forall a. a -> Maybe a
Just (LedgerRelayAccessPoint -> Maybe LedgerRelayAccessPoint)
-> LedgerRelayAccessPoint -> Maybe LedgerRelayAccessPoint
forall a b. (a -> b) -> a -> b
$ IP -> PortNumber -> LedgerRelayAccessPoint
LedgerRelayAccessAddress (IPv4 -> IP
IPv4 IPv4
ipv4) (Word16 -> PortNumber
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
port)
    relayToLedgerRelayAccessPoint
      ( SL.SingleHostAddr
          (SJust (Port Word16
port))
          StrictMaybe IPv4
SNothing
          (SJust IPv6
ipv6)
        ) =
        LedgerRelayAccessPoint -> Maybe LedgerRelayAccessPoint
forall a. a -> Maybe a
Just (LedgerRelayAccessPoint -> Maybe LedgerRelayAccessPoint)
-> LedgerRelayAccessPoint -> Maybe LedgerRelayAccessPoint
forall a b. (a -> b) -> a -> b
$ IP -> PortNumber -> LedgerRelayAccessPoint
LedgerRelayAccessAddress (IPv6 -> IP
IPv6 IPv6
ipv6) (Word16 -> PortNumber
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
port)
    -- no IP address or no port number
    relayToLedgerRelayAccessPoint (SL.SingleHostAddr StrictMaybe Port
SNothing StrictMaybe IPv4
_ StrictMaybe IPv6
_) = Maybe LedgerRelayAccessPoint
forall a. Maybe a
Nothing
    relayToLedgerRelayAccessPoint (SL.SingleHostAddr StrictMaybe Port
_ StrictMaybe IPv4
SNothing StrictMaybe IPv6
_) = Maybe LedgerRelayAccessPoint
forall a. Maybe a
Nothing
    relayToLedgerRelayAccessPoint (SL.SingleHostName (SJust (Port Word16
port)) DnsName
dnsName) =
      LedgerRelayAccessPoint -> Maybe LedgerRelayAccessPoint
forall a. a -> Maybe a
Just (LedgerRelayAccessPoint -> Maybe LedgerRelayAccessPoint)
-> LedgerRelayAccessPoint -> Maybe LedgerRelayAccessPoint
forall a b. (a -> b) -> a -> b
$ Domain -> PortNumber -> LedgerRelayAccessPoint
LedgerRelayAccessDomain (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)
    -- srv support: either `SingleHostName` without port number or
    -- `MultiHostName`
    relayToLedgerRelayAccessPoint (SL.SingleHostName StrictMaybe Port
SNothing DnsName
dnsName) =
      LedgerRelayAccessPoint -> Maybe LedgerRelayAccessPoint
forall a. a -> Maybe a
Just (LedgerRelayAccessPoint -> Maybe LedgerRelayAccessPoint)
-> LedgerRelayAccessPoint -> Maybe LedgerRelayAccessPoint
forall a b. (a -> b) -> a -> b
$ Domain -> LedgerRelayAccessPoint
LedgerRelayAccessSRVDomain (Text -> Domain
encodeUtf8 (Text -> Domain) -> Text -> Domain
forall a b. (a -> b) -> a -> b
$ DnsName -> Text
dnsToText DnsName
dnsName)
    relayToLedgerRelayAccessPoint (SL.MultiHostName DnsName
dnsName) =
      LedgerRelayAccessPoint -> Maybe LedgerRelayAccessPoint
forall a. a -> Maybe a
Just (LedgerRelayAccessPoint -> Maybe LedgerRelayAccessPoint)
-> LedgerRelayAccessPoint -> Maybe LedgerRelayAccessPoint
forall a b. (a -> b) -> a -> b
$ Domain -> LedgerRelayAccessPoint
LedgerRelayAccessSRVDomain (Text -> Domain
encodeUtf8 (Text -> Domain) -> Text -> Domain
forall a b. (a -> b) -> a -> b
$ DnsName -> Text
dnsToText DnsName
dnsName)

    -- \| Note that a stake pool can have multiple registered relays
    pparamsLedgerRelayAccessPoints ::
      (LedgerRelayAccessPoint -> StakePoolRelay) ->
      SL.PoolParams ->
      Maybe (NonEmpty StakePoolRelay)
    pparamsLedgerRelayAccessPoints :: (LedgerRelayAccessPoint -> StakePoolRelay)
-> PoolParams -> Maybe (NonEmpty StakePoolRelay)
pparamsLedgerRelayAccessPoints LedgerRelayAccessPoint -> StakePoolRelay
injStakePoolRelay =
      [StakePoolRelay] -> Maybe (NonEmpty StakePoolRelay)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty
        ([StakePoolRelay] -> Maybe (NonEmpty StakePoolRelay))
-> (PoolParams -> [StakePoolRelay])
-> PoolParams
-> 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 -> [StakePoolRelay])
-> PoolParams
-> [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 ((LedgerRelayAccessPoint -> StakePoolRelay)
-> Maybe LedgerRelayAccessPoint -> Maybe StakePoolRelay
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LedgerRelayAccessPoint -> StakePoolRelay
injStakePoolRelay (Maybe LedgerRelayAccessPoint -> Maybe StakePoolRelay)
-> (StakePoolRelay -> Maybe LedgerRelayAccessPoint)
-> StakePoolRelay
-> Maybe StakePoolRelay
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StakePoolRelay -> Maybe LedgerRelayAccessPoint
relayToLedgerRelayAccessPoint)
        ([StakePoolRelay] -> [StakePoolRelay])
-> (PoolParams -> [StakePoolRelay])
-> PoolParams
-> [StakePoolRelay]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StrictSeq StakePoolRelay -> [StakePoolRelay]
forall a. StrictSeq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList
        (StrictSeq StakePoolRelay -> [StakePoolRelay])
-> (PoolParams -> StrictSeq StakePoolRelay)
-> PoolParams
-> [StakePoolRelay]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PoolParams -> StrictSeq StakePoolRelay
SL.ppRelays

    -- \| Combine the stake pools registered in the future and the current pool
    -- parameters, and remove duplicates.
    poolLedgerRelayAccessPoints ::
      Map (SL.KeyHash 'SL.StakePool) (NonEmpty StakePoolRelay)
    poolLedgerRelayAccessPoints :: Map (KeyHash 'StakePool) (NonEmpty StakePoolRelay)
poolLedgerRelayAccessPoints =
      (NonEmpty StakePoolRelay
 -> NonEmpty StakePoolRelay -> NonEmpty StakePoolRelay)
-> Map (KeyHash 'StakePool) (NonEmpty StakePoolRelay)
-> Map (KeyHash 'StakePool) (NonEmpty StakePoolRelay)
-> Map (KeyHash 'StakePool) (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 -> Maybe (NonEmpty StakePoolRelay))
-> Map (KeyHash 'StakePool) PoolParams
-> Map (KeyHash 'StakePool) (NonEmpty StakePoolRelay)
forall a b k. (a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybe ((LedgerRelayAccessPoint -> StakePoolRelay)
-> PoolParams -> Maybe (NonEmpty StakePoolRelay)
pparamsLedgerRelayAccessPoints LedgerRelayAccessPoint -> StakePoolRelay
FutureRelay) Map (KeyHash 'StakePool) PoolParams
futurePoolParams)
        ((PoolParams -> Maybe (NonEmpty StakePoolRelay))
-> Map (KeyHash 'StakePool) PoolParams
-> Map (KeyHash 'StakePool) (NonEmpty StakePoolRelay)
forall a b k. (a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybe ((LedgerRelayAccessPoint -> StakePoolRelay)
-> PoolParams -> Maybe (NonEmpty StakePoolRelay)
pparamsLedgerRelayAccessPoints LedgerRelayAccessPoint -> StakePoolRelay
CurrentRelay) Map (KeyHash 'StakePool) PoolParams
poolParams)