mirror of https://github.com/voidlizard/hbs2
proto peer locator
This commit is contained in:
Dmitry Zuikov
parent
de97258fe1
commit
264314e255
|
|
@ -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)
|
||||
|
||||
|
|
|
|||
|
|
@ -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!
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ()
|
||||
|
||||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue