wip

hbs2-core/hbs2-core.cabal

@@ -73,6 +73,8 @@ library
                     , HBS2.Merkle
                     , HBS2.Net.Messaging
                     , HBS2.Net.Messaging.Fake
+                    , HBS2.Net.PeerLocator
+                    , HBS2.Net.PeerLocator.Static
                     , HBS2.Net.Proto
                     , HBS2.Net.Proto.Actors.BlockInfo
                     , HBS2.Prelude

hbs2-core/lib/HBS2/Net/PeerLocator.hs

@@ -0,0 +1,8 @@
+module HBS2.Net.PeerLocator where
+
+import HBS2.Net.Proto
+
+class (IsPeer peer, Monad m) => PeerLocator l peer m where
+  knownPeers :: l -> m [Peer peer]
+
+

hbs2-core/lib/HBS2/Net/PeerLocator/Static.hs

@@ -0,0 +1,24 @@
+module HBS2.Net.PeerLocator.Static where
+
+import HBS2.Prelude
+import HBS2.Net.Proto
+import HBS2.Net.PeerLocator
+
+import Control.Concurrent.STM.TVar
+import Data.Set (Set)
+import Data.Set qualified as Set
+
+newtype StaticPeerLocator p =
+  StaticPeerLocator (TVar (Set (Peer p)))
+
+
+newStaticPeerLocator :: (IsPeer p, MonadIO m) => [Peer p] -> m (StaticPeerLocator p)
+newStaticPeerLocator seeds = do
+  tv <- liftIO $ newTVarIO (Set.fromList seeds)
+  pure $ StaticPeerLocator tv
+
+instance (MonadIO m, IsPeer p)
+  => PeerLocator  (StaticPeerLocator p) p m where
+
+  knownPeers _ = pure mempty
+

hbs2-core/lib/HBS2/Net/Proto.hs

@@ -5,7 +5,7 @@ import HBS2.Prelude.Plated
 import Data.Kind
 import Data.Hashable
 
-class (Hashable (Peer a), Eq (Peer a)) => IsPeer a where
+class (Hashable (Peer a), Eq (Peer a), Ord (Peer a)) => IsPeer a where
   data family Peer a :: Type
 
 

hbs2-core/lib/HBS2/Net/Proto/Actors/BlockInfo.hs

@@ -47,8 +47,14 @@ requestBlockInfo :: forall peer h m . ( MonadIO m
                  -> Hash h
                  -> m  ()
 
-requestBlockInfo b _ h = do
+requestBlockInfo b mp h = do
   addJob (tasks b) do
+    -- peers <- getPeers
+    -- TODO: get given peer or some other peers
+    -- TODO: get cookie from cookie generator
+    -- TODO: set waiting for request
+    -- TODO: send block info request to messaging
+
     liftIO $ print ( "request-info" <+> pretty h)
 
 getBlockInfo :: MonadIO m