diff --git a/hbs2-core/lib/HBS2/Actors/Peer.hs b/hbs2-core/lib/HBS2/Actors/Peer.hs index cee16edb..b9d1e206 100644 --- a/hbs2-core/lib/HBS2/Actors/Peer.hs +++ b/hbs2-core/lib/HBS2/Actors/Peer.hs @@ -3,16 +3,18 @@ {-# Language AllowAmbiguousTypes #-} module HBS2.Actors.Peer where -import HBS2.Prelude.Plated -import HBS2.Hash -import HBS2.Clock import HBS2.Actors -import HBS2.Storage -import HBS2.Net.Proto -import HBS2.Net.Messaging -import HBS2.Net.Proto.Sessions +import HBS2.Clock import HBS2.Defaults import HBS2.Events +import HBS2.Hash +import HBS2.Net.Messaging +import HBS2.Net.PeerLocator +import HBS2.Net.PeerLocator.Static +import HBS2.Net.Proto +import HBS2.Net.Proto.Sessions +import HBS2.Prelude.Plated +import HBS2.Storage import Control.Monad.Trans.Maybe import Codec.Serialise hiding (encode,decode) @@ -93,6 +95,7 @@ data PeerEnv e = { _envSelf :: Peer e , _envFab :: Fabriq e , _envStorage :: AnyStorage + , _envPeerLocator :: AnyPeerLocator e , _envDeferred :: Pipeline IO () , _envSessions :: Cache SKey Dynamic , _envEvents :: TVar (HashMap SKey [Dynamic]) @@ -264,14 +267,22 @@ instance ( HasProtocol e p ev <- MaybeT $ pure $ fromDynamic @(EventHandler e p (PeerM e IO)) r lift $ ev d -runPeerM :: (MonadIO m, Pretty (Peer e)) => AnyStorage -> Fabriq e -> Peer e -> PeerM e m a -> m () +runPeerM :: forall e m . (MonadIO m, HasPeer e, Ord (Peer e), Pretty (Peer e)) + => AnyStorage + -> Fabriq e + -> Peer e + -> PeerM e m () + -> m () + runPeerM s bus p f = do - env <- PeerEnv p bus s <$> newPipeline defProtoPipelineSize - <*> liftIO (Cache.newCache (Just defCookieTimeout)) - <*> liftIO (newTVarIO mempty) - <*> liftIO (Cache.newCache (Just defCookieTimeout)) - <*> liftIO (newTVarIO mempty) + pl <- AnyPeerLocator <$> newStaticPeerLocator @e mempty + + env <- PeerEnv p bus s pl <$> newPipeline defProtoPipelineSize + <*> liftIO (Cache.newCache (Just defCookieTimeout)) + <*> liftIO (newTVarIO mempty) + <*> liftIO (Cache.newCache (Just defCookieTimeout)) + <*> liftIO (newTVarIO mempty) let de = view envDeferred env as <- liftIO $ async $ runPipeline de diff --git a/hbs2-core/lib/HBS2/Net/PeerLocator.hs b/hbs2-core/lib/HBS2/Net/PeerLocator.hs index c7b25085..5d7e5daa 100644 --- a/hbs2-core/lib/HBS2/Net/PeerLocator.hs +++ b/hbs2-core/lib/HBS2/Net/PeerLocator.hs @@ -1,15 +1,15 @@ module HBS2.Net.PeerLocator where --- import HBS2.Prelude +import HBS2.Prelude import HBS2.Net.Proto.Types -class PeerLocator l where - knownPeers :: (HasPeer p, Monad m) => l -> m [Peer p] +class PeerLocator e l where + knownPeers :: forall m . (HasPeer e, MonadIO m) => l -> m [Peer e] + addPeers :: forall m . (HasPeer e, MonadIO m) => l -> [Peer e] -> m () -data AnyPeerLocator = forall a . PeerLocator a => AnyPeerLocator a +data AnyPeerLocator e = forall a . PeerLocator e a => AnyPeerLocator a -instance PeerLocator AnyPeerLocator where +instance HasPeer e => PeerLocator e (AnyPeerLocator e) where knownPeers (AnyPeerLocator l) = knownPeers l - - + addPeers (AnyPeerLocator l) = addPeers l diff --git a/hbs2-core/lib/HBS2/Net/PeerLocator/Static.hs b/hbs2-core/lib/HBS2/Net/PeerLocator/Static.hs index bb70d70c..2becc66b 100644 --- a/hbs2-core/lib/HBS2/Net/PeerLocator/Static.hs +++ b/hbs2-core/lib/HBS2/Net/PeerLocator/Static.hs @@ -4,12 +4,12 @@ import HBS2.Prelude import HBS2.Net.Proto import HBS2.Net.PeerLocator -import Control.Concurrent.STM.TVar +import Control.Concurrent.STM import Data.Set (Set) import Data.Set qualified as Set -newtype StaticPeerLocator p = - StaticPeerLocator (TVar (Set (Peer p))) +newtype StaticPeerLocator e = + StaticPeerLocator (TVar (Set (Peer e))) newStaticPeerLocator :: (Ord (Peer p), HasPeer p, MonadIO m) => [Peer p] -> m (StaticPeerLocator p) @@ -17,7 +17,14 @@ newStaticPeerLocator seeds = do tv <- liftIO $ newTVarIO (Set.fromList seeds) pure $ StaticPeerLocator tv -instance PeerLocator (StaticPeerLocator p) where +instance Ord (Peer e) => PeerLocator e (StaticPeerLocator e) where + + knownPeers (StaticPeerLocator peers) = do + ps <- liftIO $ readTVarIO peers + pure $ Set.toList ps + + addPeers (StaticPeerLocator peers) new = do + liftIO $ atomically $ modifyTVar' peers (<> Set.fromList new) + - knownPeers _ = pure mempty diff --git a/hbs2-tests/test/Peer2Main.hs b/hbs2-tests/test/Peer2Main.hs index e33615e0..0ac55a61 100644 --- a/hbs2-tests/test/Peer2Main.hs +++ b/hbs2-tests/test/Peer2Main.hs @@ -14,6 +14,8 @@ import HBS2.Net.Proto import HBS2.Net.Proto.Sessions import HBS2.Net.Proto.BlockChunks import HBS2.Net.Proto.BlockInfo +import HBS2.Net.PeerLocator +import HBS2.Net.PeerLocator.Static import HBS2.Prelude.Plated import HBS2.Storage import HBS2.Storage.Simple @@ -318,6 +320,11 @@ main = do runPeerM (AnyStorage s) fake p0 $ do adapter <- mkAdapter cw env <- ask + + npl <- newStaticPeerLocator ps + + addPeers npl ps + as <- liftIO $ async $ withPeerM env blockDownloadLoop runProto @Fake