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