Merging commits from master (should be an empty commit or trivial to

resolve conflicts when this branch is merged into master)

Squashed commit of the following:

commit e48175f
Merge: 8ab4448 7d49003
Author: Armando Santos <armandoifsantos@gmail.com>
Date:   Wed Feb 21 13:42:17 2024 +0000

    Merge pull request #4810 from IntersectMBO/bolt12/bootstrapPeers-forget

    Forget non-established bootstrap peers

commit 7d49003
Author: Armando Santos <armando@well-typed.com>
Date:   Wed Feb 21 10:32:52 2024 +0000

    Added FetchMode script to Testnet tests

commit 05ab38b
Author: Armando Santos <armando@well-typed.com>
Date:   Mon Feb 19 15:38:02 2024 +0000

    Churn BootstrapPeers

commit 58a4f3b
Author: Armando Santos <armando@well-typed.com>
Date:   Tue Feb 20 15:53:55 2024 +0000

    Forget about non established bootstrap peers

commit 8ab4448
Merge: b118f38 b4f086a
Author: Marcin Wójtowicz <158484752+crocodile-dentist@users.noreply.github.com>
Date:   Tue Feb 20 12:48:42 2024 +0000

    Merge pull request #4803 from IntersectMBO/refactor/withpeerselectionaction

    refactor withPeerSelectionAction argument list

commit b4f086a
Author: Marcin Wójtowicz <158484752+crocodile-dentist@users.noreply.github.com>
Date:   Tue Feb 20 11:55:49 2024 +0100

    Update ouroboros-network/src/Ouroboros/Network/PeerSelection/PeerSelectionActions.hs

    Co-authored-by: Marcin Szamotulski <coot@coot.me>

commit 5cf418c
Author: Marcin Wójtowicz <marcin.wojtowicz@iohk.io>
Date:   Sun Feb 11 18:53:32 2024 +0100

    refactor withPeerSelectionAction argument list

commit b118f38
Merge: f83f71a 2b44951
Author: Armando Santos <armandoifsantos@gmail.com>
Date:   Wed Feb 14 18:06:56 2024 +0000

    Merge pull request #4799 from IntersectMBO/bolt12/bootstrap-peers-fix

    Fix local roots clamp to trustable & changed LedgerPeersConsensusInterface function type signature

commit 2b44951
Author: Armando Santos <armando@well-typed.com>
Date:   Wed Feb 7 14:14:10 2024 +0000

    Fix local roots clamp to trustable and changed API

commit f83f71a
Merge: 436d902 2193d67
Author: Marcin Szamotulski <coot@coot.me>
Date:   Mon Feb 12 12:07:48 2024 +0000

    Merge pull request #4796 from AndrewWestberg/amw/comment_fix

    Fix comment: Duplex started in NodeToNodeV_10

