Update block forging configuration on SIGHUP

Refactor code to accomodate the changes

Co-authored-by: Marcin Szamotulski <coot@coot.me>

cardano-node/src/Cardano/Node/Run.hs

@@ -8,6 +8,7 @@
 {-# LANGUAGE PackageImports #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE ExplicitNamespaces #-}
 
 {-# OPTIONS_GHC -Wno-unused-imports #-}
 
@@ -23,7 +24,7 @@ module Cardano.Node.Run
 import           Cardano.Api (File (..), FileDirection (..))
 import qualified Cardano.Api as Api
 
-import           Cardano.Prelude (FatalError (..))
+import           Cardano.Prelude (FatalError (..), (:~:) (..))
 
 import           Data.Bits
 import           Data.IP (toSockAddr)
@@ -98,7 +99,7 @@ import qualified Ouroboros.Network.Diffusion.NonP2P as NonP2P
 import qualified Ouroboros.Network.Diffusion.P2P as P2P
 import           Ouroboros.Network.NodeToClient (LocalAddress (..), LocalSocket (..))
 import           Ouroboros.Network.NodeToNode (AcceptedConnectionsLimit (..),
-                   PeerSelectionTargets (..), RemoteAddress)
+                   PeerSelectionTargets (..), RemoteAddress, ConnectionId)
 import           Ouroboros.Network.PeerSelection.LedgerPeers (UseLedgerAfter (..))
 import           Ouroboros.Network.PeerSelection.RelayAccessPoint (RelayAccessPoint (..))
 import           Ouroboros.Network.Subscription (DnsSubscriptionTarget (..),
@@ -164,8 +165,8 @@ runNode cmdPc = do
               in getNetworkMagic $ Consensus.configBlock pInfoConfig
 
     case p of
-      SomeConsensusProtocol _ runP ->
-        handleNodeWithTracers cmdPc nc p networkMagic runP
+      SomeConsensusProtocol blockType runP ->
+        handleNodeWithTracers cmdPc nc p networkMagic blockType runP
 
 -- | Workaround to ensure that the main thread throws an async exception on
 -- receiving a SIGTERM signal.
@@ -193,9 +194,10 @@ handleNodeWithTracers
   -> NodeConfiguration
   -> SomeConsensusProtocol
   -> Api.NetworkMagic
+  -> Api.BlockType blk
   -> Api.ProtocolInfoArgs blk
   -> IO ()
-handleNodeWithTracers cmdPc nc p networkMagic runP = do
+handleNodeWithTracers cmdPc nc p networkMagic blockType runP = do
   -- This IORef contains node kernel structure which holds node kernel.
   -- Used for ledger queries and peer connection status.
   nodeKernelData <- mkNodeKernelData
@@ -219,7 +221,7 @@ handleNodeWithTracers cmdPc nc p networkMagic runP = do
           mapM_ (traceWith $ startupTracer tracers) startupInfo
           traceNodeStartupInfo (nodeStartupInfoTracer tracers) startupInfo
 
-          handleSimpleNode runP p2pMode tracers nc
+          handleSimpleNode blockType runP p2pMode tracers nc
             (\nk -> do
                 setNodeKernel nodeKernelData nk
                 traceWith (nodeStateTracer tracers) NodeKernelOnline)
@@ -258,7 +260,7 @@ handleNodeWithTracers cmdPc nc p networkMagic runP = do
 
           -- We ignore peer logging thread if it dies, but it will be killed
           -- when 'handleSimpleNode' terminates.
-          handleSimpleNode runP p2pMode tracers nc
+          handleSimpleNode blockType runP p2pMode tracers nc
             (\nk -> do
                 setNodeKernel nodeKernelData nk
                 traceWith (nodeStateTracer tracers) NodeKernelOnline)
@@ -325,7 +327,8 @@ handlePeersListSimple tr nodeKern = forever $ do
 
 handleSimpleNode
   :: forall blk p2p . Api.Protocol IO blk
-  => Api.ProtocolInfoArgs blk
+  => Api.BlockType blk
+  -> Api.ProtocolInfoArgs blk
   -> NetworkP2PMode p2p
   -> Tracers RemoteConnectionId LocalConnectionId blk p2p
   -> NodeConfiguration
@@ -334,7 +337,7 @@ handleSimpleNode
   -- layer is initialised.  This implies this function must not block,
   -- otherwise the node won't actually start.
   -> IO ()
-handleSimpleNode runP p2pMode tracers nc onKernel = do
+handleSimpleNode blockType runP p2pMode tracers nc onKernel = do
   logStartupWarnings
 
   traceWith (startupTracer tracers)
@@ -426,12 +429,6 @@ handleSimpleNode runP p2pMode tracers nc onKernel = do
         (localRootsVar :: StrictTVar IO [(Int, Map RelayAccessPoint PeerAdvertise)])  <- newTVarIO localRoots
         publicRootsVar <- newTVarIO publicRoots
         useLedgerVar   <- newTVarIO (useLedgerAfterSlot nt)
-#ifdef UNIX
-        _ <- Signals.installHandler
-              Signals.sigHUP
-              (updateTopologyConfiguration localRootsVar publicRootsVar useLedgerVar)
-              Nothing
-#endif
         void $
           let diffusionArgumentsExtra =
                 mkP2PArguments nc
@@ -440,7 +437,12 @@ handleSimpleNode runP p2pMode tracers nc onKernel = do
                   (readTVar useLedgerVar)
           in
           Node.run
-            nodeArgs
+            nodeArgs {
+                rnNodeKernelHook = \registry nodeKernel -> do
+                  installP2PSigHUPHandler (startupTracer tracers) blockType nc nodeKernel
+                                          localRootsVar publicRootsVar useLedgerVar
+                  rnNodeKernelHook nodeArgs registry nodeKernel
+            }
             StdRunNodeArgs
               { srnBfcMaxConcurrencyBulkSync    = unMaxConcurrencyBulkSync <$> ncMaxConcurrencyBulkSync nc
               , srnBfcMaxConcurrencyDeadline    = unMaxConcurrencyDeadline <$> ncMaxConcurrencyDeadline nc
@@ -456,14 +458,6 @@ handleSimpleNode runP p2pMode tracers nc onKernel = do
               , srnMaybeMempoolCapacityOverride = ncMaybeMempoolCapacityOverride nc
               }
       DisabledP2PMode -> do
-#ifdef UNIX
-        _ <- Signals.installHandler
-              Signals.sigHUP
-              (Signals.Catch $ do
-                traceWith (startupTracer tracers) NetworkConfigUpdateUnsupported
-              )
-              Nothing
-#endif
         nt <- TopologyNonP2P.readTopologyFileOrError nc
         let (ipProducerAddrs, dnsProducerAddrs) = producerAddressesNonP2P nt
 
@@ -480,7 +474,11 @@ handleSimpleNode runP p2pMode tracers nc onKernel = do
                            (length ipProducerAddrs)
         void $
           Node.run
-            nodeArgs
+            nodeArgs {
+                rnNodeKernelHook = \registry nodeKernel -> do
+                  installNonP2PSigHUPHandler (startupTracer tracers) blockType nc nodeKernel
+                  rnNodeKernelHook nodeArgs registry nodeKernel
+            }
             StdRunNodeArgs
               { srnBfcMaxConcurrencyBulkSync   = unMaxConcurrencyBulkSync <$> ncMaxConcurrencyBulkSync nc
               , srnBfcMaxConcurrencyDeadline   = unMaxConcurrencyDeadline <$> ncMaxConcurrencyDeadline nc
@@ -529,31 +527,6 @@ handleSimpleNode runP p2pMode tracers nc onKernel = do
                    (WarningDevelopmentNodeToClientVersions
                      developmentNtcVersions)
 
-#ifdef UNIX
-  -- only used when P2P is enabled
-  updateTopologyConfiguration :: StrictTVar IO [(Int, Map RelayAccessPoint PeerAdvertise)]
-                              -> StrictTVar IO (Map RelayAccessPoint PeerAdvertise)
-                              -> StrictTVar IO UseLedgerAfter
-                              -> Signals.Handler
-  updateTopologyConfiguration localRootsVar publicRootsVar useLedgerVar =
-    Signals.Catch $ do
-      traceWith (startupTracer tracers) NetworkConfigUpdate
-      result <- try $ TopologyP2P.readTopologyFileOrError (startupTracer tracers) nc
-      case result of
-        Left (FatalError err) ->
-          traceWith (startupTracer tracers)
-                  $ NetworkConfigUpdateError
-                  $ pack "Error reading topology configuration file:" <> err
-        Right nt -> do
-          let (localRoots, publicRoots) = producerAddresses nt
-          traceWith (startupTracer tracers)
-                  $ NetworkConfig localRoots publicRoots (useLedgerAfterSlot nt)
-          atomically $ do
-            writeTVar localRootsVar localRoots
-            writeTVar publicRootsVar publicRoots
-            writeTVar useLedgerVar (useLedgerAfterSlot nt)
-#endif
-
   limitToLatestReleasedVersion :: forall k v.
        Ord k
     => ((Maybe NodeToNodeVersion, Maybe NodeToClientVersion) -> Maybe k)
@@ -566,6 +539,104 @@ handleSimpleNode runP p2pMode tracers nc onKernel = do
         Nothing       -> id
         Just version_ -> Map.takeWhileAntitone (<= version_)
 
+--------------------------------------------------------------------------------
+-- SIGHUP Handlers
+--------------------------------------------------------------------------------
+
+-- | The P2P SIGHUP handler can update block forging & reconfigure network topology.
+--
+installP2PSigHUPHandler :: Tracer IO (StartupTrace blk)
+                        -> Api.BlockType blk
+                        -> NodeConfiguration
+                        -> NodeKernel IO RemoteAddress (ConnectionId LocalAddress) blk
+                        -> StrictTVar IO [(Int, Map RelayAccessPoint PeerAdvertise)]
+                        -> StrictTVar IO (Map RelayAccessPoint PeerAdvertise)
+                        -> StrictTVar IO UseLedgerAfter
+                        -> IO ()
+#ifndef UNIX
+installP2PSigHUPHandler _ _ _ _ _ _ _ = return ()
+#else
+installP2PSigHUPHandler startupTracer blockType nc nodeKernel localRootsVar publicRootsVar useLedgerVar =
+  void $ Signals.installHandler
+    Signals.sigHUP
+    (Signals.Catch $ do
+      updateBlockForging startupTracer blockType nodeKernel nc
+      updateTopologyConfiguration startupTracer nc localRootsVar publicRootsVar useLedgerVar
+    )
+    Nothing
+#endif
+
+-- | The NonP2P SIGHUP handler can only update block forging.
+--
+installNonP2PSigHUPHandler :: Tracer IO (StartupTrace blk)
+                           -> Api.BlockType blk
+                           -> NodeConfiguration
+                           -> NodeKernel IO RemoteAddress (ConnectionId LocalAddress) blk
+                           -> IO ()
+#ifndef UNIX
+installNonP2PSigHUPHandler _ _ _ _ = return ()
+#else
+installNonP2PSigHUPHandler startupTracer blockType nc nodeKernel =
+  void $ Signals.installHandler
+    Signals.sigHUP
+    (Signals.Catch $ do
+      updateBlockForging startupTracer blockType nodeKernel nc
+      traceWith startupTracer NetworkConfigUpdateUnsupported
+    )
+    Nothing
+#endif
+
+
+#ifdef UNIX
+updateBlockForging :: Tracer IO (StartupTrace blk)
+                   -> Api.BlockType blk
+                   -> NodeKernel IO RemoteAddress (ConnectionId LocalAddress) blk
+                   -> NodeConfiguration
+                   -> IO ()
+updateBlockForging startupTracer blockType nodeKernel nc = do
+  eitherSomeProtocol <- runExceptT $ mkConsensusProtocol
+                                       (ncProtocolConfig nc)
+                                       (Just (ncProtocolFiles nc))
+  case eitherSomeProtocol of
+    Left err ->
+      traceWith startupTracer (BlockForgingUpdateError err)
+    Right (SomeConsensusProtocol blockType' runP') ->
+      case Api.reflBlockType blockType blockType' of
+        Just Refl -> do
+          -- TODO: check if runP' has changed
+          traceWith startupTracer BlockForgingUpdate
+          snd (Api.protocolInfo runP') >>= setBlockForging nodeKernel
+        Nothing ->
+          traceWith startupTracer
+            $ BlockForgingBlockTypeMismatch
+                (Api.SomeBlockType blockType)
+                (Api.SomeBlockType blockType')
+  return ()
+
+updateTopologyConfiguration :: Tracer IO (StartupTrace blk)
+                            -> NodeConfiguration
+                            -> StrictTVar IO [(Int, Map RelayAccessPoint PeerAdvertise)]
+                            -> StrictTVar IO (Map RelayAccessPoint PeerAdvertise)
+                            -> StrictTVar IO UseLedgerAfter
+                            -> IO ()
+updateTopologyConfiguration startupTracer nc localRootsVar publicRootsVar useLedgerVar = do
+    traceWith startupTracer NetworkConfigUpdate
+    result <- try $ readTopologyFileOrError startupTracer nc
+    case result of
+      Left (FatalError err) ->
+        traceWith startupTracer
+                $ NetworkConfigUpdateError
+                $ pack "Error reading topology configuration file:" <> err
+      Right nt -> do
+        let (localRoots, publicRoots) = producerAddresses nt
+        traceWith startupTracer
+                $ NetworkConfig localRoots publicRoots (useLedgerAfterSlot nt)
+        atomically $ do
+          writeTVar localRootsVar localRoots
+          writeTVar publicRootsVar publicRoots
+          writeTVar useLedgerVar (useLedgerAfterSlot nt)
+#endif
+
 --------------------------------------------------------------------------------
 -- Helper functions
 --------------------------------------------------------------------------------