wip

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

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
 

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
 

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