{-# LANGUAGE DataKinds #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

{-# 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.PoolDistr 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           Ouroboros.Consensus.Ledger.SupportsPeerSelection
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 { NewEpochState era
shelleyLedgerState :: NewEpochState era
shelleyLedgerState :: forall proto era.
LedgerState (ShelleyBlock proto era) -> 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 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 (EraCrypto 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 b c a. (b -> c) -> (a, b) -> (a, c)
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 c. IndividualPoolStake c -> 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 c.
PoolDistr c -> Map (KeyHash 'StakePool c) (IndividualPoolStake c)
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 era
-> Map
     (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
forall era.
PState era
-> Map
     (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
SL.psFutureStakePoolParams PState era
pstate, PState era
-> Map
     (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
forall era.
PState era
-> Map
     (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
SL.psStakePoolParams PState era
pstate)
        where
          pstate :: SL.PState era
          pstate :: PState era
pstate =
                CertState era -> PState era
forall era. CertState era -> PState era
SL.certPState
              (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

      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 a b. (a -> b) -> Maybe a -> Maybe b
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 a. StrictSeq a -> [a]
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 c. PoolParams c -> StrictSeq StakePoolRelay
SL.ppRelays

      -- | 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)