From 264314e2551f6a8ba9bddc561158ce385ec63d11 Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Sun, 22 Jan 2023 16:02:53 +0300 Subject: [PATCH] proto peer locator --- hbs2-core/lib/HBS2/Actors/Peer.hs | 6 +++ hbs2-core/lib/HBS2/Defaults.hs | 2 +- hbs2-core/lib/HBS2/Net/PeerLocator.hs | 2 + hbs2-tests/test/HmapMain.hs | 76 --------------------------- hbs2-tests/test/Peer2Main.hs | 36 +++++++------ 5 files changed, 29 insertions(+), 93 deletions(-) delete mode 100644 hbs2-tests/test/HmapMain.hs diff --git a/hbs2-core/lib/HBS2/Actors/Peer.hs b/hbs2-core/lib/HBS2/Actors/Peer.hs index b9d1e206..d2363124 100644 --- a/hbs2-core/lib/HBS2/Actors/Peer.hs +++ b/hbs2-core/lib/HBS2/Actors/Peer.hs @@ -50,6 +50,9 @@ instance (IsKey HbSync, Key HbSync ~ Hash HbSync, Block ByteString ~ ByteString) class Monad m => HasOwnPeer e m where ownPeer :: m (Peer e) +class Monad m => HasPeerLocator e m where + getPeerLocator :: m (AnyPeerLocator e) + class HasStorage m where getStorage :: m AnyStorage @@ -141,6 +144,9 @@ runResponseM peer f = runReaderT (fromResponse f) (ResponseEnv peer) instance Monad m => HasOwnPeer e (PeerM e m) where ownPeer = asks (view envSelf) +instance Monad m => HasPeerLocator e (PeerM e m) where + getPeerLocator = asks (view envPeerLocator) + instance Monad m => HasFabriq e (PeerM e m) where getFabriq = asks (view envFab) diff --git a/hbs2-core/lib/HBS2/Defaults.hs b/hbs2-core/lib/HBS2/Defaults.hs index dfc121d0..4bd09e5f 100644 --- a/hbs2-core/lib/HBS2/Defaults.hs +++ b/hbs2-core/lib/HBS2/Defaults.hs @@ -36,7 +36,7 @@ defBlockInfoTimeout :: TimeSpec defBlockInfoTimeout = toTimeSpec ( 10 :: Timeout 'Minutes) defSweepTimeout :: Timeout 'Seconds -defSweepTimeout = 5 -- FIXME: only for debug! +defSweepTimeout = 600 -- FIXME: only for debug! diff --git a/hbs2-core/lib/HBS2/Net/PeerLocator.hs b/hbs2-core/lib/HBS2/Net/PeerLocator.hs index 5d7e5daa..5073d5a5 100644 --- a/hbs2-core/lib/HBS2/Net/PeerLocator.hs +++ b/hbs2-core/lib/HBS2/Net/PeerLocator.hs @@ -1,3 +1,4 @@ +{-# Language AllowAmbiguousTypes #-} module HBS2.Net.PeerLocator where import HBS2.Prelude @@ -13,3 +14,4 @@ instance HasPeer e => PeerLocator e (AnyPeerLocator e) where knownPeers (AnyPeerLocator l) = knownPeers l addPeers (AnyPeerLocator l) = addPeers l + diff --git a/hbs2-tests/test/HmapMain.hs b/hbs2-tests/test/HmapMain.hs deleted file mode 100644 index f960e1f3..00000000 --- a/hbs2-tests/test/HmapMain.hs +++ /dev/null @@ -1,76 +0,0 @@ -{-# LANGUAGE ExistentialQuantification, RankNTypes #-} -module Main where - -import Data.Typeable -import Data.Dynamic -import Data.Proxy -import Data.Kind - -import Prettyprinter - - -data Key = forall a . (Unfuck a, Eq a) => Key (Proxy a) Dynamic - -class Typeable a => Unfuck a where - unfuck :: Proxy a -> Dynamic -> Maybe a - -instance Typeable a => Unfuck a where - unfuck _ = fromDynamic @a - -newKey :: forall a . (Eq a, Typeable a, Unfuck a) => a -> Key -newKey s = Key (Proxy @a) (toDyn s) - -instance Eq Key where - (==) (Key p1 a) (Key p2 b) = unfuck p1 a == unfuck p1 b - -main :: IO () -main = do - let k1 = newKey 22 - let k2 = newKey 33 - let k3 = newKey "JOPA" - - print $ "k1 == k1:" <+> pretty (k1 == k1) - print $ "k2 == k2:" <+> pretty (k2 == k2) - print $ "k1 == k2:" <+> pretty (k1 == k2) - print $ "k3 == k3:" <+> pretty (k3 == k3) - print $ "k3 == k2:" <+> pretty (k3 == k2) - print $ "k3 == k1:" <+> pretty (k3 == k1) - - - -- _ <- race ( pause ( 60 :: Timeout 'Seconds) ) $ forever $ do - -- let gen = arbitrary @MyKey - -- let n = 100 - -- keys <- replicateM 10 (sample' @MyKey gen) <&> mconcat - -- vals <- replicateM 100 (randomIO @Int) - - -- let kv = zip keys vals - - -- forM_ kv $ \(k,v) -> do - - -- m <- readTVarIO tm - - -- let z = withKey k id - - -- undefined - - -- atomically $ writeTVar tm z - -- atomically $ modifyTVar km (k:) - - -- kl <- readTVarIO km - - -- when (length kl > 1000) $ do - -- let (a,b) = L.splitAt 1000 kl - - -- m1 <- readTVarIO tm - -- forM_ b $ \z3 -> do - -- let m2 = withKey z3 $ \z3 -> delete z3 m1 - -- pure () - - -- atomically $ writeTVar km b - - -- pure () - - - - pure () - diff --git a/hbs2-tests/test/Peer2Main.hs b/hbs2-tests/test/Peer2Main.hs index 0ac55a61..6ec86200 100644 --- a/hbs2-tests/test/Peer2Main.hs +++ b/hbs2-tests/test/Peer2Main.hs @@ -157,18 +157,19 @@ handleBlockInfo (p, h, sz') = do let bsz = fromIntegral sz update @e def (BlockSizeKey h) (over bsBlockSizes (Map.insert p bsz)) -blockDownloadLoop :: forall e . ( HasProtocol e (BlockSize e) - , HasProtocol e (BlockChunks e) - , Request e (BlockSize e) (PeerM e IO) - , Request e (BlockChunks e) (PeerM e IO) - , EventListener e (BlockSize e) (PeerM e IO) - , EventListener e (BlockChunks e) (PeerM e IO) - , EventEmitter e (BlockChunks e) (PeerM e IO) - , Sessions e (BlockSize e) (PeerM e IO) - , Sessions e (BlockChunks e) (PeerM e IO) - , Num (Peer e) - -- , Ord (Peer e) - ) => PeerM e IO () +blockDownloadLoop :: forall e m . ( m ~ PeerM e IO + , HasProtocol e (BlockSize e) + , HasProtocol e (BlockChunks e) + , Request e (BlockSize e) m + , Request e (BlockChunks e) m + , EventListener e (BlockSize e) m + , EventListener e (BlockChunks e) m + , EventEmitter e (BlockChunks e) m + , Sessions e (BlockSize e) m + , Sessions e (BlockChunks e) m + , Num (Peer e) + , Pretty (Peer e) + ) => PeerM e IO () blockDownloadLoop = do let blks = [ "5KP4vM6RuEX6RA1ywthBMqZV5UJDLANC17UrF6zuWdRt" @@ -185,7 +186,6 @@ blockDownloadLoop = do pure () subscribe @e (BlockSizeEventKey h) $ \(BlockSizeEvent (p,h,s)) -> do - debug $ "can't believe this shit works" <+> pretty h coo <- genCookie (p,h) let key = DownloadSessionKey (p, coo) let chusz = defChunkSize @@ -196,7 +196,11 @@ blockDownloadLoop = do update @e new key id request p (BlockChunks coo (BlockGetAllChunks @e h chusz)) -- FIXME: nicer construction - request 1 (GetBlockSize @e h) + peers <- getPeerLocator @e >>= knownPeers @e + + for_ peers $ \p -> do + debug $ "WTF?" <+> pretty p + request p (GetBlockSize @e h) fix \next -> do liftIO $ print "piu!" @@ -321,9 +325,9 @@ main = do adapter <- mkAdapter cw env <- ask - npl <- newStaticPeerLocator ps + pl <- getPeerLocator @Fake - addPeers npl ps + addPeers @Fake pl ps as <- liftIO $ async $ withPeerM env blockDownloadLoop