commit 2193d67
Author: Andrew Westberg <andrewwestberg@gmail.com>
Date:   Fri Feb 2 19:30:59 2024 +0000

    Fix comment: Duplex started in NodeToNodeV_10

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)]`
 

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)]
   }

ouroboros-network/CHANGELOG.md

@@ -15,6 +15,7 @@
 * Updated type of constructor in `TraceLocalRootPeers`
 * Added `TraceDebugState` message to `TracePeerSelection` for tracing
   peer selection upon getting a USR1 sig.
+* Changed withPeerSelectionActions and withLedgerPeers signatures
 
 * Removed `computePeers` callback in `daApplicationInitiatorAndResponderMode`.
 * Changed `peerSharingServer` to require `PeerSharingAPI`.
@@ -57,6 +58,14 @@
 
 * Disable mean reward for new peers
 
+* Fix `targetPeers` monitoring action to use the correct set of local peers
+  when in sensitive mode.
+
+* Forget non-established bootstrap peers when transitioning from
+  `TooOld` state to `YoungEnough`
+
+* Implemented Churn for bootstrap peers
+
 * Refactored `computePeerSharingPeers` and moved it to
   `Ouroboros.Network.Peersharing`
 * Added `PeerSharingAPI` with all the things necessary to run peer sharing.

ouroboros-network/ouroboros-network.cabal

@@ -55,6 +55,7 @@ library
                        Ouroboros.Network.PeerSelection.State.EstablishedPeers
                        Ouroboros.Network.PeerSelection.State.KnownPeers
                        Ouroboros.Network.PeerSelection.State.LocalRootPeers
+                       Ouroboros.Network.PeerSelection.RootPeersDNS
                        Ouroboros.Network.PeerSelection.RootPeersDNS.DNSActions
                        Ouroboros.Network.PeerSelection.RootPeersDNS.DNSSemaphore
                        Ouroboros.Network.PeerSelection.RootPeersDNS.LocalRootPeers

ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/LedgerPeers.hs

@@ -32,11 +32,11 @@ 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
-import Ouroboros.Network.PeerSelection.RootPeersDNS.DNSSemaphore
+import Ouroboros.Network.PeerSelection.RootPeersDNS
 import Ouroboros.Network.Testing.Data.Script
 import Test.Ouroboros.Network.PeerSelection.RootPeersDNS
 import Test.QuickCheck
@@ -186,10 +186,13 @@ prop_pick100 seed (NonNegative n) (ArbLedgerPeersKind ledgerPeersKind) (MockRoot
           dnsSemaphore <- newLedgerAndPublicRootDNSSemaphore
 
           withLedgerPeers
-                rng dnsSemaphore (curry IP.toSockAddr) verboseTracer
-                (pure (UseLedgerPeers (After 0)))
-                interface
-                (mockDNSActions @SomeException dnsMapVar dnsTimeoutScriptVar dnsLookupDelayScriptVar)
+                PeerActionsDNS { paToPeerAddr = curry IP.toSockAddr,
+                                 paDnsActions = (mockDNSActions @SomeException dnsMapVar dnsTimeoutScriptVar dnsLookupDelayScriptVar),
+                                 paDnsSemaphore = dnsSemaphore }
+                WithLedgerPeersArgs { wlpRng = rng,
+                                      wlpConsensusInterface = interface,
+                                      wlpTracer = verboseTracer,
+                                      wlpGetUseLedgerPeers = pure $ UseLedgerPeers Always }
                 (\request _ -> do
                   threadDelay 1900 -- we need to invalidate ledger peer's cache
                   resp <- request (NumberOfPeers 1) ledgerPeersKind
@@ -203,7 +206,7 @@ prop_pick100 seed (NonNegative n) (ArbLedgerPeersKind ledgerPeersKind) (MockRoot
           where
             interface =
               LedgerPeersConsensusInterface
-                (pure slot)
+                (pure $ At slot)
                 (pure lsj)
                 (pure (Map.elems accumulatedStakeMap))
 
@@ -243,10 +246,13 @@ prop_pick (LedgerPools lps) (ArbLedgerPeersKind ledgerPeersKind) count seed (Moc
           dnsSemaphore <- newLedgerAndPublicRootDNSSemaphore
 
           withLedgerPeers
-                rng dnsSemaphore (curry IP.toSockAddr) verboseTracer
-                (pure (UseLedgerPeers (After 0)))
-                interface
-                (mockDNSActions @SomeException dnsMapVar dnsTimeoutScriptVar dnsLookupDelayScriptVar)
+                PeerActionsDNS { paToPeerAddr = curry IP.toSockAddr,
+                                 paDnsActions = mockDNSActions @SomeException dnsMapVar dnsTimeoutScriptVar dnsLookupDelayScriptVar,
+                                 paDnsSemaphore = dnsSemaphore }
+                WithLedgerPeersArgs { wlpRng = rng,
+                                      wlpConsensusInterface = interface,
+                                      wlpTracer = verboseTracer,
+                                      wlpGetUseLedgerPeers = pure $ UseLedgerPeers (After 0) }
                 (\request _ -> do
                   threadDelay 1900 -- we need to invalidate ledger peer's cache
                   resp <- request (NumberOfPeers count) ledgerPeersKind
@@ -260,7 +266,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 +342,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)))
 

ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/PeerSelection.hs

@@ -1780,21 +1780,28 @@ prop_governor_target_known_5_no_shrink_below (MaxTime maxTime) env =
           selectGovState (PublicRootPeers.getBigLedgerPeers . Governor.publicRootPeers)
                          events
 
+        bootstrapPeersSig :: Signal (Set PeerAddr)
+        bootstrapPeersSig =
+          selectGovState (PublicRootPeers.getBootstrapPeers . Governor.publicRootPeers)
+                         events
+
         knownPeersShrinksSig :: Signal (Set PeerAddr)
         knownPeersShrinksSig =
             Signal.nub
           . fmap (fromMaybe Set.empty)
           . Signal.difference
               -- We subtract all big ledger peers.  This is because we might
               -- first satisfy the target of known peers, and then learn that
-              -- one of them was a big ledger peers.  This would be a fake
-              -- shrink of known non big ledger peers.
+              -- one of them was a big ledger peers. We also subtract
+              -- bootstrap peers. This would be a fake shrink of known non
+              -- big ledger peers.
               --
               -- By subtracting a sum of `y` and `y'` we also do not account
               -- forgetting big ledger peers.
