From d2eaf3bce0ada602c33ac40acb7e7977a291be00 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcin=20W=C3=B3jtowicz?= Date: Thu, 11 Apr 2024 09:24:00 +0200 Subject: [PATCH] Expose functionality of calculating big ledger peers: Moved utility functions to ouroboros-network-api to support calculating big ledger peer snapshots by upstream libraries, for eg. Genesis consensus mode and bootstrapping a node with a recent snapshot of these peers. --- ouroboros-network-api/CHANGELOG.md | 4 + .../ouroboros-network-api.cabal | 1 + .../Network/PeerSelection/LedgerPeers/Type.hs | 6 ++ .../PeerSelection/LedgerPeers/Utils.hs | 81 ++++++++++++++++++ ouroboros-network/CHANGELOG.md | 4 + .../Test/Ouroboros/Network/LedgerPeers.hs | 4 +- .../Network/PeerSelection/LedgerPeers.hs | 83 +++---------------- .../PeerSelection/LedgerPeers/Common.hs | 5 -- 8 files changed, 111 insertions(+), 77 deletions(-) create mode 100644 ouroboros-network-api/src/Ouroboros/Network/PeerSelection/LedgerPeers/Utils.hs diff --git a/ouroboros-network-api/CHANGELOG.md b/ouroboros-network-api/CHANGELOG.md index ef5a67ddab1..b540807d67d 100644 --- a/ouroboros-network-api/CHANGELOG.md +++ b/ouroboros-network-api/CHANGELOG.md @@ -6,6 +6,10 @@ ### Non-Breaking changes +* Transplanted `accBigPoolStake` and `reRelativeStake` from ouroboros-network + `LedgerPeers` module to expose functionality that facilitates serializing + of big ledger peers via LocalStateQuery miniprotocol. + ## 0.7.3.0 -- 2024-06-07 ### Breaking changes diff --git a/ouroboros-network-api/ouroboros-network-api.cabal b/ouroboros-network-api/ouroboros-network-api.cabal index d7e84d347b5..13b3534d635 100644 --- a/ouroboros-network-api/ouroboros-network-api.cabal +++ b/ouroboros-network-api/ouroboros-network-api.cabal @@ -43,6 +43,7 @@ library Ouroboros.Network.PeerSelection.Bootstrap Ouroboros.Network.PeerSelection.LedgerPeers.Type + Ouroboros.Network.PeerSelection.LedgerPeers.Utils Ouroboros.Network.PeerSelection.LocalRootPeers Ouroboros.Network.PeerSelection.PeerMetric.Type Ouroboros.Network.PeerSelection.PeerAdvertise diff --git a/ouroboros-network-api/src/Ouroboros/Network/PeerSelection/LedgerPeers/Type.hs b/ouroboros-network-api/src/Ouroboros/Network/PeerSelection/LedgerPeers/Type.hs index c9ca11d629f..6e1705943f2 100644 --- a/ouroboros-network-api/src/Ouroboros/Network/PeerSelection/LedgerPeers/Type.hs +++ b/ouroboros-network-api/src/Ouroboros/Network/PeerSelection/LedgerPeers/Type.hs @@ -14,6 +14,7 @@ module Ouroboros.Network.PeerSelection.LedgerPeers.Type , LedgerPeersConsensusInterface (..) , UseLedgerPeers (..) , AfterSlot (..) + , LedgerPeersKind (..) , isLedgerPeersEnabled ) where @@ -25,6 +26,11 @@ import GHC.Generics import NoThunks.Class import Ouroboros.Network.PeerSelection.RelayAccessPoint (RelayAccessPoint) +-- | Which ledger peers to pick. +-- +data LedgerPeersKind = AllLedgerPeers | BigLedgerPeers + deriving Show + -- | Only use the ledger after the given slot number. data UseLedgerPeers = DontUseLedgerPeers | UseLedgerPeers AfterSlot diff --git a/ouroboros-network-api/src/Ouroboros/Network/PeerSelection/LedgerPeers/Utils.hs b/ouroboros-network-api/src/Ouroboros/Network/PeerSelection/LedgerPeers/Utils.hs new file mode 100644 index 00000000000..a4e133e53b5 --- /dev/null +++ b/ouroboros-network-api/src/Ouroboros/Network/PeerSelection/LedgerPeers/Utils.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE TypeApplications #-} + +module Ouroboros.Network.PeerSelection.LedgerPeers.Utils + ( bigLedgerPeerQuota + , accBigPoolStake + , reRelativeStake + , AccPoolStake (..) + , PoolStake (..) + , RelayAccessPoint (..) + ) where + +import Control.Exception (assert) +import Data.Bifunctor (first) +import Data.List (foldl', sortOn) +import Data.List.NonEmpty (NonEmpty) +import Data.Ord (Down (..)) +import Data.Ratio ((%)) + +import Ouroboros.Network.PeerSelection.LedgerPeers.Type +import Ouroboros.Network.PeerSelection.RelayAccessPoint + +-- | The total accumulated stake of big ledger peers. +-- +bigLedgerPeerQuota :: AccPoolStake +bigLedgerPeerQuota = 0.9 + +-- | Sort ascendingly a given list of pools with stake, +-- and tag each one with cumulative stake, with a cutoff +-- at 'bigLedgerPeerQuota' +-- +accBigPoolStake :: [(PoolStake, NonEmpty RelayAccessPoint)] + -> [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))] +accBigPoolStake = + takeWhilePrev (\(acc, _) -> acc <= bigLedgerPeerQuota) + . go 0 + . sortOn (Down . fst) + . reRelativeStake BigLedgerPeers + where + takeWhilePrev :: (a -> Bool) -> [a] -> [a] + takeWhilePrev f as = + fmap snd + . takeWhile (\(a, _) -> maybe True f a) + $ zip (Nothing : (Just <$> as)) as + + -- natural fold + go :: AccPoolStake + -> [(PoolStake, NonEmpty RelayAccessPoint)] + -> [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))] + go _acc [] = [] + go !acc (a@(s, _) : as) = + let acc' = acc + AccPoolStake (unPoolStake s) + in (acc', a) : go acc' as + +-- | Not all stake pools have valid \/ usable relay information. This means that +-- we need to recalculate the relative stake for each pool. +-- +reRelativeStake :: LedgerPeersKind + -> [(PoolStake, NonEmpty RelayAccessPoint)] + -> [(PoolStake, NonEmpty RelayAccessPoint)] +reRelativeStake ledgerPeersKind pl = + let pl' = first adjustment <$> pl + total = foldl' (+) 0 (fst <$> pl') + pl'' = first (/ total) <$> pl' + in + assert (let total' = sum $ map fst pl'' + in total == 0 || (total' > (PoolStake $ 999999 % 1000000) && + total' < (PoolStake $ 1000001 % 1000000)) + ) + pl'' + where + adjustment :: PoolStake -> PoolStake + adjustment = + case ledgerPeersKind of + AllLedgerPeers -> + -- We do loose some precision in the conversion. However we care about + -- precision in the order of 1 block per year and for that a Double is + -- good enough. + PoolStake . toRational . sqrt @Double . fromRational . unPoolStake + BigLedgerPeers -> + id diff --git a/ouroboros-network/CHANGELOG.md b/ouroboros-network/CHANGELOG.md index 3503dea5da0..a21d7ce5167 100644 --- a/ouroboros-network/CHANGELOG.md +++ b/ouroboros-network/CHANGELOG.md @@ -4,6 +4,10 @@ ### Breaking changes +* moved `accBigPoolStake` and `reRelativeStake` to ouroboros-networking-api + in order to expose functionality of creating snapshots of big ledger peers, + eg. for Genesis consensus mode. + ### Non-Breaking changes * Refactored signature of `LedgerPeers.ledgerPeersThread` for concision diff --git a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/LedgerPeers.hs b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/LedgerPeers.hs index 3aae41ed196..813f9684283 100644 --- a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/LedgerPeers.hs +++ b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/LedgerPeers.hs @@ -175,7 +175,7 @@ prop_pick100 seed (NonNegative n) (ArbLedgerPeersKind ledgerPeersKind) (MockRoot accumulatedStakeMap = case ledgerPeersKind of AllLedgerPeers -> accPoolStake sps - BigLedgerPeers -> accBigPoolStake sps + BigLedgerPeers -> accBigPoolStakeMap sps sim :: IOSim s [RelayAccessPoint] sim = do @@ -334,7 +334,7 @@ prop_accBigPoolStake (LedgerPools lps@(_:_)) = in counterexample ("initial sublist vaiolation: " ++ show (elems, lps')) $ elems `isPrefixOf` lps' where - accumulatedStakeMap = accBigPoolStake lps + accumulatedStakeMap = accBigPoolStakeMap lps prop_getLedgerPeers :: ArbitrarySlotNo -> ArbitraryLedgerStateJudgement diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/LedgerPeers.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/LedgerPeers.hs index 21280690da1..27ab5e8ae36 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSelection/LedgerPeers.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/LedgerPeers.hs @@ -7,7 +7,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} - #if __GLASGOW_HASKELL__ >= 908 {-# OPTIONS_GHC -Wno-x-partial #-} #endif @@ -25,7 +24,7 @@ module Ouroboros.Network.PeerSelection.LedgerPeers , LedgerPeersKind (..) -- * Ledger Peers specific functions , accPoolStake - , accBigPoolStake + , accBigPoolStakeMap , bigLedgerPeerQuota -- * DNS based provider for ledger root peers , WithLedgerPeersArgs (..) @@ -37,19 +36,16 @@ module Ouroboros.Network.PeerSelection.LedgerPeers , resolveLedgerPeers ) where -import Control.Exception (assert) import Control.Monad (when) import Control.Monad.Class.MonadAsync import Control.Monad.Class.MonadTime.SI import Control.Tracer (Tracer, traceWith) -import Data.Bifunctor (first) import Data.IP qualified as IP -import Data.List (foldl', sortOn) +import Data.List (foldl') import Data.List.NonEmpty (NonEmpty (..)) import Data.List.NonEmpty qualified as NonEmpty import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map -import Data.Ord (Down (..)) import Data.Ratio import System.Random @@ -63,6 +59,8 @@ import Data.Word (Word16, Word64) import Network.DNS qualified as DNS import Ouroboros.Network.PeerSelection.LedgerPeers.Common import Ouroboros.Network.PeerSelection.LedgerPeers.Type +import Ouroboros.Network.PeerSelection.LedgerPeers.Utils (accBigPoolStake, + bigLedgerPeerQuota, reRelativeStake) import Ouroboros.Network.PeerSelection.RelayAccessPoint import Ouroboros.Network.PeerSelection.RootPeersDNS import Ouroboros.Network.PeerSelection.RootPeersDNS.LedgerPeers @@ -125,68 +123,13 @@ accPoolStake = !acc = as + accst in (acc, (s, rs)) : ps --- | The total accumulated stake of big ledger peers. --- -bigLedgerPeerQuota :: AccPoolStake -bigLedgerPeerQuota = 0.9 - --- | Convert a list of pools with stake to a Map keyed on the accumulated stake --- which only contains big ledger peers, e.g. largest ledger peers which --- cumulatively control 90% of stake. --- -accBigPoolStake :: [(PoolStake, NonEmpty RelayAccessPoint)] - -> Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint) -accBigPoolStake = - Map.fromAscList -- the input list is ordered by `AccPoolStake`, thus we - -- can use `fromAscList` - . takeWhilePrev (\(acc, _) -> acc <= bigLedgerPeerQuota) - . go 0 - . sortOn (Down . fst) - . reRelativeStake BigLedgerPeers - where - takeWhilePrev :: (a -> Bool) -> [a] -> [a] - takeWhilePrev f as = - fmap snd - . takeWhile (\(a, _) -> maybe True f a) - $ zip (Nothing : (Just <$> as)) as - - -- natural fold - go :: AccPoolStake - -> [(PoolStake, NonEmpty RelayAccessPoint)] - -> [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))] - go _acc [] = [] - go !acc (a@(s, _) : as) = - let acc' = acc + AccPoolStake (unPoolStake s) - in (acc', a) : go acc' as - --- | Not all stake pools have valid \/ usable relay information. This means that --- we need to recalculate the relative stake for each pool. +-- | Take the result of 'accBigPoolStake' and turn it into -- -reRelativeStake :: LedgerPeersKind - -> [(PoolStake, NonEmpty RelayAccessPoint)] - -> [(PoolStake, NonEmpty RelayAccessPoint)] -reRelativeStake ledgerPeersKind pl = - let pl' = first adjustment <$> pl - total = foldl' (+) 0 (fst <$> pl') - pl'' = first (/ total) <$> pl' - in - assert (let total' = sum $ map fst pl'' - in total == 0 || (total' > (PoolStake $ 999999 % 1000000) && - total' < (PoolStake $ 1000001 % 1000000)) - ) - pl'' - where - adjustment :: PoolStake -> PoolStake - adjustment = - case ledgerPeersKind of - AllLedgerPeers -> - -- We do loose some precision in the conversion. However we care about - -- precision in the order of 1 block per year and for that a Double is - -- good enough. - PoolStake . toRational . sqrt @Double . fromRational . unPoolStake - BigLedgerPeers -> - id - +accBigPoolStakeMap :: [(PoolStake, NonEmpty RelayAccessPoint)] + -> Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint) +accBigPoolStakeMap = Map.fromAscList -- the input list is ordered by `AccPoolStake`, thus we + -- can use `fromAscList` + . accBigPoolStake -- | Try to pick n random peers using stake distribution. -- @@ -318,9 +261,9 @@ ledgerPeersThread PeerActionsDNS { ) <$> atomically (getLedgerPeers wlpConsensusInterface ula) let peersStake = accPoolStake peers - bigPeersStake = accBigPoolStake peers - traceWith wlpTracer $ FetchingNewLedgerState (Map.size peersStake) (Map.size bigPeersStake) - return (peersStake, bigPeersStake, now) + bigPeersStakeMap = accBigPoolStakeMap peers + traceWith wlpTracer $ FetchingNewLedgerState (Map.size peersStake) (Map.size bigPeersStakeMap) + return (peersStake, bigPeersStakeMap, now) else do traceWith wlpTracer $ ReusingLedgerState (Map.size peerMap) age return (peerMap, bigPeerMap, oldTs) diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/LedgerPeers/Common.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/LedgerPeers/Common.hs index 1372cfb6445..36b9db269b2 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSelection/LedgerPeers/Common.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/LedgerPeers/Common.hs @@ -21,11 +21,6 @@ data IsLedgerPeer = IsLedgerPeer | IsNotLedgerPeer deriving (Eq, Show) --- | Which ledger peers to pick. --- -data LedgerPeersKind = AllLedgerPeers | BigLedgerPeers - deriving Show - -- | Ledger Peer request result -- data LedgerPeers = LedgerPeers LedgerStateJudgement -- ^ Current ledger state