hbs2-peer extract multicast worker probe

hbs2-core/lib/HBS2/Actors/Peer.hs

@@ -398,6 +398,10 @@ newPeerEnv pl s bus p = do
 peerEnvSetProbe :: (MonadIO m) => PeerEnv e -> AnyProbe -> m ()
 peerEnvSetProbe PeerEnv {..} p = liftIO $ atomically $ writeTVar _envProbe p
 
+-- peerEnvAddProbe :: (MonadIO m) => PeerEnv e -> AnyProbe -> m ()
+-- peerEnvAddProbe PeerEnv {..} p = liftIO $ atomically $ modifyTVar _envProbe p
+
+
 peerEnvCollectProbes :: (MonadIO m) => PeerEnv e -> m ()
 peerEnvCollectProbes PeerEnv {..} = do
   probe <- liftIO $ readTVarIO _envProbe

hbs2-peer/app/Multicast.hs

@@ -70,9 +70,9 @@ multicastWorker :: forall e s m . ( s ~ Encryption e
                                   -- , HasPeerLocator e m
                                   -- , HasPeerNonce L4Proto m
                                   )
-                => PeerConfig -> PeerEnv e -> PeerM e m ()
+                => PeerConfig -> PeerEnv e -> AnyProbe -> PeerM e m ()
 
-multicastWorker conf penv = recover do
+multicastWorker conf penv probe = recover do
 
   debug $ red "multicastWorker started"
 
@@ -93,6 +93,8 @@ multicastWorker conf penv = recover do
 
     menv <- newPeerEnv pl sto (Fabriq mcast) (getOwnPeer mcast)
 
+    peerEnvSetProbe menv probe
+
     ann <- ContT $ withAsync $ do
             localMulticast <- atomically $ takeTMVar localMCast_
             forever do
@@ -102,6 +104,10 @@ multicastWorker conf penv = recover do
               request localMulticast (PeerAnnounce @e pnonce)
               pause w
 
+    void $ ContT $ withAsync $ forever do
+      pause @'Seconds 10
+      peerEnvCollectProbes menv
+
     liftIO $ runPeerM menv $ do
 
       self <- ownPeer @e

hbs2-peer/app/PeerMain.hs

@@ -839,13 +839,6 @@ runPeer opts = respawnOnError opts $ do
 
                            `orDie` "assertion: localMulticastPeer not set"
 
-  -- notice $ "multicast:" <+> pretty localMulticast
-
-  -- mcast <- newMessagingUDPMulticast defLocalMulticast
-  --           `orDie` "Can't start multicast listener"
-
-  -- messMcast <- async $ runMessagingUDP mcast
-
   brains <- newBasicBrains @e conf
 
   bProbe <- newSimpleProbe "Brains"
@@ -1186,7 +1179,10 @@ runPeer opts = respawnOnError opts $ do
 
               flip runContT pure do
 
-                peerThread "multicastWorker" $ multicastWorker conf env
+                mcastProbe <- newSimpleProbe "PeerEnv_Announce"
+                addProbe mcastProbe
+
+                peerThread "multicastWorker" $ multicastWorker conf env mcastProbe
 
                 peerThread "byPassWorker" (byPassWorker byPass)