Skip to content

Commit

Permalink
Gave better names to functions moved to public ouroboros-network-api
Browse files Browse the repository at this point in the history 
component.
Added property tests to check whether ledger peer snapshot peers are
provided in appropriate circumstances.
  • Loading branch information
@crocodile-dentist
crocodile-dentist committed May 3, 2024
1 parent 9dddb46 commit 2f5f34a
Show file tree
Hide file tree
Showing 3 changed files with 209 additions and 46 deletions.
16 changes: 8 additions & 8 deletions ouroboros-network-api/src/Ouroboros/Network/PeerSelection/LedgerPeers/Utils.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -3,8 +3,8 @@

module Ouroboros.Network.PeerSelection.LedgerPeers.Utils
( bigLedgerPeerQuota
, accBigPoolStake
, reRelativeStake
, accumulateBigLedgerStake
, recomputeRelativeStake
, AccPoolStake (..)
, PoolStake (..)
, RelayAccessPoint (..)
Expand All @@ -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 =
Expand All @@ -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 = foldl' (+) 0 (fst <$> pl')
pl'' = first (/ total) <$> pl'
Expand Down
173 changes: 163 additions & 10 deletions ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/LedgerPeers.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -2,6 +2,7 @@
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ParallelListComp #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
Expand All @@ -11,6 +12,7 @@ module Test.Ouroboros.Network.LedgerPeers where
import Codec.CBOR.FlatTerm
import Control.Concurrent.Class.MonadSTM.Strict
import Control.Exception (SomeException (..))
import Control.Monad (forM)
import Control.Monad.Class.MonadAsync
import Control.Monad.Class.MonadFork
import Control.Monad.Class.MonadSay
Expand All @@ -19,8 +21,12 @@ import Control.Monad.Class.MonadTime.SI
import Control.Monad.Class.MonadTimer.SI
import Control.Monad.IOSim hiding (SimResult)
import Control.Tracer (Tracer (..), nullTracer, traceWith)
import Data.Bifunctor (Bifunctor (bimap))
import Data.Foldable (foldrM)
import Data.Functor ((<&>))
import Data.IP qualified as IP
import Data.List (foldl', intercalate, isPrefixOf, nub, sortOn)
import Data.List (foldl', intercalate, isPrefixOf, nub, sort, sortOn, zip4,
zip6)
import Data.List.NonEmpty qualified as NonEmpty
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
Expand All @@ -37,6 +43,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
Expand All @@ -46,13 +54,16 @@ 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 encode/decode" prop_ledgerPeerSnapshot
, testProperty "Choose big pool peers from ledger or snapshot" prop_use_snapshot_bigledger_peers
]

newtype ArbitraryPortNumber = ArbitraryPortNumber { getArbitraryPortNumber :: PortNumber }
Expand Down Expand Up @@ -100,7 +111,7 @@ newtype ArbitrarySlotNo =
-- of the tests we run.
instance Arbitrary ArbitrarySlotNo where
arbitrary =
ArbitrarySlotNo . SlotNo <$> arbitrarySizedBoundedIntegral
ArbitrarySlotNo . SlotNo <$> arbitrary

