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

wip

This commit is contained in:
Dmitry Zuikov 2023-03-29 09:59:53 +03:00
parent ec6feb0203
commit 2b71b27dca
3 changed files with 22 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
hbs2-core/lib/HBS2/Defaults.hs
View File

@ -42,7 +42,7 @@ defProtoPipelineSize :: Int
defProtoPipelineSize = 65536*2 defProtoPipelineSize = 65536*2
defCookieTimeoutSec :: Timeout 'Seconds defCookieTimeoutSec :: Timeout 'Seconds
defCookieTimeoutSec = 3600 defCookieTimeoutSec = 1200
defCookieTimeout :: TimeSpec defCookieTimeout :: TimeSpec
defCookieTimeout = toTimeSpec defCookieTimeoutSec defCookieTimeout = toTimeSpec defCookieTimeoutSec

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

@ -164,16 +164,21 @@ peerPingLoop cfg = do
for_ pips $ \p -> do for_ pips $ \p -> do
npi <- newPeerInfo npi <- newPeerInfo
pfails <- fetch True npi (PeerInfoKey p) (view peerPingFailed)
pdownfails <- fetch True npi (PeerInfoKey p) (view peerDownloadFail) here <- find @e (KnownPeerKey p) id
pinfo <- fetch True npi (PeerInfoKey p) id
let pfails = view peerPingFailed pinfo
let pdownfails = view peerDownloadFail pinfo
liftIO $ atomically $ modifyTVar pfails succ liftIO $ atomically $ modifyTVar pfails succ
sendPing @e p sendPing @e p
fnum <- liftIO $ readTVarIO pfails fnum <- liftIO $ readTVarIO pfails
fdown <- liftIO $ readTVarIO pdownfails fdown <- liftIO $ readTVarIO pdownfails
when (fnum > 2) do -- FIXME: hardcode! when (fnum > 4) do -- FIXME: hardcode!
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)

15
hbs2-peer/app/PeerTypes.hs
View File

@ -372,15 +372,26 @@ delPeerThread p = do
maybe1 pt (pure ()) $ liftIO . cancel . view peerThreadAsync maybe1 pt (pure ()) $ liftIO . cancel . view peerThreadAsync
newPeerThread :: (MyPeer e, MonadIO m) => Peer e -> Async () -> BlockDownloadM e m () newPeerThread :: ( MyPeer e
, MonadIO m
, Sessions e (PeerInfo e) m
-- , Sessions e (PeerInfo e) (BlockDownloadM e m)
)
=> Peer e
-> Async ()
-> BlockDownloadM e m ()
newPeerThread p m = do newPeerThread p m = do
npi <- newPeerInfo
void $ lift $ fetch True npi (PeerInfoKey p) id
q <- liftIO newTQueueIO q <- liftIO newTQueueIO
let pt = PeerThread m q let pt = PeerThread m q
threads <- asks (view peerThreads) threads <- asks (view peerThreads)
liftIO $ atomically $ modifyTVar threads $ HashMap.insert p pt liftIO $ atomically $ modifyTVar threads $ HashMap.insert p pt
failedDownload :: forall e m . ( MyPeer e failedDownload :: forall e m . ( MyPeer e
, MonadIO m , MonadIO m
, HasPeer e , HasPeer e