Recover sigusr1 signal handler

Make addresses polymorphic

ouroboros-network/ouroboros-network.cabal

@@ -56,6 +56,7 @@ library
   exposed-modules:
     Control.Concurrent.Class.MonadSTM.Strict.TMergeVar
     Ouroboros.Cardano.Diffusion.Configuration
+    Ouroboros.Cardano.Diffusion.Handlers
     Ouroboros.Cardano.Diffusion.Policies
     Ouroboros.Cardano.Network.ArgumentsExtra
     Ouroboros.Cardano.Network.LedgerPeerConsensusInterface
@@ -187,7 +188,8 @@ library
 
   if !os(windows)
     build-depends:
-      directory
+      directory,
+      unix,
 
   if flag(asserts)
     ghc-options: -fno-ignore-asserts

ouroboros-network/src/Ouroboros/Cardano/Diffusion/Handlers.hs

@@ -0,0 +1,87 @@
+{-# LANGUAGE CPP #-}
+
+#if !defined(mingw32_HOST_OS)
+#define POSIX
+#endif
+
+module Ouroboros.Cardano.Diffusion.Handlers where
+
+import Control.Concurrent.Class.MonadSTM.Strict
+import Ouroboros.Cardano.Network.LedgerPeerConsensusInterface
+import Ouroboros.Cardano.Network.PeerSelection.Governor.PeerSelectionState
+import Ouroboros.Network.ConnectionManager.Types
+import Ouroboros.Network.Diffusion.Common
+import Ouroboros.Network.PeerSelection.Governor
+import Ouroboros.Network.PeerSelection.PeerMetric
+#ifdef POSIX
+import Control.Monad.Class.MonadTime.SI
+import Control.Tracer (traceWith)
+import Ouroboros.Network.ConnectionManager.Core (Trace (..))
+import Ouroboros.Network.PeerSelection.Governor.Types
+           (makeDebugPeerSelectionState)
+import Ouroboros.Network.PeerSelection.LedgerPeers.Type
+import System.Posix.Signals qualified as Signals
+#endif
+
+#ifdef POSIX
+sigUSR1Handler
+  :: Ord ntnAddr
+  => TracersExtra ntnAddr ntnVersion ntnVersionData ntcAddr ntcVersion
+     ntcVersionData resolverError CardanoPeerSelectionState
+     CardanoDebugPeerSelectionState extraFlags extraPeers extraCounters
+     IO
+  -> ArgumentsExtra extraArgs CardanoPeerSelectionState extraActions
+     (CardanoLedgerPeersConsensusInterface IO) extraPeers extraFlags
+     extraChurnArgs extraCounters exception peeraddr IO
+  -> Applications ntnAddr ntnVersion ntnVersionData ntcAddr ntcVersion
+     ntcVersionData (CardanoLedgerPeersConsensusInterface IO) IO a
+  -> ConnectionManager muxMode socket ntnAddr handle handleError IO
+  -> StrictTVar IO (PeerSelectionState CardanoPeerSelectionState
+     extraFlags extraPeers ntnAddr peerconn)
+  -> PeerMetrics IO ntnAddr
+  -> IO ()
+sigUSR1Handler tracersExtra argsExtra apps connectionManager
+                        dbgStateVar metrics = do
+  _ <- Signals.installHandler
+         Signals.sigUSR1
+         (Signals.Catch
+           (do state <- atomically $ readState connectionManager
+               traceWith (dtConnectionManagerTracer tracersExtra)
+                         (TrState state)
+               ps <- readTVarIO dbgStateVar
+               now <- getMonotonicTime
+               (up, bp, lsj, am) <- atomically $
+                 (,,,) <$> upstreamyness metrics
+                       <*> fetchynessBlocks metrics
+                       <*> (CardanoDebugPeerSelectionState <$>
+                             clpciGetLedgerStateJudgement
+                               (lpExtraAPI (daLedgerPeersCtx apps)))
+                       <*> readAssociationMode
+                             (daReadUseLedgerPeers argsExtra)
+                             (daOwnPeerSharing argsExtra)
+                             (cpstBootstrapPeersFlag (extraState ps))
+               let dbgState = makeDebugPeerSelectionState ps up bp lsj am
+               traceWith (dtTracePeerSelectionTracer tracersExtra)
+                         (TraceDebugState now dbgState)
+           )
+         )
+         Nothing
+  return ()
+#else
+sigUSR1Handler
+  :: TracersExtra ntnAddr ntnVersion ntnVersionData ntcAddr ntcVersion
+     ntcVersionData resolverError CardanoPeerSelectionState
+     CardanoDebugPeerSelectionState extraFlags extraPeers extraCounters
+     IO
+  -> ArgumentsExtra extraArgs CardanoPeerSelectionState extraActions
+     (CardanoLedgerPeersConsensusInterface IO) extraPeers extraFlags
+     extraChurnArgs extraCounters exception peeraddr IO
+  -> Applications ntnAddr ntnVersion ntnVersionData ntcAddr ntcVersion
+     ntcVersionData (CardanoLedgerPeersConsensusInterface IO) IO a
+  -> ConnectionManager muxMode socket ntnAddr handle handleError IO
+  -> StrictTVar IO (PeerSelectionState CardanoPeerSelectionState
+     extraFlags extraPeers ntnAddr peerconn)
+  -> PeerMetrics IO ntnAddr
+  -> IO ()
+sigUSR1Handler _ _ _ _ _ _ = pure ()
+#endif

ouroboros-network/src/Ouroboros/Network/Diffusion.hs

@@ -75,20 +75,20 @@ data ArgumentsExtra
 
 -- | Application data which depend on p2p mode.
 --
-data Applications (p2p :: P2P) extraAPI m a where
+data Applications (p2p :: P2P) ntnAddr ntcAddr versionDataNTN versionDataNTC extraAPI m a where
   P2PApplications
     :: Common.Applications
-         RemoteAddress  NodeToNodeVersion   NodeToNodeVersionData
-         LocalAddress   NodeToClientVersion NodeToClientVersionData
+         ntnAddr  NodeToNodeVersion   versionDataNTN
+         ntcAddr  NodeToClientVersion versionDataNTC
          extraAPI m a
-    -> Applications 'P2P extraAPI m a
+    -> Applications 'P2P ntnAddr ntcAddr versionDataNTN versionDataNTC extraAPI m a
 
   NonP2PApplications
     :: Common.Applications
-         RemoteAddress  NodeToNodeVersion   NodeToNodeVersionData
-         LocalAddress   NodeToClientVersion NodeToClientVersionData
+         ntnAddr NodeToNodeVersion   versionDataNTN
+         ntcAddr NodeToClientVersion versionDataNTC
          () m a
-    -> Applications 'NonP2P () m a
+    -> Applications 'NonP2P ntnAddr ntcAddr versionDataNTN versionDataNTC extraAPI m a
 
 -- | Application data which depend on p2p mode.
 --
@@ -137,7 +137,7 @@ run :: forall (p2p :: P2P) extraArgs extraState extraActions extraFlags
     -> ArgumentsExtra p2p extraArgs extraState extraActions extraAPI
        extraPeers extraFlags extraChurnArgs extraCounters exception
        RemoteAddress IO
-    -> Applications p2p extraAPI IO a
+    -> Applications p2p RemoteAddress LocalAddress NodeToNodeVersionData NodeToClientVersionData extraAPI IO a
 
     -> ApplicationsExtra p2p RemoteAddress IO a
     -> IO ()