From cc001b0451d28ef1eac43bb50173a2e289e5e092 Mon Sep 17 00:00:00 2001
From: voidlizard <dzuikov@gmail.com>
Date: Tue, 4 Mar 2025 18:43:46 +0300
Subject: [PATCH] wip, hunting busyloops

---
 hbs2-peer/app/PeerMain.hs                     |  6 ++++
 hbs2-peer/app/RPC2.hs                         |  3 ++
 hbs2-peer/lib/HBS2/Peer/RPC/Internal/Types.hs | 35 ++++++++++---------
 3 files changed, 27 insertions(+), 17 deletions(-)

diff --git a/hbs2-peer/app/PeerMain.hs b/hbs2-peer/app/PeerMain.hs
index 9e324657..6bded06a 100644
--- a/hbs2-peer/app/PeerMain.hs
+++ b/hbs2-peer/app/PeerMain.hs
@@ -1319,6 +1319,11 @@ runPeer opts = respawnOnError opts $ do
   setProbe rpcmsg rpcProbe
   addProbe rpcProbe
 
+  let doCleanupByPassMessaging = withPeerM penv do
+        debug $ red "doCleanupByPassMessaging"
+        pips <- getKnownPeers @L4Proto
+        cleanupByPassMessaging byPass pips
+
   let rpcctx = RPC2Context { rpcSelf = myself
                            , rpcConfig = fromPeerConfig conf
                            , rpcMessaging = rpcmsg
@@ -1331,6 +1336,7 @@ runPeer opts = respawnOnError opts $ do
                            , rpcByPassInfo = liftIO (getStat byPass)
                            , rpcProbes = probes
                            , rpcDoFetch = liftIO . fetchHash penv
+                           , rpcCleanupByPassMessaging = doCleanupByPassMessaging
                            , rpcDoRefChanHeadPost = refChanHeadPostAction
                            , rpcDoRefChanPropose = refChanProposeAction
                            , rpcDoRefChanNotify = refChanNotifyAction
diff --git a/hbs2-peer/app/RPC2.hs b/hbs2-peer/app/RPC2.hs
index faa42b07..23c5145b 100644
--- a/hbs2-peer/app/RPC2.hs
+++ b/hbs2-peer/app/RPC2.hs
@@ -218,6 +218,9 @@ instance (e ~ L4Proto, MonadUnliftIO m, HasRpcContext PeerAPI RPC2Context m) =>
           _ -> do
             pure nil
 
+        entry $ bindMatch "test:cleanupByPassMessaging" $ const $ do
+          liftIO rpcCleanupByPassMessaging
+          pure $ mkSym "done"
 
         entry $ bindMatch "test:explode" $ const do
 
diff --git a/hbs2-peer/lib/HBS2/Peer/RPC/Internal/Types.hs b/hbs2-peer/lib/HBS2/Peer/RPC/Internal/Types.hs
index 24594878..4cb9d853 100644
--- a/hbs2-peer/lib/HBS2/Peer/RPC/Internal/Types.hs
+++ b/hbs2-peer/lib/HBS2/Peer/RPC/Internal/Types.hs
@@ -32,23 +32,24 @@ import HBS2.Prelude (asyncLinked)
 
 data RPC2Context =
   RPC2Context
-  { rpcSelf                :: ThreadId
-  , rpcConfig              :: [Syntax C]
-  , rpcMessaging           :: MessagingUnix
-  , rpcTCP                 :: Maybe MessagingTCP
-  , rpcPokeAnswer          :: String
-  , rpcPeerEnv             :: PeerEnv L4Proto
-  , rpcLocalMultiCast      :: Peer L4Proto
-  , rpcStorage             :: AnyStorage
-  , rpcBrains              :: SomeBrains L4Proto
-  , rpcByPassInfo          :: IO ByPassStat
-  , rpcProbes              :: TVar [AnyProbe]
-  , rpcDoFetch             :: HashRef -> IO ()
-  , rpcDoRefChanHeadPost   :: HashRef -> IO ()
-  , rpcDoRefChanPropose    :: (PubKey 'Sign 'HBS2Basic, SignedBox ByteString 'HBS2Basic) -> IO ()
-  , rpcDoRefChanNotify     :: (PubKey 'Sign 'HBS2Basic, SignedBox ByteString 'HBS2Basic) -> IO ()
-  , rpcMailboxService      :: AnyMailboxService HBS2Basic
-  , rpcMailboxAdapter      :: AnyMailboxAdapter HBS2Basic
+  { rpcSelf                   :: ThreadId
+  , rpcConfig                 :: [Syntax C]
+  , rpcMessaging              :: MessagingUnix
+  , rpcTCP                    :: Maybe MessagingTCP
+  , rpcPokeAnswer             :: String
+  , rpcPeerEnv                :: PeerEnv L4Proto
+  , rpcLocalMultiCast         :: Peer L4Proto
+  , rpcStorage                :: AnyStorage
+  , rpcBrains                 :: SomeBrains L4Proto
+  , rpcByPassInfo             :: IO ByPassStat
+  , rpcProbes                 :: TVar [AnyProbe]
+  , rpcCleanupByPassMessaging :: IO ()
+  , rpcDoFetch                :: HashRef -> IO ()
+  , rpcDoRefChanHeadPost      :: HashRef -> IO ()
+  , rpcDoRefChanPropose       :: (PubKey 'Sign 'HBS2Basic, SignedBox ByteString 'HBS2Basic) -> IO ()
+  , rpcDoRefChanNotify        :: (PubKey 'Sign 'HBS2Basic, SignedBox ByteString 'HBS2Basic) -> IO ()
+  , rpcMailboxService         :: AnyMailboxService HBS2Basic
+  , rpcMailboxAdapter         :: AnyMailboxAdapter HBS2Basic
   }
 
 instance (Monad m, Messaging MessagingUnix UNIX (Encoded UNIX)) => HasFabriq UNIX (ReaderT RPC2Context m) where