voidlizard
/
hbs2
mirror of https://github.com/voidlizard/hbs2
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

fixed issue with peer expiring

This commit is contained in:
Dmitry Zuikov 2023-02-04 15:53:02 +03:00
parent 277e886a4b
commit 83f5f2a496
3 changed files with 7 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
hbs2-core/lib/HBS2/Net/PeerLocator.hs
View File

@ -14,6 +14,6 @@ data AnyPeerLocator e = forall a . PeerLocator e a => AnyPeerLocator a
instance HasPeer e => PeerLocator e (AnyPeerLocator e) where instance HasPeer e => PeerLocator e (AnyPeerLocator e) where
knownPeers (AnyPeerLocator l) = knownPeers l knownPeers (AnyPeerLocator l) = knownPeers l
addPeers (AnyPeerLocator l) = addPeers l addPeers (AnyPeerLocator l) = addPeers l
delPeers (AnyPeerLocator l) = addPeers l delPeers (AnyPeerLocator l) = delPeers l

4
hbs2-core/lib/HBS2/Net/PeerLocator/Static.hs
View File

@ -8,6 +8,8 @@ import Control.Concurrent.STM
import Data.Set (Set) import Data.Set (Set)
import Data.Set qualified as Set import Data.Set qualified as Set
import Prettyprinter
newtype StaticPeerLocator e = newtype StaticPeerLocator e =
StaticPeerLocator (TVar (Set (Peer e))) StaticPeerLocator (TVar (Set (Peer e)))
@ -17,7 +19,7 @@ newStaticPeerLocator seeds = do
tv <- liftIO $ newTVarIO (Set.fromList seeds) tv <- liftIO $ newTVarIO (Set.fromList seeds)
pure $ StaticPeerLocator tv pure $ StaticPeerLocator tv
instance Ord (Peer e) => PeerLocator e (StaticPeerLocator e) where instance (Ord (Peer e), Pretty (Peer e)) => PeerLocator e (StaticPeerLocator e) where
knownPeers (StaticPeerLocator peers) = do knownPeers (StaticPeerLocator peers) = do
ps <- liftIO $ readTVarIO peers ps <- liftIO $ readTVarIO peers

5
hbs2-peer/app/PeerInfo.hs
View File

@ -66,12 +66,13 @@ peerPingLoop :: forall e m . ( HasPeerLocator e m
, Request e (PeerHandshake e) m , Request e (PeerHandshake e) m
, Sessions e (PeerHandshake e) m , Sessions e (PeerHandshake e) m
, Sessions e (PeerInfo e) m , Sessions e (PeerInfo e) m
, Sessions e (KnownPeer e) m
, Pretty (Peer e) , Pretty (Peer e)
, MonadIO m , MonadIO m
) )
=> m () => m ()
peerPingLoop = forever do peerPingLoop = forever do
pause @'Minutes 2 -- FIXME: defaults pause @'Seconds 120 -- FIXME: defaults
debug "peerPingLoop" debug "peerPingLoop"
pl <- getPeerLocator @e pl <- getPeerLocator @e
@ -90,5 +91,5 @@ peerPingLoop = forever do
warn $ "removing peer" <+> pretty p <+> "for not responding to our pings" warn $ "removing peer" <+> pretty p <+> "for not responding to our pings"
delPeers pl [p] delPeers pl [p]
expire (PeerInfoKey p) expire (PeerInfoKey p)
expire (KnownPeerKey p)