Merge pull request #4793 from IntersectMBO/bolt12/peer-sharing-enhance

Make PeerSharingController private

ouroboros-network/CHANGELOG.md

@@ -47,6 +47,8 @@
 * set knownSuccessfulConnection for incomming peers
 * Don't use minPeerShareTime with GuardedSkip
 
+* `PeerSharingController` is now private and `requestPeers` is exported
+
 ## 0.11.0.0 -- 2023-01-22
 
 ### Breaking changes

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

@@ -15,7 +15,7 @@ module Ouroboros.Network.PeerSelection.PeerSelectionActions
 
 
 import Control.Applicative (Alternative)
-import Control.Concurrent.Class.MonadMVar (MonadMVar (..), takeMVar)
+import Control.Concurrent.Class.MonadMVar (MonadMVar (..))
 import Control.Concurrent.Class.MonadSTM.Strict
 import Control.Monad.Class.MonadAsync
 import Control.Monad.Class.MonadThrow
@@ -46,7 +46,7 @@ import Ouroboros.Network.PeerSelection.RootPeersDNS.DNSSemaphore
 import Ouroboros.Network.PeerSelection.RootPeersDNS.LocalRootPeers
 import Ouroboros.Network.PeerSelection.RootPeersDNS.PublicRootPeers
 import Ouroboros.Network.PeerSelection.State.LocalRootPeers
-import Ouroboros.Network.PeerSharing (PeerSharingController (..))
+import Ouroboros.Network.PeerSharing (PeerSharingController, requestPeers)
 import Ouroboros.Network.Protocol.PeerSharing.Type (PeerSharingAmount (..))
 import System.Random (StdGen)
 
@@ -221,17 +221,14 @@ withPeerSelectionActions
 
     requestPeerShare :: PeerSharingAmount -> peeraddr -> m (PeerSharingResult peeraddr)
     requestPeerShare amount peer = do
-      resultQueue <- newEmptyMVar
-      controller <- atomically readPeerSharingController
-      case Map.lookup peer controller of
+      controllerMap <- atomically readPeerSharingController
+      case Map.lookup peer controllerMap of
         -- Peer Registering happens asynchronously with respect to
         -- requestPeerShare. This means that there's a possible race where the
         -- Peer Selection Governor can decide to peer share request to a peer
         -- for the peer is registered. When this happens this map lookup is
         -- going to fail, so instead of erroring we report this to the governor
         -- so it can deal with this particular case accordingly.
         Nothing -> return PeerSharingNotRegisteredYet
-        Just (PeerSharingController requestQueue) -> do
-          atomically $ putTMVar requestQueue (amount, resultQueue)
-          result <- takeMVar resultQueue
-          return (PeerSharingResult result)
+        Just psController ->
+          PeerSharingResult <$> requestPeers psController amount

ouroboros-network/src/Ouroboros/Network/PeerSharing.hs

@@ -1,13 +1,22 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE NamedFieldPuns   #-}
 
-module Ouroboros.Network.PeerSharing where
+module Ouroboros.Network.PeerSharing
+  ( PeerSharingController
+  , PeerSharingRegistry (..)
+  , newPeerSharingRegistry
+  , bracketPeerSharingClient
+  , peerSharingClient
+  , peerSharingServer
+  , requestPeers
+  ) where
 
 import Control.Applicative (Alternative)
-import Control.Concurrent.Class.MonadMVar (MVar, MonadMVar (putMVar))
+import Control.Concurrent.Class.MonadMVar (MVar, MonadMVar (putMVar),
+           newEmptyMVar, takeMVar)
 import Control.Concurrent.Class.MonadSTM.Strict (MonadSTM, STM, StrictTMVar,
            StrictTVar, atomically, modifyTVar, newEmptyTMVarIO, newTVarIO,
-           retry, takeTMVar)
+           putTMVar, retry, takeTMVar)
 import Control.Monad.Class.MonadThrow (MonadThrow, bracket)
 import Data.Map.Strict (Map)
 import Data.Map.Strict qualified as Map
@@ -36,6 +45,13 @@ newtype PeerSharingController peer m = PeerSharingController {
     requestQueue :: StrictTMVar m (PeerSharingAmount, MVar m [peer])
   }
 
+requestPeers :: (MonadMVar m, MonadSTM m)
+             => PeerSharingController peer m -> PeerSharingAmount -> m [peer]
+requestPeers (PeerSharingController requestQueue) amount = do
+   res <- newEmptyMVar
+   atomically $ putTMVar requestQueue (amount, res)
+   takeMVar res
+
 -- | Peer Sharing Registry is a registry that stores a 'PeerSharingController'
 -- for every peer that we connect to.
 --