Added ledger peer snapshot property tests

crocodile-dentist · crocodile-dentist · commit 748fcf701934 · 2024-07-23T13:10:37.000+02:00
Improved naming of functions related to calculating big ledger stake
distribution which were to moved public ouroboros-network-api component.
diff --git a/ouroboros-network-api/CHANGELOG.md b/ouroboros-network-api/CHANGELOG.md
@@ -14,6 +14,9 @@
   * New type supports CBOR & JSON for serialisation purposes.
   * Ledger peer snapshot is versioned in case changes need to be made to the
     encoding format in the future.
+* Renamed:
+  * `accBigPoolStake` -> `accumulateBigLedgerStake`
+     and `reRelativeStake` -> `recomputeRelativeStake`
 
 * Added `Measure` and `BoundedMeasure` instances for `SizeInBytes`.
 
diff --git a/ouroboros-network-api/src/Ouroboros/Network/PeerSelection/LedgerPeers/Utils.hs b/ouroboros-network-api/src/Ouroboros/Network/PeerSelection/LedgerPeers/Utils.hs
@@ -3,8 +3,8 @@
 
 module Ouroboros.Network.PeerSelection.LedgerPeers.Utils
   ( bigLedgerPeerQuota
-  , accBigPoolStake
-  , reRelativeStake
+  , accumulateBigLedgerStake
+  , recomputeRelativeStake
   , AccPoolStake (..)
   , PoolStake (..)
   , RelayAccessPoint (..)
@@ -29,13 +29,13 @@ bigLedgerPeerQuota = 0.9
 -- and tag each one with cumulative stake, with a cutoff
 -- at 'bigLedgerPeerQuota'
 --
-accBigPoolStake :: [(PoolStake, NonEmpty RelayAccessPoint)]
-                -> [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
-accBigPoolStake =
+accumulateBigLedgerStake :: [(PoolStake, NonEmpty RelayAccessPoint)]
+                         -> [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
+accumulateBigLedgerStake =
     takeWhilePrev (\(acc, _) -> acc <= bigLedgerPeerQuota)
     . go 0
     . sortOn (Down . fst)
-    . reRelativeStake BigLedgerPeers
+    . recomputeRelativeStake BigLedgerPeers
   where
     takeWhilePrev :: (a -> Bool) -> [a] -> [a]
     takeWhilePrev f as =
@@ -55,10 +55,10 @@ accBigPoolStake =
 -- | Not all stake pools have valid \/ usable relay information. This means that
 -- we need to recalculate the relative stake for each pool.
 --
-reRelativeStake :: LedgerPeersKind
+recomputeRelativeStake :: LedgerPeersKind
                 -> [(PoolStake, NonEmpty RelayAccessPoint)]
                 -> [(PoolStake, NonEmpty RelayAccessPoint)]
-reRelativeStake ledgerPeersKind pl =
+recomputeRelativeStake ledgerPeersKind pl =
     let pl'   = first adjustment <$> pl
         total = List.foldl' (+) 0 (fst <$> pl')
         pl''  = first (/ total) <$> pl'
diff --git a/ouroboros-network/CHANGELOG.md b/ouroboros-network/CHANGELOG.md
@@ -22,6 +22,11 @@
 - Fixed block fetch client assertion failure
 * Make it build with ghc-9.10
 * Implemented provision of big ledger peers from the snapshot by `ledgerPeersThread`
+* Added property test checking if `ledgerPeersThread` is providing big ledger peers
+  from the snapshot when appropriate conditions are met
+* Added property tests checking if `LedgerPeerSnapshot` CBOR encoding is valid,
+  and decode/encode = id, as well as some property tests for calculating big ledger
+  peers
 
 ## 0.16.1.1 -- 2024-06-28
 
diff --git a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/LedgerPeers.hs b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/LedgerPeers.hs
@@ -1,6 +1,5 @@
 {-# LANGUAGE BangPatterns        #-}
 {-# LANGUAGE DerivingVia         #-}
-{-# LANGUAGE LambdaCase          #-}
 {-# LANGUAGE NamedFieldPuns      #-}
 {-# LANGUAGE OverloadedStrings   #-}
 {-# LANGUAGE RankNTypes          #-}
@@ -41,6 +40,8 @@ import Network.DNS (Domain)
 import Cardano.Binary
 import Cardano.Slotting.Slot (SlotNo (..), WithOrigin (..))
 import Ouroboros.Network.PeerSelection.LedgerPeers
+import Ouroboros.Network.PeerSelection.LedgerPeers.Utils
+           (recomputeRelativeStake)
 import Ouroboros.Network.PeerSelection.RelayAccessPoint
 import Ouroboros.Network.PeerSelection.RootPeersDNS
 import Ouroboros.Network.Testing.Data.Script
@@ -50,11 +51,13 @@ import Test.Tasty
 import Test.Tasty.QuickCheck
 import Text.Printf
 
+
 tests :: TestTree
 tests = testGroup "Ouroboros.Network.LedgerPeers"
   [ testProperty "Pick 100%" prop_pick100
   , testProperty "Pick" prop_pick
-  , testProperty "accBigPoolStake" prop_accBigPoolStake
+  , testProperty "accumulateBigLedgerStake" prop_accumulateBigLedgerStake
+  , testProperty "recomputeRelativeStake" prop_recomputeRelativeStake
   , testProperty "getLedgerPeers invariants" prop_getLedgerPeers
   , testProperty "LedgerPeerSnapshot CBOR version 1" prop_ledgerPeerSnapshotCBORV1
   , testProperty "LedgerPeerSnapshot JSON version 1" prop_ledgerPeerSnapshotJSONV1
@@ -105,7 +108,7 @@ newtype ArbitrarySlotNo =
 -- of the tests we run.
 instance Arbitrary ArbitrarySlotNo where
     arbitrary =
-      ArbitrarySlotNo . SlotNo <$> arbitrarySizedBoundedIntegral
+      ArbitrarySlotNo . SlotNo <$> arbitrary
 
 data StakePool = StakePool {
       spStake :: !Word64
@@ -163,6 +166,93 @@ instance Arbitrary ArbLedgerPeersKind where
     shrink (ArbLedgerPeersKind AllLedgerPeers) = [ArbLedgerPeersKind BigLedgerPeers]
     shrink (ArbLedgerPeersKind BigLedgerPeers) = []
 
+newtype ArbStakeMapOverSource = ArbStakeMapOverSource { getArbStakeMapOverSource :: StakeMapOverSource }
+  deriving Show
+
+instance Arbitrary ArbStakeMapOverSource where
+  arbitrary = do
+    peerSnapshot <-
+      oneof [ pure Nothing, Just <$> genPeerSnapshot ]
+    ledgerWithOrigin <- genWithOrigin
+    ula <- arbitrary
+    ledgerPeers <-
+      case (ula, ledgerWithOrigin) of
+        (Always, _) -> LedgerPeers TooOld . getLedgerPools <$> arbitrary
+        (After slotNo, Origin) | slotNo > 0 -> return BeforeSlot
+        (After afterSlotNo, At atSlotNo)
+          | afterSlotNo <= atSlotNo -> LedgerPeers TooOld . getLedgerPools <$> arbitrary
+        _otherwise -> return BeforeSlot
+    (peerMap, bigPeerMap, cachedSlot) <-
+      return $ case peerSnapshot of
+                 Nothing -> (Map.empty, Map.empty, Nothing)
+                 Just (LedgerPeerSnapshotV1 (At slot, accPools))
+                   -> (Map.fromList accPools, Map.fromList accPools, Just slot)
+                 _otherwise -> error "impossible!"
+    return $ ArbStakeMapOverSource StakeMapOverSource {
+      ledgerWithOrigin,
+      ledgerPeers,
+      peerSnapshot,
+      peerMap,
+      bigPeerMap,
+      ula,
+      cachedSlot }
+    where
+      genWithOrigin = do
+        ArbitrarySlotNo slotNo <- arbitrary
+        return $ if slotNo == 0 then Origin else At slotNo
+      genPeerSnapshot = do
+        slotNo <- At . getPositive <$> arbitrary
+        pools <- accumulateBigLedgerStake . getLedgerPools <$> arbitrary
+        return $ LedgerPeerSnapshotV1 (slotNo, pools)
+
+-- | This test checks whether requesting ledger peers works as intended
+-- when snapshot data is available. For each request, peers must be returned from the right
+-- source - either the ledger or snapshot, depending on whether which source is fresher.
+--
+prop_ledgerPeerSnapshot_requests :: ArbStakeMapOverSource
+                                 -> Property
+prop_ledgerPeerSnapshot_requests ArbStakeMapOverSource {
+      getArbStakeMapOverSource = params@StakeMapOverSource {
+          ledgerWithOrigin,
+          ledgerPeers,
+          peerSnapshot,
+          ula } } =
+  counterexample (unlines
+                   ["Counterexample:", "Ledger slot " ++ show ledgerWithOrigin,
+                    "Ledger pools: " ++ show ledgerPeers,
+                    "Snapshot? :" ++ show peerSnapshot,
+                    "UseLedgerAfter: " ++ show ula]) $
+    let (poolMap, bigPoolMap, _slot) = stakeMapWithSlotOverSource params
+        bigPoolRelays = fmap (snd . snd) . Map.toList $ bigPoolMap
+        poolRelays    = fmap (snd . snd) . Map.toList $ poolMap
+    in case (ledgerWithOrigin, ledgerPeers, peerSnapshot) of
+        (At t, LedgerPeers _ ledgerPools, Just (LedgerPeerSnapshot (At t', snapshotAccStake)))
+          | t' >= t ->
+            snapshotRelays === bigPoolRelays .&&. bigPoolRelays === poolRelays
+          | otherwise ->
+                 bigPoolRelays === ledgerBigPoolRelays
+            .&&.    poolRelays === ledgerRelays
+          where
+            snapshotRelays = fmap (snd . snd) snapshotAccStake
+            ledgerBigPoolRelays   = fmap (snd . snd) (accumulateBigLedgerStake ledgerPools)
+            ledgerRelays = fmap (snd . snd) . Map.toList $ accPoolStake ledgerPools
+
+        (_, LedgerPeers _ ledgerPools, Nothing) ->
+               bigPoolRelays === ledgerBigPoolRelays
+          .&&.    poolRelays === ledgerRelays
+          where
+            ledgerBigPoolRelays = fmap (snd . snd) (accumulateBigLedgerStake ledgerPools)
+            ledgerRelays = fmap (snd . snd) . Map.toList $ accPoolStake ledgerPools
+
+        (_, _, Just (LedgerPeerSnapshot (At t', snapshotAccStake)))
+          | After slot <- ula, t' >= slot ->
+            snapshotRelays === bigPoolRelays .&&. bigPoolRelays === poolRelays
+          where
+            snapshotRelays = fmap (snd . snd) snapshotAccStake
+
+        _otherwise -> bigPoolRelays === [] .&&. poolRelays === []
+
+
 -- | A pool with 100% stake should always be picked.
 prop_pick100 :: Word16
              -> NonNegative Int -- ^ number of pools with 0 stake
@@ -317,10 +407,9 @@ prop_pick (LedgerPools lps) (ArbLedgerPeersKind ledgerPeersKind) count seed (Moc
                                         === fromIntegral count `min` numOfPeers)
 
 
-prop_accBigPoolStake :: LedgerPools -> Property
-prop_accBigPoolStake  (LedgerPools [])        = property True
-prop_accBigPoolStake  (LedgerPools lps@(_:_)) =
-
+prop_accumulateBigLedgerStake :: LedgerPools -> Property
+prop_accumulateBigLedgerStake  (LedgerPools [])        = property True
+prop_accumulateBigLedgerStake  (LedgerPools lps@(_:_)) =
          -- the accumulated map is non empty, whenever ledger peers set is non
          -- empty
          not (Map.null accumulatedStakeMap)
@@ -334,7 +423,7 @@ prop_accBigPoolStake  (LedgerPools lps@(_:_)) =
              >= unAccPoolStake bigLedgerPeerQuota)
 
          -- This property checks that elements of
-         -- `accBigPoolStake` form an initial sub-list of the ordered ledger
+         -- `accBigPoolStakeMap` form an initial sub-list of the ordered ledger
          -- peers by stake (from large to small).
          --
          -- We relay on the fact that `Map.elems` returns a list of elements
@@ -346,6 +435,37 @@ prop_accBigPoolStake  (LedgerPools lps@(_:_)) =
   where
     accumulatedStakeMap = accBigPoolStakeMap lps
 
+-- |This functions checks the following properties:
+-- 1. The accumulated relative stake adds up to unity
+-- 2. No pool relative stake can be less than 0
+-- 3. The relays aren't mangled
+-- 4. Running this function multiple times always produces the same result
+--
+prop_recomputeRelativeStake :: LedgerPools -> Property
+prop_recomputeRelativeStake (LedgerPools []) = property True
+prop_recomputeRelativeStake (LedgerPools lps) = property $ do
+  lpk <- genLedgerPeersKind
+  let (accStake, relayAccessPointsUnchangedNonNegativeStake) = go (reStake lpk) lps (0, True)
+  return $     counterexample "recomputeRelativeStake: relays modified or negative pool stake calculated"
+                             relayAccessPointsUnchangedNonNegativeStake
+          .&&. accStake === 1
+          .&&. counterexample "violates idempotency"
+                              ((recomputeRelativeStake BigLedgerPeers . recomputeRelativeStake BigLedgerPeers $ lps) == recomputeRelativeStake BigLedgerPeers lps)
+  where
+    genLedgerPeersKind = elements [AllLedgerPeers, BigLedgerPeers]
+    reStake lpk = recomputeRelativeStake lpk lps
+    -- compare relay access points in both lists for equality
+    -- where we assume that recomputerelativestake doesn't change
+    -- the order, and sum up relative stake to make sure it adds up to 1
+    go ((normPoolStake, raps):rest) ((_, raps'):rest') (accStake, _) =
+      if raps == raps' && normPoolStake >= 0
+      then go rest rest' (accStake + normPoolStake, True)
+      else (accStake + normPoolStake, False)
+    go [] (_:_) (accStake, _) = (accStake, False)
+    go (_:_) [] (accStake, _) = (accStake, False)
+    go _ _ (accStake, relayAccessPointsUnchangedNonNegativeStake) = (accStake, relayAccessPointsUnchangedNonNegativeStake)
+
+
 prop_getLedgerPeers :: ArbitrarySlotNo
                     -> ArbitraryLedgerStateJudgement
                     -> LedgerPools
diff --git a/ouroboros-network/src/Ouroboros/Network/Diffusion/P2P.hs b/ouroboros-network/src/Ouroboros/Network/Diffusion/P2P.hs
@@ -245,11 +245,11 @@ nullTracers =
 data ArgumentsExtra m = ArgumentsExtra {
       -- | selection targets for the peer governor
       --
-      daPeerSelectionTargets  :: PeerSelectionTargets
+      daPeerSelectionTargets   :: PeerSelectionTargets
 
-    , daReadLocalRootPeers    :: STM m (LocalRootPeers.Config RelayAccessPoint)
-    , daReadPublicRootPeers   :: STM m (Map RelayAccessPoint PeerAdvertise)
-    , daReadUseBootstrapPeers :: STM m UseBootstrapPeers
+    , daReadLocalRootPeers     :: STM m (LocalRootPeers.Config RelayAccessPoint)
+    , daReadPublicRootPeers    :: STM m (Map RelayAccessPoint PeerAdvertise)
+    , daReadUseBootstrapPeers  :: STM m UseBootstrapPeers
     -- | Depending on configuration, node may provide us with
     -- a snapshot of big ledger peers taken at some slot on the chain.
     -- These peers may be selected by ledgerPeersThread when requested
@@ -260,8 +260,8 @@ data ArgumentsExtra m = ArgumentsExtra {
     -- | Peer's own PeerSharing value.
     --
     -- This value comes from the node's configuration file and is static.
-    , daOwnPeerSharing        :: PeerSharing
-    , daReadUseLedgerPeers    :: STM m UseLedgerPeers
+    , daOwnPeerSharing         :: PeerSharing
+    , daReadUseLedgerPeers     :: STM m UseLedgerPeers
 
       -- | Timeout which starts once all responder protocols are idle. If the
       -- responders stay idle for duration of the timeout, the connection will
@@ -272,7 +272,7 @@ data ArgumentsExtra m = ArgumentsExtra {
       --
       -- See 'serverProtocolIdleTimeout'.
       --
-    , daProtocolIdleTimeout   :: DiffTime
+    , daProtocolIdleTimeout    :: DiffTime
 
       -- | Time for which /node-to-node/ connections are kept in
       -- 'TerminatingState', it should correspond to the OS configured @TCP@
@@ -282,21 +282,21 @@ data ArgumentsExtra m = ArgumentsExtra {
       -- purpose is to be resilient for delayed packets in the same way @TCP@
       -- is using @TIME_WAIT@.
       --
-    , daTimeWaitTimeout       :: DiffTime
+    , daTimeWaitTimeout        :: DiffTime
 
       -- | Churn interval between churn events in deadline mode.  A small fuzz
       -- is added (max 10 minutes) so that not all nodes churn at the same time.
       --
       -- By default it is set to 3300 seconds.
       --
-    , daDeadlineChurnInterval :: DiffTime
+    , daDeadlineChurnInterval  :: DiffTime
 
       -- | Churn interval between churn events in bulk sync mode.  A small fuzz
       -- is added (max 1 minute) so that not all nodes churn at the same time.
       --
       -- By default it is set to 300 seconds.
       --
-    , daBulkChurnInterval     :: DiffTime
+    , daBulkChurnInterval      :: DiffTime
     }
 
 --
diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/LedgerPeers.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/LedgerPeers.hs
@@ -26,6 +26,7 @@ module Ouroboros.Network.PeerSelection.LedgerPeers
   , StakeMapOverSource (..)
     -- * Ledger Peers specific functions
   , accPoolStake
+  , accumulateBigLedgerStake
   , accBigPoolStakeMap
   , bigLedgerPeerQuota
   , stakeMapWithSlotOverSource
@@ -63,8 +64,9 @@ 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.LedgerPeers.Utils
+           (accumulateBigLedgerStake, bigLedgerPeerQuota,
+           recomputeRelativeStake)
 import Ouroboros.Network.PeerSelection.RelayAccessPoint
 import Ouroboros.Network.PeerSelection.RootPeersDNS
 import Ouroboros.Network.PeerSelection.RootPeersDNS.LedgerPeers
@@ -114,7 +116,7 @@ accPoolStake :: [(PoolStake, NonEmpty RelayAccessPoint)]
 accPoolStake =
       Map.fromList
     . List.foldl' fn []
-    . reRelativeStake AllLedgerPeers
+    . recomputeRelativeStake AllLedgerPeers
   where
     fn :: [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
        -> (PoolStake, NonEmpty RelayAccessPoint)
@@ -133,7 +135,7 @@ 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
+                     . accumulateBigLedgerStake
 
 -- | Try to pick n random peers using stake distribution.
 --
