diff --git a/hbs2-peer/app/BlockDownloadNew.hs b/hbs2-peer/app/BlockDownloadNew.hs index 0602127a..4ab726ef 100644 --- a/hbs2-peer/app/BlockDownloadNew.hs +++ b/hbs2-peer/app/BlockDownloadNew.hs @@ -231,13 +231,13 @@ instance MonadUnliftIO m => IsBurstMachine BurstMachine m where _rates <- newTVarIO (mempty :: Map Double Double) - pause @'Seconds (realToFrac _buTimeout) + pause @'Seconds (min 1 $ realToFrac _buTimeout) flip runContT pure do void $ ContT $ withAsync do forever do - pause @'Seconds (realToFrac _buTimeout * 10) + pause @'Seconds (min 2 $ realToFrac _buTimeout * 10) atomically do e <- headDef bu0 . Map.elems <$> readTVar _rates @@ -293,7 +293,7 @@ instance MonadUnliftIO m => IsBurstMachine BurstMachine m where pure e2 - pause @'Seconds dt + pause @'Seconds (min 1 dt) next eNew instance MonadIO m => IsBurstMachine ConstBurstMachine m where diff --git a/hbs2-peer/app/PeerMain.hs b/hbs2-peer/app/PeerMain.hs index 3769850e..7eb4f3b3 100644 --- a/hbs2-peer/app/PeerMain.hs +++ b/hbs2-peer/app/PeerMain.hs @@ -58,6 +58,7 @@ import MailboxProtoWorker import HttpWorker import DispatchProxy import PeerMeta +import Watchdogs import CLI.Common import CLI.RefChan import CLI.LWWRef @@ -776,6 +777,8 @@ runPeer opts = respawnOnError opts $ do let tcpProbeWait = runReader (cfgValue @PeerTcpProbeWaitKey) syn & fromInteger @(Timeout 'Seconds) . fromMaybe 300 + let rpc = getRpcSocketName conf + let addProbe :: forall m . MonadIO m => AnyProbe -> m () addProbe p = liftIO $ atomically $ modifyTVar probes (p:) @@ -1240,6 +1243,8 @@ runPeer opts = respawnOnError opts $ do peerThread "mailboxProtoWorker" (mailboxProtoWorker (pure mboxConf) mailboxWorker) + peerThread "rpcWatchDog" (runRpcWatchDog myself rpc) + liftIO $ withPeerM penv do runProto @e [ makeResponse (blockSizeProto blk onNoBlock) @@ -1304,6 +1309,7 @@ runPeer opts = respawnOnError opts $ do probe <- newSimpleProbe "PeerEnv_Announce" addProbe probe peerEnvSetProbe menv probe + probesMenv <- liftIO $ async $ forever do pause @'Seconds 10 peerEnvCollectProbes menv @@ -1333,7 +1339,6 @@ runPeer opts = respawnOnError opts $ do PeerHttpPort Nothing -> mempty PeerHttpPort (Just p) -> "http-port:" <+> pretty p - let rpc = getRpcSocketName conf let pokeAnsw = show $ vcat [ "peer-key:" <+> dquotes (pretty (AsBase58 k)) , "udp:" <+> dquotes (pretty (fst . snd <$> udpPoint)) diff --git a/hbs2-peer/hbs2-peer.cabal b/hbs2-peer/hbs2-peer.cabal index 81321a18..df672439 100644 --- a/hbs2-peer/hbs2-peer.cabal +++ b/hbs2-peer/hbs2-peer.cabal @@ -286,6 +286,7 @@ executable hbs2-peer , MailboxProtoWorker , CheckMetrics , HttpWorker + , Watchdogs , Brains , DispatchProxy , CLI.Common