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

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

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

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

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

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

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

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)

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