diff --git a/hbs2-core/lib/HBS2/Defaults.hs b/hbs2-core/lib/HBS2/Defaults.hs index 72996f2e..81ff3428 100644 --- a/hbs2-core/lib/HBS2/Defaults.hs +++ b/hbs2-core/lib/HBS2/Defaults.hs @@ -42,7 +42,7 @@ defProtoPipelineSize :: Int defProtoPipelineSize = 65536*2 defCookieTimeoutSec :: Timeout 'Seconds -defCookieTimeoutSec = 3600 +defCookieTimeoutSec = 1200 defCookieTimeout :: TimeSpec defCookieTimeout = toTimeSpec defCookieTimeoutSec diff --git a/hbs2-peer/app/PeerInfo.hs b/hbs2-peer/app/PeerInfo.hs index 47530bf7..c2a9aa53 100644 --- a/hbs2-peer/app/PeerInfo.hs +++ b/hbs2-peer/app/PeerInfo.hs @@ -164,16 +164,21 @@ peerPingLoop cfg = do for_ pips $ \p -> do 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 + sendPing @e p fnum <- liftIO $ readTVarIO pfails 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" delPeers pl [p] expire (PeerInfoKey p) diff --git a/hbs2-peer/app/PeerTypes.hs b/hbs2-peer/app/PeerTypes.hs index 33fd3da4..cd21c3cb 100644 --- a/hbs2-peer/app/PeerTypes.hs +++ b/hbs2-peer/app/PeerTypes.hs @@ -372,15 +372,26 @@ delPeerThread p = do 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 + + npi <- newPeerInfo + void $ lift $ fetch True npi (PeerInfoKey p) id + q <- liftIO newTQueueIO let pt = PeerThread m q threads <- asks (view peerThreads) liftIO $ atomically $ modifyTVar threads $ HashMap.insert p pt - failedDownload :: forall e m . ( MyPeer e , MonadIO m , HasPeer e