diff --git a/hbs2-core/lib/HBS2/Net/PeerLocator.hs b/hbs2-core/lib/HBS2/Net/PeerLocator.hs index 973cb3eb..336c71d5 100644 --- a/hbs2-core/lib/HBS2/Net/PeerLocator.hs +++ b/hbs2-core/lib/HBS2/Net/PeerLocator.hs @@ -1,8 +1,14 @@ module HBS2.Net.PeerLocator where +-- import HBS2.Prelude import HBS2.Net.Proto -class (IsPeer peer, Monad m) => PeerLocator l peer m where - knownPeers :: l -> m [Peer peer] +class PeerLocator l where + knownPeers :: (IsPeer peer, Monad m) => l -> m [Peer peer] + +data AnyPeerLocator = forall a . PeerLocator a => AnyPeerLocator a + +instance PeerLocator AnyPeerLocator where + knownPeers (AnyPeerLocator l) = knownPeers l diff --git a/hbs2-core/lib/HBS2/Net/PeerLocator/Static.hs b/hbs2-core/lib/HBS2/Net/PeerLocator/Static.hs index 38ed26b9..b8ede9cf 100644 --- a/hbs2-core/lib/HBS2/Net/PeerLocator/Static.hs +++ b/hbs2-core/lib/HBS2/Net/PeerLocator/Static.hs @@ -17,8 +17,7 @@ newStaticPeerLocator seeds = do tv <- liftIO $ newTVarIO (Set.fromList seeds) pure $ StaticPeerLocator tv -instance (MonadIO m, IsPeer p) - => PeerLocator (StaticPeerLocator p) p m where +instance PeerLocator (StaticPeerLocator p) where knownPeers _ = pure mempty diff --git a/hbs2-core/lib/HBS2/Net/Proto/Actors/BlockInfo.hs b/hbs2-core/lib/HBS2/Net/Proto/Actors/BlockInfo.hs index b463eb63..1b26df30 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/Actors/BlockInfo.hs +++ b/hbs2-core/lib/HBS2/Net/Proto/Actors/BlockInfo.hs @@ -1,10 +1,11 @@ module HBS2.Net.Proto.Actors.BlockInfo where -import HBS2.Prelude -import HBS2.Hash -import HBS2.Net.Proto -import HBS2.Clock import HBS2.Actors +import HBS2.Clock +import HBS2.Hash +import HBS2.Net.PeerLocator +import HBS2.Net.Proto +import HBS2.Prelude import Data.Function import Data.Kind @@ -19,19 +20,19 @@ import Prettyprinter data BlockInfoActor (m :: Type -> Type) = BlockInfoActor { tasks :: Pipeline m () + , peers :: AnyPeerLocator } - -- TODO: send block info request -- TODO: receive block info request -- TODO: cache block info per peer -- TODO: get block info per peer -createBlockInfoActor :: MonadIO m => m (BlockInfoActor m ) -createBlockInfoActor = do +createBlockInfoActor :: MonadIO m => AnyPeerLocator -> m (BlockInfoActor m ) +createBlockInfoActor l = do pip <- newPipeline 200 -- FIXME: to settings! - pure $ BlockInfoActor pip + pure $ BlockInfoActor pip l runBlockInfoActor :: MonadIO m => BlockInfoActor m -> m () runBlockInfoActor b = runPipeline (tasks b) @@ -41,6 +42,7 @@ stopBlockInfoActor b = stopPipeline (tasks b) requestBlockInfo :: forall peer h m . ( MonadIO m , Pretty (Hash h) + , IsPeer peer ) => BlockInfoActor m -> Maybe (Peer peer) @@ -50,7 +52,11 @@ requestBlockInfo :: forall peer h m . ( MonadIO m requestBlockInfo b mp h = do addJob (tasks b) do -- peers <- getPeers + -- -- TODO: get given peer or some other peers + somePeers <- knownPeers @_ @peer (peers b) + + -- TODO: get cookie from cookie generator -- TODO: set waiting for request -- TODO: send block info request to messaging diff --git a/hbs2-core/test/TestBlockInfoActor.hs b/hbs2-core/test/TestBlockInfoActor.hs index 10caa55c..c43e3949 100644 --- a/hbs2-core/test/TestBlockInfoActor.hs +++ b/hbs2-core/test/TestBlockInfoActor.hs @@ -2,26 +2,40 @@ module TestBlockInfoActor where import HBS2.Hash import HBS2.Clock +import HBS2.Net.Proto import HBS2.Net.Proto.Actors.BlockInfo +import HBS2.Net.PeerLocator +import HBS2.Net.PeerLocator.Static import Test.Tasty.HUnit import Test.QuickCheck import Data.Word +import Data.Hashable (Hashable) import Data.ByteString (ByteString) import Data.ByteString qualified as B import Control.Concurrent.Async +data Fake + +instance IsPeer Fake where + newtype instance Peer Fake = FakePeer Int + deriving stock (Eq,Ord,Show) + deriving newtype (Hashable,Num,Enum,Real,Integral) + testBlockInfoActor :: IO () testBlockInfoActor = do - a <- createBlockInfoActor + + np <- newStaticPeerLocator @Fake [1..10] + + a <- createBlockInfoActor (AnyPeerLocator np) actor <- async $ runBlockInfoActor a let obj = shrink [0x00 .. 0xFF] :: [[Word8]] forConcurrently_ obj $ \x -> do - requestBlockInfo a Nothing (hashObject (B.pack x) :: Hash HbSync) + requestBlockInfo @Fake a Nothing (hashObject (B.pack x) :: Hash HbSync) pause ( 1 :: Timeout 'Seconds)