diff --git a/ouroboros-network-api/CHANGELOG.md b/ouroboros-network-api/CHANGELOG.md index 830e44dac12..71aa256af52 100644 --- a/ouroboros-network-api/CHANGELOG.md +++ b/ouroboros-network-api/CHANGELOG.md @@ -6,7 +6,7 @@ * Changed `LedgerConsensusInterface` type: `LedgerConsensusInterface` now has to fill 3 STM actions: - * `lpGetLatestSlot :: STM m SlotNo` + * `lpGetLatestSlot :: STM m (WithOrigin SlotNo)` * `lpGetLedgerStateJudgment :: STM m LedgerStateJudgement` * `lpGetLedgerPeers :: STM m [(PoolStake, NonEmpty RelayAccessPoint)]` 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 e09efc8b2fe..c9ca11d629f 100644 --- a/ouroboros-network-api/src/Ouroboros/Network/PeerSelection/LedgerPeers/Type.hs +++ b/ouroboros-network-api/src/Ouroboros/Network/PeerSelection/LedgerPeers/Type.hs @@ -17,7 +17,7 @@ module Ouroboros.Network.PeerSelection.LedgerPeers.Type , isLedgerPeersEnabled ) where -import Cardano.Slotting.Slot (SlotNo (..)) +import Cardano.Slotting.Slot (SlotNo (..), WithOrigin) import Control.Concurrent.Class.MonadSTM import Control.DeepSeq (NFData (..)) import Data.List.NonEmpty (NonEmpty) @@ -75,7 +75,7 @@ data LedgerStateJudgement = YoungEnough | TooOld -- | Return ledger state information and ledger peers. -- data LedgerPeersConsensusInterface m = LedgerPeersConsensusInterface { - lpGetLatestSlot :: STM m SlotNo, + lpGetLatestSlot :: STM m (WithOrigin SlotNo), lpGetLedgerStateJudgement :: STM m LedgerStateJudgement, lpGetLedgerPeers :: STM m [(PoolStake, NonEmpty RelayAccessPoint)] } diff --git a/ouroboros-network/CHANGELOG.md b/ouroboros-network/CHANGELOG.md index 5828a1a1c78..a53372f393f 100644 --- a/ouroboros-network/CHANGELOG.md +++ b/ouroboros-network/CHANGELOG.md @@ -54,6 +54,9 @@ * Disable mean reward for new peers +* Fix `targetPeers` monitoring action to use the correct set of local peers + when in sensitive mode. + ## 0.11.0.0 -- 2023-01-22 ### Breaking changes 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 4ad7cb8a745..6a6f416acf5 100644 --- a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/LedgerPeers.hs +++ b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/LedgerPeers.hs @@ -32,7 +32,7 @@ import System.Random import Network.DNS (Domain) -import Cardano.Slotting.Slot (SlotNo) +import Cardano.Slotting.Slot (SlotNo, WithOrigin (..)) import Control.Concurrent.Class.MonadSTM.Strict import Ouroboros.Network.PeerSelection.LedgerPeers import Ouroboros.Network.PeerSelection.RelayAccessPoint @@ -187,7 +187,7 @@ prop_pick100 seed (NonNegative n) (ArbLedgerPeersKind ledgerPeersKind) (MockRoot withLedgerPeers rng dnsSemaphore (curry IP.toSockAddr) verboseTracer - (pure (UseLedgerPeers (After 0))) + (pure (UseLedgerPeers Always)) interface (mockDNSActions @SomeException dnsMapVar dnsTimeoutScriptVar dnsLookupDelayScriptVar) (\request _ -> do @@ -203,7 +203,7 @@ prop_pick100 seed (NonNegative n) (ArbLedgerPeersKind ledgerPeersKind) (MockRoot where interface = LedgerPeersConsensusInterface - (pure slot) + (pure $ At slot) (pure lsj) (pure (Map.elems accumulatedStakeMap)) @@ -260,7 +260,7 @@ prop_pick (LedgerPools lps) (ArbLedgerPeersKind ledgerPeersKind) count seed (Moc where interface :: LedgerPeersConsensusInterface (IOSim s) interface = LedgerPeersConsensusInterface - (pure slot) + (pure $ At slot) (pure lsj) (pure lps) @@ -336,21 +336,28 @@ prop_getLedgerPeers :: ArbitrarySlotNo prop_getLedgerPeers (ArbitrarySlotNo curSlot) (ArbitraryLedgerStateJudgement lsj) (LedgerPools lps) - slot = - let sim :: IOSim m LedgerPeers - sim = atomically $ getLedgerPeers interface (getArbitrarySlotNo slot) + (ArbitrarySlotNo slot) = + let afterSlot = if slot == 0 + then Always + else After slot + sim :: IOSim m LedgerPeers + sim = atomically $ getLedgerPeers interface afterSlot result :: LedgerPeers result = runSimOrThrow sim in counterexample (show result) $ case result of - LedgerPeers _ _ -> property (curSlot >= getArbitrarySlotNo slot) - BeforeSlot -> property (curSlot < getArbitrarySlotNo slot) + LedgerPeers _ _ -> property (curSlot >= slot || afterSlot == Always) + BeforeSlot -> property (curSlot < slot) where + curSlotWO = if curSlot == 0 + then Origin + else At curSlot + interface :: LedgerPeersConsensusInterface (IOSim s) interface = LedgerPeersConsensusInterface - (pure curSlot) + (pure $ curSlotWO) (pure lsj) (pure (Map.elems (accPoolStake lps))) diff --git a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/PeerSelection/MockEnvironment.hs b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/PeerSelection/MockEnvironment.hs index b645efdf7ee..dea309d36fb 100644 --- a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/PeerSelection/MockEnvironment.hs +++ b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/PeerSelection/MockEnvironment.hs @@ -370,8 +370,9 @@ mockPeerSelectionActions' tracer traceWith tracer TraceEnvPublicRootTTL -- Read the current ledger state judgement - isSensitive <- atomically $ requiresBootstrapPeers <$> readUseBootstrapPeers - <*> readLedgerStateJudgement + usingBootstrapPeers <- atomically + $ requiresBootstrapPeers <$> readUseBootstrapPeers + <*> readLedgerStateJudgement -- If the ledger state is YoungEnough we should get ledger peers. -- Otherwise we should get bootstrap peers let publicConfigPeers = PublicRootPeers.getPublicConfigPeers publicRootPeers @@ -379,7 +380,7 @@ mockPeerSelectionActions' tracer ledgerPeers = PublicRootPeers.getLedgerPeers publicRootPeers bigLedgerPeers = PublicRootPeers.getBigLedgerPeers publicRootPeers result = - if isSensitive + if usingBootstrapPeers then PublicRootPeers.fromBootstrapPeers bootstrapPeers else case ledgerPeersKind of AllLedgerPeers diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/Monitor.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/Monitor.hs index d4492e5d237..16c8b7d4825 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/Monitor.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/Monitor.hs @@ -88,7 +88,9 @@ targetPeers PeerSelectionActions{readPeerSelectionTargets} ) -- We simply ignore target updates that are not "sane". - let -- We have to enforce the invariant that the number of root peers is + let usingBootstrapPeers = requiresBootstrapPeers bootstrapPeersFlag + ledgerStateJudgement + -- We have to enforce the invariant that the number of root peers is -- not more than the target number of known peers. It's unlikely in -- practice so it's ok to resolve it arbitrarily using clampToLimit. -- @@ -101,7 +103,9 @@ targetPeers PeerSelectionActions{readPeerSelectionTargets} localRootPeers' = LocalRootPeers.clampToLimit (targetNumberOfKnownPeers targets') - $ LocalRootPeers.clampToTrustable + $ (if usingBootstrapPeers + then LocalRootPeers.clampToTrustable + else id) $ localRootPeers -- We have to enforce that local and big ledger peers are disjoint. diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/LedgerPeers.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/LedgerPeers.hs index ee71a8ac3c2..ca144ca3174 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSelection/LedgerPeers.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/LedgerPeers.hs @@ -53,7 +53,7 @@ import Data.Ord (Down (..)) import Data.Ratio import System.Random -import Cardano.Slotting.Slot (SlotNo) +import Cardano.Slotting.Slot (WithOrigin (..)) import Control.Concurrent.Class.MonadSTM.Strict import Control.Monad.Class.MonadThrow import Data.Set (Set) @@ -84,17 +84,22 @@ import Ouroboros.Network.PeerSelection.RootPeersDNS.LedgerPeers getLedgerPeers :: MonadSTM m => LedgerPeersConsensusInterface m - -> SlotNo + -> AfterSlot -> STM m LedgerPeers getLedgerPeers (LedgerPeersConsensusInterface lpGetLatestSlot lpGetLedgerStateJudgement lpGetLedgerPeers) - slot = do - curSlot <- lpGetLatestSlot - if curSlot < slot - then pure BeforeSlot - else LedgerPeers <$> lpGetLedgerStateJudgement - <*> lpGetLedgerPeers + ulp = do + wOrigin <- lpGetLatestSlot + case (wOrigin, ulp) of + (_ , Always) -> ledgerPeers + (At curSlot, After slot) + | curSlot >= slot -> ledgerPeers + _ -> pure BeforeSlot + where + ledgerPeers = LedgerPeers + <$> lpGetLedgerStateJudgement + <*> lpGetLedgerPeers -- | Convert a list of pools with stake to a Map keyed on the accumulated stake. -- Consensus provides a list of pairs of relative stake and corresponding relays for all usable @@ -306,14 +311,11 @@ ledgerPeersThread inRng dnsSemaphore toPeerAddr tracer readUseLedgerAfter traceWith tracer DisabledLedgerPeers return (Map.empty, Map.empty, now) UseLedgerPeers ula -> do - let slotNumber = case ula of - Always -> 0 - After slot -> slot peers <- (\case BeforeSlot -> [] LedgerPeers _ peers -> peers ) - <$> atomically (getLedgerPeers ledgerPeersConsensusInterface slotNumber) + <$> atomically (getLedgerPeers ledgerPeersConsensusInterface ula) let peersStake = accPoolStake peers bigPeersStake = accBigPoolStake peers traceWith tracer $ FetchingNewLedgerState (Map.size peersStake) (Map.size bigPeersStake) diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/PeerSelectionActions.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/PeerSelectionActions.hs index 9430fc7b102..fd835c5b8c2 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSelection/PeerSelectionActions.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/PeerSelectionActions.hs @@ -160,9 +160,10 @@ withPeerSelectionActions -> m (PublicRootPeers peeraddr, DiffTime) requestPublicRootPeers ledgerPeersKind n getLedgerPeers dnsSemaphore = do -- Check if the node is in a sensitive state - isSensitive <- atomically $ requiresBootstrapPeers <$> readUseBootstrapPeers - <*> readLedgerStateJudgement - if isSensitive + usingBootstrapPeers <- atomically + $ requiresBootstrapPeers <$> readUseBootstrapPeers + <*> readLedgerStateJudgement + if usingBootstrapPeers then do -- If the ledger state is in sensitive state we should get trustable peers. (bootstrapPeers, dt) <- requestConfiguredBootstrapPeers dnsSemaphore n