-              (\(x,y) (x',y') -> x Set.\\ x' Set.\\ y Set.\\ y')
-          $ (,) <$> govKnownPeersSig
-                <*> bigLedgerPeersSig
+              (\(x,y,z) (x',y',z') -> x Set.\\ x' Set.\\ y Set.\\ y' Set.\\ z Set.\\ z')
+          $ (,,) <$> govKnownPeersSig
+                 <*> bigLedgerPeersSig
+                 <*> bootstrapPeersSig
 
         unexpectedShrink :: Signal Bool
         unexpectedShrink =

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

ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Testnet.hs

@@ -68,7 +68,7 @@ import Test.Tasty
 import Test.Tasty.QuickCheck (testProperty)
 
 import Control.Exception (AssertionFailed (..), catch, evaluate)
-import Ouroboros.Network.BlockFetch (TraceFetchClientState (..))
+import Ouroboros.Network.BlockFetch (FetchMode (..), TraceFetchClientState (..))
 import Ouroboros.Network.ConnectionManager.Test.Timeouts (AllProperty (..),
            TestProperty (..), classifyActivityType, classifyEffectiveDataFlow,
            classifyNegotiatedDataFlow, classifyPrunings, classifyTermination,
@@ -690,6 +690,7 @@ unit_4177 = prop_inbound_governor_transitions_coverage absNoAttenuation script
               (Script (DNSLookupDelay {getDNSLookupDelay = 0.067} :| [DNSLookupDelay {getDNSLookupDelay = 0.097},DNSLookupDelay {getDNSLookupDelay = 0.101},DNSLookupDelay {getDNSLookupDelay = 0.096},DNSLookupDelay {getDNSLookupDelay = 0.051}]))
               Nothing
               False
+              (Script (FetchModeDeadline :| []))
           , [JoinNetwork 1.742857142857
             ,Reconfigure 6.33333333333 [(1,1,Map.fromList [(RelayAccessDomain "test2" 65535,(DoAdvertisePeer, IsNotTrustable))]),
                                         (1,1,Map.fromList [(RelayAccessAddress "0:6:0:3:0:6:0:5" 65530,(DoAdvertisePeer, IsNotTrustable))
@@ -721,6 +722,7 @@ unit_4177 = prop_inbound_governor_transitions_coverage absNoAttenuation script
                      ]))
              Nothing
              False
+             (Script (FetchModeDeadline :| []))
           , [JoinNetwork 0.183783783783
             ,Reconfigure 4.533333333333 [(1,1,Map.fromList [])]
             ]
@@ -1328,6 +1330,7 @@ unit_4191 = prop_diffusion_dns_can_recover absInfo script
                                                                    ]))
             Nothing
             False
+            (Script (FetchModeDeadline :| []))
             , [ JoinNetwork 6.710144927536
               , Kill 7.454545454545
               , JoinNetwork 10.763157894736
@@ -2338,7 +2341,8 @@ async_demotion_network_script =
                            = Nothing,
         naChainSyncEarlyExit
                            = False,
-        naPeerSharing      = PeerSharingDisabled
+        naPeerSharing      = PeerSharingDisabled,
+        naFetchModeScript  = singletonScript FetchModeDeadline
       }
 
 
@@ -2823,6 +2827,7 @@ prop_unit_4258 =
              (Script (DNSLookupDelay {getDNSLookupDelay = 0.065} :| []))
              Nothing
              False
+             (Script (FetchModeDeadline :| []))
          , [ JoinNetwork 4.166666666666,
              Kill 0.3,
              JoinNetwork 1.517857142857,
@@ -2862,6 +2867,7 @@ prop_unit_4258 =
                      ]))
              Nothing
              False