data StakePool = StakePool {
spStake :: !Word64
Expand Down Expand Up @@ -158,6 +169,122 @@ instance Arbitrary ArbLedgerPeersKind where
shrink (ArbLedgerPeersKind AllLedgerPeers) = [ArbLedgerPeersKind BigLedgerPeers]
shrink (ArbLedgerPeersKind BigLedgerPeers) = []

-- | This test checks whether requesting ledger peers works as intended
-- when snapshot data is available. A number of requests is queued up
-- with changing ledger and snapshot slot positions (simulating chain advancement and
-- reloading of snapshot data). For each request, peers must be returned from the right
-- source - either the ledger or snapshot, depending on whether which source is fresher,
-- as well as taking into account the type of ledger peers being requested -- all or big only.
--
prop_use_snapshot_bigledger_peers :: Word16
-> MockRoots
-> DelayAndTimeoutScripts
-> ArbitraryLedgerStateJudgement
-> Property
prop_use_snapshot_bigledger_peers seed (MockRoots _ dnsMapScript _ _)
(DelayAndTimeoutScripts dnsLookupDelayScript dnsTimeoutScript)
(ArbitraryLedgerStateJudgement lsj) = property $ do
-- snapshotSlots has duplicates removed since the test will fail when two consecutive
-- snapshot slot numbers are identical but the ledger pools are different (which is likely given random generation).
-- When using a particular snapshot, the request function provided by withLedgerPeers caches the results for
-- the corresponding slot number to avoid recomputating the same things every time we request a new peer when snapshot
-- data is used. Furthermore, each test is limited to roughly ~10 slot changes to speed things up.
(snapshotSlots, ledgerSlots) <- bimap nub sort . unzip
<$> sized (\n -> if n <= 10
then listOf1 arbitrary
else resize 10 (listOf1 (resize n arbitrary)))
let snapshotSlots' = snapshotSlots ++ repeat (last snapshotSlots) -- ^ fill in missing slots removed by nub

(ledgerPeersKinds, ledgerPools) <- unzip <$> forM ledgerSlots
(\(Positive relativeToSlot) ->
(,) <$> arbitrary <*> resize relativeToSlot arbitrary
`suchThat`
(not . null . getLedgerPools))

snapshotPools :: [Maybe LedgerPools] <-
forM snapshotSlots (\(Positive relativeToSlot) -> resize relativeToSlot arbitrary
`suchThat` maybe True (not . null . getLedgerPools))
let snapshotPools' = snapshotPools ++ repeat (last snapshotPools) -- ^ fill in missing data

let ledgerPeerSnapshots = [snap <&> \(LedgerPools pools) ->
LedgerPeerSnapshot (At (fromIntegral slot), Map.toList $ accPoolStake pools)
| snap <- snapshotPools
| (Positive slot) <- snapshotSlots]

(rng1, rng2) = split . mkStdGen . fromIntegral $ seed
sim :: IOSim s [(NumberOfPeers, Set RelayAccessPoint)]
sim = do
dnsMapVar <- newTVarIO (scriptHead dnsMapScript)
dnsTimeoutScriptVar <- initScript' dnsTimeoutScript
dnsLookupDelayScriptVar <- initScript' dnsLookupDelayScript
dnsSemaphore <- newLedgerAndPublicRootDNSSemaphore
snapshotScript <- initScript' . Script . NonEmpty.fromList $ ledgerPeerSnapshots
ledgerPeersScript <- initScript' . Script . NonEmpty.fromList $ getLedgerPools <$> ledgerPools
slotScript <- initScript' . Script . NonEmpty.fromList $ At . fromIntegral . getPositive <$> ledgerSlots
let interface = LedgerPeersConsensusInterface
(stepScriptSTM' slotScript)
(pure lsj)
(stepScriptSTM' ledgerPeersScript)

withLedgerPeers
PeerActionsDNS { paToPeerAddr = curry IP.toSockAddr,
paDnsActions = mockDNSActions @SomeException dnsMapVar dnsTimeoutScriptVar dnsLookupDelayScriptVar,
paDnsSemaphore = dnsSemaphore }
WithLedgerPeersArgs { wlpRng = rng1,
wlpConsensusInterface = interface,
wlpTracer = verboseTracer,
wlpGetUseLedgerPeers = pure $ UseLedgerPeers Always,
wlpGetLedgerPeerSnapshot = stepScriptSTM' snapshotScript }
(\request _ ->
forM (zip4 ledgerPools snapshotPools'
ledgerPeersKinds (iterate (fst . split) rng2)) $
\(LedgerPools lp, sp, ArbLedgerPeersKind lpk, rng') -> do
threadDelay 1900 -- we need to invalidate ledger peer's cache
let maxRequest = case sp of
Just (LedgerPools sp') -> min (length lp) (length sp')
Nothing -> length lp
numRequested = NumberOfPeers . fromIntegral . fst . randomR (1, maxRequest) $ rng'
resp <- request numRequested lpk
pure $ case resp of
Nothing -> (numRequested, Set.empty)
Just (peers, _) -> (numRequested, Set.fromList [ RelayAccessAddress ip port
| Just (ip, port) <- IP.fromSockAddr
<$> Set.toList peers]))

return . ioProperty $ do
tr' <- evaluateTrace (runSimTrace sim)
case tr' of
SimException e trace -> do
return $ counterexample (intercalate "\n" $ show e : trace) False
SimDeadLock trace -> do
return $ counterexample (intercalate "\n" $ "Deadlock" : trace) False
SimReturn results _trace -> do
return $ either (`counterexample` False) id evalChecks
where
evalChecks = foldrM step (property True) (zip6 results snapshotSlots' ledgerSlots ledgerPeersKinds ledgerPools snapshotPools')

step ((numRequested, peers), ss, ls, ArbLedgerPeersKind lpk, lpool, spool) pass =
let fixupSnapshotSlot = maybe (-1) getPositive (ss <$ spool)
snapshotSet spools = Set.fromList (concatMap (NonEmpty.toList . snd) $ getLedgerPools spools)
ledgerSet = Set.fromList (concatMap (NonEmpty.toList . snd) $ getLedgerPools lpool)
bigLedgerSet = Set.fromList (concatMap (NonEmpty.toList . snd . snd) . accumulateBigLedgerStake . getLedgerPools $ lpool)
source =
case spool of
Just spools | fixupSnapshotSlot > getPositive ls ->
snapshotSet spools `Set.union` ledgerSet
_otherwise -> case lpk of
AllLedgerPeers -> ledgerSet
BigLedgerPeers -> bigLedgerSet
in if peers `Set.isSubsetOf` source
then return pass
else Left $ intercalate "\n"
["Counterexample:", "Requested: "++ show numRequested,
"Type requested: " ++ show lpk,
"Ledger slot: " ++ show ls, "Snapshot slot? " ++ show (ss <$ spool),
show peers, "========================", "violates Set.isSubsetOf:",
"========================", show source]


-- | A pool with 100% stake should always be picked.
prop_pick100 :: Word16
-> NonNegative Int -- ^ number of pools with 0 stake
Expand Down Expand Up @@ -197,7 +324,8 @@ prop_pick100 seed (NonNegative n) (ArbLedgerPeersKind ledgerPeersKind) (MockRoot
WithLedgerPeersArgs { wlpRng = rng,
wlpConsensusInterface = interface,
wlpTracer = verboseTracer,
wlpGetUseLedgerPeers = pure $ UseLedgerPeers Always }
wlpGetUseLedgerPeers = pure $ UseLedgerPeers Always,
wlpGetLedgerPeerSnapshot = pure Nothing }
(\request _ -> do
threadDelay 1900 -- we need to invalidate ledger peer's cache
resp <- request (NumberOfPeers 1) ledgerPeersKind
Expand Down Expand Up @@ -257,7 +385,8 @@ prop_pick (LedgerPools lps) (ArbLedgerPeersKind ledgerPeersKind) count seed (Moc
WithLedgerPeersArgs { wlpRng = rng,
wlpConsensusInterface = interface,
wlpTracer = verboseTracer,
wlpGetUseLedgerPeers = pure $ UseLedgerPeers (After 0) }
wlpGetUseLedgerPeers = pure $ UseLedgerPeers (After 0),
wlpGetLedgerPeerSnapshot = pure $ Nothing }
(\request _ -> do
threadDelay 1900 -- we need to invalidate ledger peer's cache
resp <- request (NumberOfPeers count) ledgerPeersKind
Expand Down Expand Up @@ -310,10 +439,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)
Expand All @@ -327,7 +455,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
Expand All @@ -339,6 +467,31 @@ prop_accBigPoolStake (LedgerPools lps@(_:_)) =
where
accumulatedStakeMap = accBigPoolStakeMap lps

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
Expand Down

0 comments on commit 2f5f34a

Please sign in to comment.