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

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

import Cardano.Base.IP (unIPv4, unIPv6)
import qualified Cardano.Ledger.Api.State.Query as SL
import Cardano.Ledger.BaseTypes
import qualified Cardano.Ledger.Shelley.API as SL
import Control.DeepSeq (force)
import Data.Foldable (toList)
import Data.List (sortOn)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as NE
import qualified Data.Map.Strict as Map
import Data.Maybe (catMaybes, mapMaybe)
import Data.Ord (Down (..))
import Data.Sequence.Strict (StrictSeq)
import Data.Text.Encoding (encodeUtf8)
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
      [ (Rational -> PoolStake
PoolStake Rational
stake,) (NonEmpty StakePoolRelay -> (PoolStake, NonEmpty StakePoolRelay))
-> Maybe (NonEmpty StakePoolRelay)
-> Maybe (PoolStake, NonEmpty StakePoolRelay)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictSeq StakePoolRelay -> Maybe (NonEmpty StakePoolRelay)
ledgerRelayAccessPoints StrictSeq StakePoolRelay
relays
      | (KeyHash StakePool
_stakePool, (Rational
stake, StrictSeq StakePoolRelay
relays)) <- [(KeyHash StakePool, (Rational, StrictSeq StakePoolRelay))]
stakeOrdered
      ]
   where
    stakeOrdered :: [(KeyHash StakePool, (Rational, StrictSeq StakePoolRelay))]
stakeOrdered =
      ((KeyHash StakePool, (Rational, StrictSeq StakePoolRelay))
 -> Down Rational)
-> [(KeyHash StakePool, (Rational, StrictSeq StakePoolRelay))]
-> [(KeyHash StakePool, (Rational, StrictSeq StakePoolRelay))]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (Rational -> Down Rational
forall a. a -> Down a
Down (Rational -> Down Rational)
-> ((KeyHash StakePool, (Rational, StrictSeq StakePoolRelay))
    -> Rational)
-> (KeyHash StakePool, (Rational, StrictSeq StakePoolRelay))
-> Down Rational
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Rational, StrictSeq StakePoolRelay) -> Rational
forall a b. (a, b) -> a
fst ((Rational, StrictSeq StakePoolRelay) -> Rational)
-> ((KeyHash StakePool, (Rational, StrictSeq StakePoolRelay))
    -> (Rational, StrictSeq StakePoolRelay))
-> (KeyHash StakePool, (Rational, StrictSeq StakePoolRelay))
-> Rational
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (KeyHash StakePool, (Rational, StrictSeq StakePoolRelay))
-> (Rational, StrictSeq StakePoolRelay)
forall a b. (a, b) -> b
snd) ([(KeyHash StakePool, (Rational, StrictSeq StakePoolRelay))]
 -> [(KeyHash StakePool, (Rational, StrictSeq StakePoolRelay))])
-> (Map (KeyHash StakePool) (Rational, StrictSeq StakePoolRelay)
    -> [(KeyHash StakePool, (Rational, StrictSeq StakePoolRelay))])
-> Map (KeyHash StakePool) (Rational, StrictSeq StakePoolRelay)
-> [(KeyHash StakePool, (Rational, StrictSeq StakePoolRelay))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map (KeyHash StakePool) (Rational, StrictSeq StakePoolRelay)
-> [(KeyHash StakePool, (Rational, StrictSeq StakePoolRelay))]
forall k a. Map k a -> [(k, a)]
Map.toList (Map (KeyHash StakePool) (Rational, StrictSeq StakePoolRelay)
 -> [(KeyHash StakePool, (Rational, StrictSeq StakePoolRelay))])
-> Map (KeyHash StakePool) (Rational, StrictSeq StakePoolRelay)
-> [(KeyHash StakePool, (Rational, StrictSeq StakePoolRelay))]
forall a b. (a -> b) -> a -> b
$
        NewEpochState era
-> Map (KeyHash StakePool) (Rational, StrictSeq StakePoolRelay)
forall era.
EraCertState era =>
NewEpochState era
-> Map (KeyHash StakePool) (Rational, StrictSeq StakePoolRelay)
SL.queryStakePoolRelays 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
unIPv4 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
unIPv6 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)

    ledgerRelayAccessPoints ::
      StrictSeq SL.StakePoolRelay ->
      Maybe (NonEmpty StakePoolRelay)
    ledgerRelayAccessPoints :: StrictSeq StakePoolRelay -> Maybe (NonEmpty StakePoolRelay)
ledgerRelayAccessPoints =
      [StakePoolRelay] -> Maybe (NonEmpty StakePoolRelay)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty
        ([StakePoolRelay] -> Maybe (NonEmpty StakePoolRelay))
-> (StrictSeq StakePoolRelay -> [StakePoolRelay])
-> StrictSeq StakePoolRelay
-> Maybe (NonEmpty StakePoolRelay)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [StakePoolRelay] -> [StakePoolRelay]
forall a. NFData a => a -> a
force
        ([StakePoolRelay] -> [StakePoolRelay])
-> (StrictSeq StakePoolRelay -> [StakePoolRelay])
-> StrictSeq StakePoolRelay
-> [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
CurrentRelay (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])
-> (StrictSeq StakePoolRelay -> [StakePoolRelay])
-> StrictSeq StakePoolRelay
-> [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