+             (Script (FetchModeDeadline :| []))
          , [ JoinNetwork 3.384615384615,
              Reconfigure 3.583333333333 [(1,1,Map.fromList [(RelayAccessAddress "0.0.0.4" 9,(DoNotAdvertisePeer, IsNotTrustable))])],
              Kill 15.55555555555,
@@ -2923,6 +2929,7 @@ prop_unit_reconnect =
               (Script (DNSLookupDelay {getDNSLookupDelay = 0} :| []))
               Nothing
               False
+              (Script (FetchModeDeadline :| []))
           , [ JoinNetwork 0
             ])
           , (NodeArgs
@@ -2949,6 +2956,7 @@ prop_unit_reconnect =
              (Script (DNSLookupDelay {getDNSLookupDelay = 0} :| []))
              Nothing
              False
+             (Script (FetchModeDeadline :| []))
          , [ JoinNetwork 10
            ])
          ]

ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Testnet/Simulation/Node.hs

@@ -114,9 +114,11 @@ import Test.Ouroboros.Network.PeerSelection.RootPeersDNS (DNSLookupDelay (..),
 import Test.Ouroboros.Network.PeerSelection.RootPeersDNS qualified as PeerSelection hiding
            (tests)
 
+import Data.Bool (bool)
 import Data.Function (on)
 import Data.Typeable (Typeable)
-import Ouroboros.Network.BlockFetch (TraceFetchClientState, TraceLabelPeer (..))
+import Ouroboros.Network.BlockFetch (FetchMode (..), TraceFetchClientState,
+           TraceLabelPeer (..))
 import Ouroboros.Network.PeerSelection.Bootstrap (UseBootstrapPeers (..))
 import Ouroboros.Network.PeerSelection.PeerAdvertise (PeerAdvertise (..))
 import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing)
@@ -209,13 +211,14 @@ data NodeArgs =
       -- ^ 'Arguments' 'aDNSLookupDelayScript' value
     , naChainSyncExitOnBlockNo :: Maybe BlockNo
     , naChainSyncEarlyExit     :: Bool
+    , naFetchModeScript        :: Script FetchMode
     }
 
 instance Show NodeArgs where
     show NodeArgs { naSeed, naDiffusionMode, naMbTime, naBootstrapPeers, naPublicRoots,
                    naAddr, naPeerSharing, naLocalRootPeers, naLocalSelectionTargets,
                    naDNSTimeoutScript, naDNSLookupDelayScript, naChainSyncExitOnBlockNo,
-                   naChainSyncEarlyExit } =
+                   naChainSyncEarlyExit, naFetchModeScript } =
       unwords [ "NodeArgs"
               , "(" ++ show naSeed ++ ")"
               , show naDiffusionMode
@@ -230,6 +233,7 @@ instance Show NodeArgs where
               , "(" ++ show naDNSLookupDelayScript ++ ")"
               , "(" ++ show naChainSyncExitOnBlockNo ++ ")"
               , show naChainSyncEarlyExit
+              , show naFetchModeScript
               ]
 
 data Command = JoinNetwork DiffTime
@@ -414,6 +418,8 @@ genNodeArgs relays minConnected localRootPeers relay = flip suchThat hasUpstream
   firstLedgerPool <- arbitrary
   let ledgerPeerPoolsScript = Script (firstLedgerPool :| ledgerPeerPools)
 
+  fetchModeScript <- fmap (bool FetchModeBulkSync FetchModeDeadline) <$> arbitrary
+
   firstBootstrapPeer <- maybe DontUseBootstrapPeers UseBootstrapPeers
                       <$> arbitrary
   bootstrapPeers <- listOf (maybe DontUseBootstrapPeers UseBootstrapPeers
@@ -438,6 +444,7 @@ genNodeArgs relays minConnected localRootPeers relay = flip suchThat hasUpstream
       , naChainSyncExitOnBlockNo = chainSyncExitOnBlockNo
       , naChainSyncEarlyExit     = chainSyncEarlyExit
       , naPeerSharing            = peerSharing
+      , naFetchModeScript        = fetchModeScript
       }
   where
     hasActive :: SmallPeerSelectionTargets -> Bool