Address #4782

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,10 @@
 * 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`.
 
 ### Non-breaking changes
 
@@ -49,11 +53,23 @@
 
 * `PeerSharingController` is now private and `requestPeers` is exported
 
-* Fix hot demototion by having blockfetch give chainsync a chance to exit
+* Fix hot demotion by having blockfetch give chainsync a chance to exit
   cleanly before killing it.
 
 * 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.
+
 ## 0.11.0.0 -- 2023-01-22
 
 ### Breaking changes

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/Diffusion/Node.hs

@@ -279,7 +279,7 @@ run blockGeneratorArgs limits ni na tracersExtra tracerBlockFetch =
               <> wait blockFetchLogicThread
               <> wait nodeKernelThread
   where
-    blockFetch :: NodeKernel BlockHeader Block m
+    blockFetch :: NodeKernel BlockHeader Block s m
                -> m Void
     blockFetch nodeKernel = do
       blockFetchLogic
@@ -295,7 +295,7 @@ run blockGeneratorArgs limits ni na tracersExtra tracerBlockFetch =
           bfcSalt                   = 0
         })
 
-    blockFetchPolicy :: NodeKernel BlockHeader Block m
+    blockFetchPolicy :: NodeKernel BlockHeader Block s m
                      -> BlockFetchConsensusInterface NtNAddr BlockHeader Block m
     blockFetchPolicy nodeKernel =
         BlockFetchConsensusInterface {

ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Diffusion/Node/MiniProtocols.hs

@@ -33,7 +33,7 @@ import Data.ByteString.Lazy (ByteString)
 import Data.Functor (($>))
 import Data.Maybe (fromMaybe)
 import Data.Void (Void)
-import System.Random (StdGen)
+import System.Random (RandomGen, StdGen)
 
 import Codec.CBOR.Read qualified as CBOR
 import Codec.Serialise qualified as Serialise
@@ -89,13 +89,12 @@ import Ouroboros.Network.NodeToNode (blockFetchMiniProtocolNum,
            peerSharingMiniProtocolNum)
 import Ouroboros.Network.PeerSelection.LedgerPeers
 import Ouroboros.Network.PeerSelection.PeerSharing qualified as PSTypes
-import Ouroboros.Network.PeerSharing (bracketPeerSharingClient,
+import Ouroboros.Network.PeerSharing (PeerSharingAPI, bracketPeerSharingClient,
            peerSharingClient, peerSharingServer)
 import Ouroboros.Network.Protocol.PeerSharing.Client (peerSharingClientPeer)
 import Ouroboros.Network.Protocol.PeerSharing.Codec (codecPeerSharing)
 import Ouroboros.Network.Protocol.PeerSharing.Server (peerSharingServerPeer)
-import Ouroboros.Network.Protocol.PeerSharing.Type (PeerSharing,
-           PeerSharingAmount (..))
+import Ouroboros.Network.Protocol.PeerSharing.Type (PeerSharing)
 import Test.Ouroboros.Network.Diffusion.Node.NodeKernel
 
 
@@ -211,7 +210,7 @@ data AppArgs header block m = AppArgs
 
 -- | Protocol handlers.
 --
-applications :: forall block header m.
+applications :: forall block header s m.
                 ( Alternative (STM m)
                 , MonadAsync m
                 , MonadFork  m
@@ -228,9 +227,10 @@ applications :: forall block header m.
                 , Show block
                 , ShowProxy block
                 , ShowProxy header
+                , RandomGen s
                 )
              => Tracer m String
-             -> NodeKernel header block m
+             -> NodeKernel header block s m
              -> Codecs NtNAddr header block m
              -> LimitsAndTimeouts header block
              -> AppArgs header block m
@@ -260,10 +260,10 @@ applications debugTracer nodeKernel
           simpleSingletonVersions UnversionedProtocol
                                   (NtNVersionData InitiatorOnlyDiffusionMode aaOwnPeerSharing)
                                   initiatorApp
-      , Diff.daApplicationInitiatorResponderMode = \computePeers ->
+      , Diff.daApplicationInitiatorResponderMode =
           simpleSingletonVersions UnversionedProtocol
                                   (NtNVersionData aaDiffusionMode aaOwnPeerSharing)
-                                  (initiatorAndResponderApp computePeers)
+                                  initiatorAndResponderApp
       , Diff.daLocalResponderApplication =
           simpleSingletonVersions UnversionedProtocol
                                   UnversionedProtocolData
@@ -275,7 +275,7 @@ applications debugTracer nodeKernel
     initiatorApp
       :: OuroborosBundleWithExpandedCtx InitiatorMode NtNAddr ByteString m () Void
     -- initiator mode will never run a peer sharing responder side
-    initiatorApp = fmap f <$> initiatorAndResponderApp (error "impossible happened!")
+    initiatorApp = fmap f <$> initiatorAndResponderApp
       where
         f :: MiniProtocolWithExpandedCtx InitiatorResponderMode NtNAddr ByteString m () ()
           -> MiniProtocolWithExpandedCtx InitiatorMode          NtNAddr ByteString m () Void
@@ -291,10 +291,8 @@ applications debugTracer nodeKernel
                        }
 
     initiatorAndResponderApp
-      :: (PeerSharingAmount -> m [NtNAddr])
-      -- ^ Peer Sharing result computation callback
-      -> OuroborosBundleWithExpandedCtx InitiatorResponderMode NtNAddr ByteString m () ()
-    initiatorAndResponderApp computePeers = TemperatureBundle
+      :: OuroborosBundleWithExpandedCtx InitiatorResponderMode NtNAddr ByteString m () ()
+    initiatorAndResponderApp = TemperatureBundle
       { withHot = WithHot
           [ MiniProtocol
               { miniProtocolNum    = chainSyncMiniProtocolNum
@@ -339,7 +337,7 @@ applications debugTracer nodeKernel
                           , miniProtocolRun    =
                               InitiatorAndResponderProtocol
                                 peerSharingInitiator
-                                (peerSharingResponder computePeers)
+                                (peerSharingResponder (nkPeerSharingAPI nodeKernel))
                           }
                        ]
                   else []
@@ -583,9 +581,9 @@ applications debugTracer nodeKernel
                    (peerSharingClientPeer psClient)
 
     peerSharingResponder
-      :: (PeerSharingAmount -> m [NtNAddr])
+      :: PeerSharingAPI NtNAddr s m
       -> MiniProtocolCb (ResponderContext NtNAddr) ByteString m ()
-    peerSharingResponder f = MiniProtocolCb $ \_ctx channel -> do
+    peerSharingResponder psAPI = MiniProtocolCb $ \_ctx channel -> do
       labelThisThread "PeerSharingServer"
       runPeerWithLimits
         nullTracer
@@ -594,7 +592,7 @@ applications debugTracer nodeKernel
         (peerSharingTimeLimits limits)
         channel
         $ peerSharingServerPeer
-        $ peerSharingServer f
+        $ peerSharingServer psAPI
 
 
 --

ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Diffusion/Node/NodeKernel.hs

@@ -51,7 +51,7 @@ import Data.Typeable (Typeable)
 import Data.Void (Void)
 import Numeric.Natural (Natural)
 
-import System.Random (StdGen, randomR)
+import System.Random (RandomGen, StdGen, randomR, split)
 
 import Data.Monoid.Synchronisation
 
@@ -80,8 +80,9 @@ import Ouroboros.Network.Mock.Chain (Chain (..))
 import Ouroboros.Network.NodeToNode ()
 import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing)
 import Ouroboros.Network.PeerSelection.RelayAccessPoint (RelayAccessPoint (..))
-import Ouroboros.Network.PeerSharing (PeerSharingRegistry (..),
-           newPeerSharingRegistry)
+import Ouroboros.Network.PeerSharing (PeerSharingAPI, PeerSharingRegistry (..),
+           newPeerSharingAPI, newPeerSharingRegistry,
+           ps_POLICY_PEER_SHARE_MAX_PEERS, ps_POLICY_PEER_SHARE_STICKY_TIME)
 import Test.Ouroboros.Network.Diffusion.Node.ChainDB (ChainDB (..))
 import Test.Ouroboros.Network.Diffusion.Node.ChainDB qualified as ChainDB
 import Test.QuickCheck (Arbitrary (..), choose, chooseInt, frequency, oneof)
@@ -248,7 +249,7 @@ randomBlockGenerationArgs bgaSlotDuration bgaSeed quota =
     , bgaSeed
     }
 
-data NodeKernel header block m = NodeKernel {
+data NodeKernel header block s m = NodeKernel {
       -- | upstream chains
       nkClientChains
         :: StrictTVar m (Map NtNAddr (StrictTVar m (Chain header))),
@@ -261,21 +262,28 @@ data NodeKernel header block m = NodeKernel {
 
       nkPeerSharingRegistry :: PeerSharingRegistry NtNAddr m,
 
-      nkChainDB :: ChainDB block m
+      nkChainDB :: ChainDB block m,
+
+      nkPeerSharingAPI :: PeerSharingAPI NtNAddr s m
     }
 
-newNodeKernel :: MonadSTM m => m (NodeKernel header block m)
-newNodeKernel = NodeKernel
+newNodeKernel :: ( MonadSTM m
+                 , RandomGen s
+                 )
+              => s -> m (NodeKernel header block s m)
+newNodeKernel rng = NodeKernel
             <$> newTVarIO Map.empty
             <*> newTVarIO (ChainProducerState Chain.Genesis Map.empty 0)
             <*> newFetchClientRegistry
             <*> newPeerSharingRegistry
             <*> ChainDB.newChainDB
+            <*> newPeerSharingAPI rng ps_POLICY_PEER_SHARE_STICKY_TIME
+                                      ps_POLICY_PEER_SHARE_MAX_PEERS
 
 -- | Register a new upstream chain-sync client.
 --
 registerClientChains :: MonadSTM m
-                     => NodeKernel header block m
+                     => NodeKernel header block s m
                      -> NtNAddr
                      -> m (StrictTVar m (Chain header))
 registerClientChains NodeKernel { nkClientChains } peerAddr = atomically $ do
@@ -287,7 +295,7 @@ registerClientChains NodeKernel { nkClientChains } peerAddr = atomically $ do
 -- | Unregister an upstream chain-sync client.
 --
 unregisterClientChains :: MonadSTM m
-                       => NodeKernel header block m
+                       => NodeKernel header block s m
                        -> NtNAddr
                        -> m ()
 unregisterClientChains NodeKernel { nkClientChains } peerAddr = atomically $
@@ -349,19 +357,21 @@ withNodeKernelThread
      , MonadThrow         m
      , MonadThrow    (STM m)
      , HasFullHeader block
+     , RandomGen seed
      )
   => BlockGeneratorArgs block seed
-  -> (NodeKernel header block m -> Async m Void -> m a)
+  -> (NodeKernel header block seed m -> Async m Void -> m a)
   -- ^ The continuation which has a handle to the chain selection \/ block
   -- production thread.  The thread might throw an exception.
   -> m a
 withNodeKernelThread BlockGeneratorArgs { bgaSlotDuration, bgaBlockGenerator, bgaSeed }
                      k = do
-    kernel <- newNodeKernel
+    let (_, psSeed) = split bgaSeed
+    kernel <- newNodeKernel psSeed
     withSlotTime bgaSlotDuration $ \waitForSlot ->
       withAsync (blockProducerThread kernel waitForSlot) (k kernel)
   where
-    blockProducerThread :: NodeKernel header block m
+    blockProducerThread :: NodeKernel header block seed m
                         -> (SlotNo -> STM m SlotNo)
                         -> m Void
     blockProducerThread NodeKernel { nkChainProducerState, nkChainDB }

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