hbs2-peer, simple rpc watchdog

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

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))

hbs2-peer/hbs2-peer.cabal

@@ -286,6 +286,7 @@ executable hbs2-peer
                     , MailboxProtoWorker
                     , CheckMetrics
                     , HttpWorker
+                    , Watchdogs
                     , Brains
                     , DispatchProxy
                     , CLI.Common