Fix local roots clamp to trustable and changed API

IntersectMBO · Feb 14, 2024 · 2b44951 · 2b44951
1 parent f83f71a
commit 2b44951
Show file tree

Hide file tree

Showing 8 changed files with 51 additions and 33 deletions.
diff --git 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
@@ -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
@@ -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
@@ -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
@@ -370,16 +370,17 @@ 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
           bootstrapPeers    = PublicRootPeers.getBootstrapPeers publicRootPeers
           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
@@ -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
@@ -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
@@ -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