Merge #3932

3932: cardano-node:  implement --shutdown-on-block-synced r=deepfire a=deepfire

This:

1. adds `--shutdown-on-block-synced BLOCKNO` option, in parallel to `--shutdown-on-slot-synced SLOTNO`
2. integrates it into the workbench

Co-authored-by: Marcin Szamotulski <[email protected]>
Co-authored-by: iohk-bors[bot] <43231472+iohk-bors[bot]@users.noreply.github.com>
Co-authored-by: Kosyrev Serge <[email protected]>
Co-authored-by: Jordan Millar <[email protected]>

cardano-node/src/Cardano/Node/Handlers/Shutdown.hs

@@ -1,14 +1,21 @@
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PackageImports #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TupleSections #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
 
 module Cardano.Node.Handlers.Shutdown
-  (
+  ( ShutdownOn (..)
+  , parseShutdownOn
+
   -- * Generalised shutdown handling
-    ShutdownConfig (..)
+  , ShutdownConfig (..)
   , withShutdownHandling
 
   , ShutdownTrace (..)
@@ -19,28 +26,51 @@ module Cardano.Node.Handlers.Shutdown
   )
 where
 
+import           Cardano.Prelude
 import           Data.Aeson (FromJSON, ToJSON)
-import           Generic.Data (Generic)
 import           Generic.Data.Orphans ()
-import           Prelude
 
-import           Control.Concurrent.Async (race_)
-import           Control.Exception
-import           Control.Monad
-import           Data.Text (Text, pack)
+import           Data.Text (pack)
 import qualified GHC.IO.Handle.FD as IO (fdToHandle)
-import           System.Exit
+import qualified Options.Applicative as Opt
 import qualified System.IO as IO
 import qualified System.IO.Error as IO
 import           System.Posix.Types (Fd (Fd))
 
 import           Cardano.Slotting.Slot (WithOrigin (..))
 import           "contra-tracer" Control.Tracer
+import           Ouroboros.Consensus.Block (Header)
 import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB
 import           Ouroboros.Consensus.Util.ResourceRegistry (ResourceRegistry)
 import           Ouroboros.Consensus.Util.STM (Watcher (..), forkLinkedWatcher)
-import           Ouroboros.Network.Block (MaxSlotNo (..), SlotNo, pointSlot)
+import           Ouroboros.Network.Block (BlockNo (..), HasHeader, SlotNo (..), pointSlot)
+
+
+data ShutdownOn
+  = ASlot  !SlotNo
+  | ABlock !BlockNo
+  | NoShutdown
+  deriving (Generic, Eq, Show)
+
+deriving instance FromJSON ShutdownOn
+deriving instance ToJSON ShutdownOn
 
+parseShutdownOn :: Opt.Parser ShutdownOn
+parseShutdownOn =
+    Opt.option (ASlot . SlotNo <$> Opt.auto) (
+         Opt.long "shutdown-on-slot-synced"
+      <> Opt.metavar "SLOT"
+      <> Opt.help "Shut down the process after ChainDB is synced up to the specified slot"
+      <> Opt.hidden
+    )
+    <|>
+    Opt.option (ABlock . BlockNo <$> Opt.auto) (
+         Opt.long "shutdown-on-block-synced"
+      <> Opt.metavar "BLOCK"
+      <> Opt.help "Shut down the process after ChainDB is synced up to the specified block"
+      <> Opt.hidden
+    )
+    <|> pure NoShutdown
 
 data ShutdownTrace
   = ShutdownRequested
@@ -51,14 +81,24 @@ data ShutdownTrace
   -- ^ Received shutdown request but found unexpected input in --shutdown-ipc FD:
   | RequestingShutdown Text
   -- ^ Ringing the node shutdown doorbell for reason
-  | ShutdownArmedAtSlot SlotNo
-  -- ^ Will terminate upon reaching maxSlot
+  | ShutdownArmedAt ShutdownOn
+  -- ^ Will terminate upon reaching a ChainDB sync limit
   deriving (Generic, FromJSON, ToJSON)
 
+deriving instance FromJSON BlockNo
+deriving instance ToJSON BlockNo
+
+data AndWithOrigin
+  = AndWithOriginBlock (BlockNo, WithOrigin BlockNo)
+  | AndWithOriginSlot (SlotNo, WithOrigin SlotNo)
+  | WithoutOrigin
+
+deriving instance Eq AndWithOrigin
+
 data ShutdownConfig
   = ShutdownConfig
-    { scIPC          :: !(Maybe Fd)
-    , scOnSlotSynced :: !(Maybe MaxSlotNo)
+    { scIPC         :: !(Maybe Fd)
+    , scOnSyncLimit :: !(Maybe ShutdownOn)
     }
     deriving (Eq, Show)
 
@@ -92,28 +132,40 @@ withShutdownHandling ShutdownConfig{scIPC = Just fd} tr action = do
 -- | Spawn a thread that would cause node to shutdown upon ChainDB reaching the
 -- configuration-defined slot.
 maybeSpawnOnSlotSyncedShutdownHandler
-  :: ShutdownConfig
+  :: HasHeader (Header blk)
+  => ShutdownConfig
   -> Tracer IO ShutdownTrace
   -> ResourceRegistry IO
   -> ChainDB.ChainDB IO blk
   -> IO ()
 maybeSpawnOnSlotSyncedShutdownHandler sc tr registry chaindb =
-  case scOnSlotSynced sc of
-    Just (MaxSlotNo maxSlot) -> do
-      traceWith tr (ShutdownArmedAtSlot maxSlot)
-      spawnSlotLimitTerminator maxSlot
-    _ -> pure ()
+  case scOnSyncLimit sc of
+    Nothing -> pure ()
+    Just lim -> do
+      traceWith tr (ShutdownArmedAt lim)
+      spawnLimitTerminator lim
  where
-  spawnSlotLimitTerminator :: SlotNo -> IO ()
-  spawnSlotLimitTerminator maxSlot =
+  spawnLimitTerminator :: ShutdownOn -> IO ()
+  spawnLimitTerminator limit =
     void $ forkLinkedWatcher registry "slotLimitTerminator" Watcher {
-        wFingerprint = id
+        wFingerprint = identity
       , wInitial     = Nothing
+      , wReader      =
+          case limit of
+            ASlot   x -> AndWithOriginSlot . (x,) . pointSlot <$> ChainDB.getTipPoint chaindb
+            ABlock  x -> AndWithOriginBlock . (x,) <$> ChainDB.getTipBlockNo chaindb
+            NoShutdown -> return WithoutOrigin
       , wNotify      = \case
-          Origin -> pure ()
-          At cur -> when (cur >= maxSlot) $ do
-            traceWith tr (RequestingShutdown $ "spawnSlotLimitTerminator: reached target "
-                                                 <> (pack . show) cur)
-            throwIO ExitSuccess
-      , wReader      = pointSlot <$> ChainDB.getTipPoint chaindb
+          (AndWithOriginSlot (lim, At cur)) ->
+              when (cur >= lim) $ do
+                traceWith tr (RequestingShutdown $ "spawnLimitTerminator: reached target slot "
+                              <> (pack . show) cur)
+                throwIO ExitSuccess
+          (AndWithOriginBlock (lim, At cur)) ->
+              when (cur >= lim) $ do
+                traceWith tr (RequestingShutdown $ "spawnLimitTerminator: reached target block "
+                              <> (pack . show) cur)
+                throwIO ExitSuccess
+          WithoutOrigin -> pure ()
+          _ -> pure ()
       }

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

@@ -19,13 +19,12 @@ import qualified Options.Applicative as Opt
 import qualified Options.Applicative.Help as OptI
 import           System.Posix.Types (Fd (..))
 
-import           Ouroboros.Network.Block (MaxSlotNo (..), SlotNo (..))
-
 import           Ouroboros.Consensus.Mempool.API (MempoolCapacityBytes (..),
                    MempoolCapacityBytesOverride (..))
 import           Ouroboros.Consensus.Storage.LedgerDB.DiskPolicy (SnapshotInterval (..))
 
-import           Cardano.Node.Configuration.NodeAddress
+import           Cardano.Node.Configuration.NodeAddress (NodeHostIPv4Address (NodeHostIPv4Address),
+                   NodeHostIPv6Address (NodeHostIPv6Address), PortNumber, SocketPath (SocketPath))
 import           Cardano.Node.Configuration.POM (PartialNodeConfiguration (..), lastOption)
 import           Cardano.Node.Configuration.Socket
 import           Cardano.Node.Handlers.Shutdown
@@ -66,7 +65,7 @@ nodeRunParser = do
 
   validate <- lastOption parseValidateDB
   shutdownIPC <- lastOption parseShutdownIPC
-  shutdownOnSlot <- lastOption parseShutdownOnSlotSynced
+  shutdownOnLimit <- lastOption parseShutdownOn
 
   maybeMempoolCapacityOverride <- lastOption parseMempoolCapacityOverride
 
@@ -93,7 +92,7 @@ nodeRunParser = do
              }
            , pncValidateDB = validate
            , pncShutdownConfig =
-               Last . Just $ ShutdownConfig (getLast shutdownIPC) (getLast shutdownOnSlot)
+               Last . Just $ ShutdownConfig (getLast shutdownIPC) (getLast shutdownOnLimit)
            , pncProtocolConfig = mempty
            , pncMaxConcurrencyBulkSync = mempty
            , pncMaxConcurrencyDeadline = mempty
@@ -215,16 +214,6 @@ parseShutdownIPC =
         <> hidden
       )
 
-parseShutdownOnSlotSynced :: Parser MaxSlotNo
-parseShutdownOnSlotSynced =
-    fmap (fromMaybe NoMaxSlotNo) $
-    optional $ option (MaxSlotNo . SlotNo <$> auto) (
-         long "shutdown-on-slot-synced"
-      <> metavar "SLOT"
-      <> help "Shut down the process after ChainDB is synced up to the specified slot"
-      <> hidden
-    )
-
 parseTopologyFile :: Parser FilePath
 parseTopologyFile =
     strOption (

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

@@ -426,6 +426,14 @@ 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
         eitherTopology <- TopologyNonP2P.readTopologyFile nc
         nt <- either (\err -> panic $ "Cardano.Node.Run.handleSimpleNodeNonP2P.readTopologyFile: " <> err) pure eitherTopology
         let (ipProducerAddrs, dnsProducerAddrs) = producerAddressesNonP2P nt

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

@@ -79,6 +79,10 @@ data StartupTrace blk =
   --
   | NetworkConfigUpdate
 
+  -- | Re-configuration of network config is not supported.
+  --
+  | NetworkConfigUpdateUnsupported
+
   -- | Log network configuration update error.
   --
   | NetworkConfigUpdateError Text

cardano-node/src/Cardano/Node/Tracing/Tracers/Shutdown.hs

@@ -14,7 +14,7 @@ module Cardano.Node.Tracing.Tracers.Shutdown
 
 import           Cardano.Logging
 import           Cardano.Node.Handlers.Shutdown
-import           Data.Aeson (ToJSON (..), Value (..), (.=))
+import           Data.Aeson (Value (..), (.=))
 import           Data.Monoid (mconcat, (<>))
 import           Data.Text (Text, pack)
 import           Prelude (show)
@@ -29,15 +29,15 @@ namesForShutdown = \case
   AbnormalShutdown{}          -> ["AbnormalShutdown"]
   ShutdownUnexpectedInput{}   -> ["ShutdownUnexpectedInput"]
   RequestingShutdown{}        -> ["RequestingShutdown"]
-  ShutdownArmedAtSlot{}       -> ["ShutdownArmedAtSlot"]
+  ShutdownArmedAt{}           -> ["ShutdownArmedAt"]
 
 severityShutdown :: ShutdownTrace -> SeverityS
 severityShutdown = \case
   ShutdownRequested{}         -> Warning
   AbnormalShutdown{}          -> Error
   ShutdownUnexpectedInput{}   -> Error
   RequestingShutdown{}        -> Warning
-  ShutdownArmedAtSlot{}       -> Warning
+  ShutdownArmedAt{}           -> Warning
 
 ppShutdownTrace :: ShutdownTrace -> Text
 ppShutdownTrace = \case
@@ -46,7 +46,7 @@ ppShutdownTrace = \case
   ShutdownUnexpectedInput text  ->
     "Received shutdown request but found unexpected input in --shutdown-ipc FD: " <> text
   RequestingShutdown reason     -> "Ringing the node shutdown doorbell:  " <> reason
-  ShutdownArmedAtSlot slot      -> "Will terminate upon reaching " <> pack (show slot)
+  ShutdownArmedAt lim           -> "Will terminate upon reaching " <> pack (show lim)
 
 instance LogFormatting ShutdownTrace where
   forHuman = ppShutdownTrace
@@ -58,13 +58,13 @@ instance LogFormatting ShutdownTrace where
           mconcat [ "kind"   .= String "AbnormalShutdown" ]
     ShutdownUnexpectedInput text ->
           mconcat [ "kind"   .= String "AbnormalShutdown"
-                   , "unexpected" .= String text ]
+                  , "unexpected" .= String text ]
     RequestingShutdown reason ->
           mconcat [ "kind"   .= String "RequestingShutdown"
-                   , "reason" .= String reason ]
-    ShutdownArmedAtSlot slot  ->
-          mconcat [ "kind"   .= String "ShutdownArmedAtSlot"
-                   , "slot"   .= toJSON slot ]
+                  , "reason" .= String reason ]
+    ShutdownArmedAt lim ->
+          mconcat [ "kind"   .= String "ShutdownArmedAt"
+                  , "limit"  .= lim ]
 
 docShutdown :: Documented ShutdownTrace
 docShutdown = addDocumentedNamespace  [] docShutdown'
@@ -88,7 +88,7 @@ docShutdown' = Documented
       []
       "Ringing the node shutdown doorbell"
   , DocMsg
-      ["ShutdownArmedAtSlot"]
+      ["ShutdownArmedAt"]
       []
-      "Setting up node shutdown at given slot."
+      "Setting up node shutdown at given slot / block."
   ]

cardano-node/src/Cardano/Node/Tracing/Tracers/Startup.hs

@@ -130,6 +130,7 @@ namesStartupInfo = \case
   StartupSocketConfigError {}               -> ["StartupSocketConfigError"]
   StartupDBValidation {}                    -> ["StartupDBValidation"]
   NetworkConfigUpdate {}                    -> ["NetworkConfigUpdate"]
+  NetworkConfigUpdateUnsupported            -> ["NetworkConfigUpdateUnsupported"]
   NetworkConfigUpdateError {}               -> ["NetworkConfigUpdateError"]
   NetworkConfig {}                          -> ["NetworkConfig"]
   P2PWarning {}                             -> ["P2PWarning"]
@@ -198,7 +199,10 @@ instance ( Show (BlockNodeToNodeVersion blk)
                , "message" .= String "start db validation" ]
   forMachine _dtal NetworkConfigUpdate =
       mconcat [ "kind" .= String "NetworkConfigUpdate"
-               , "message" .= String "ntework configuration update" ]
+               , "message" .= String "network configuration update" ]
+  forMachine _dtal NetworkConfigUpdateUnsupported =
+      mconcat [ "kind" .= String "NetworkConfigUpdate"
+              , "message" .= String "network topology reconfiguration is not supported in non-p2p mode" ]
   forMachine _dtal (NetworkConfigUpdateError err) =
       mconcat [ "kind" .= String "NetworkConfigUpdateError"
                , "error" .= String err ]
@@ -299,6 +303,8 @@ ppStartupInfoTrace (StartupSocketConfigError err) =
 ppStartupInfoTrace StartupDBValidation = "Performing DB validation"
 
 ppStartupInfoTrace NetworkConfigUpdate = "Performing topology configuration update"
+ppStartupInfoTrace NetworkConfigUpdateUnsupported =
+  "Network topology reconfiguration is not supported in non-p2p mode"
 ppStartupInfoTrace (NetworkConfigUpdateError err) = err
 ppStartupInfoTrace (NetworkConfig localRoots publicRoots useLedgerAfter) =
     pack

cardano-node/src/Cardano/Tracing/OrphanInstances/Common.hs

@@ -58,7 +58,7 @@ import           Cardano.BM.Stats
 import           Cardano.BM.Tracing (HasPrivacyAnnotation (..), HasSeverityAnnotation (..),
                    Severity (..), ToObject (..), Tracer (..), TracingVerbosity (..),
                    Transformable (..))
-import           Cardano.Slotting.Block (BlockNo (..))
+import           Cardano.Node.Handlers.Shutdown ()
 import           Ouroboros.Consensus.Byron.Ledger.Block (ByronHash (..))
 import           Ouroboros.Consensus.HardFork.Combinator (OneEraHash (..))
 import           Ouroboros.Network.Block (HeaderHash, Tip (..))
@@ -102,7 +102,6 @@ instance ToJSON (OneEraHash xs) where
     toJSON . Text.decodeLatin1 . B16.encode . SBS.fromShort $ bs
 
 deriving newtype instance ToJSON ByronHash
-deriving newtype instance ToJSON BlockNo
 
 instance HasPrivacyAnnotation  ResourceStats
 instance HasSeverityAnnotation ResourceStats where

cardano-node/src/Cardano/Tracing/Startup.hs

@@ -27,6 +27,7 @@ import           Ouroboros.Consensus.Node.NetworkProtocolVersion
 instance HasSeverityAnnotation (StartupTrace blk) where
     getSeverityAnnotation (StartupSocketConfigError _) = Error
     getSeverityAnnotation (NetworkConfigUpdateError _) = Error
+    getSeverityAnnotation NetworkConfigUpdateUnsupported = Warning
     getSeverityAnnotation P2PWarning = Warning
     getSeverityAnnotation P2PWarningDevelopementNetworkProtocols = Warning
     getSeverityAnnotation WarningDevelopmentNetworkProtocols {} = Warning

cardano-node/test/Test/Cardano/Node/POM.hs

@@ -17,7 +17,7 @@ import           Cardano.Tracing.Config (PartialTraceOptions (..), defaultPartia
                    partialTraceSelectionToEither)
 import qualified Ouroboros.Consensus.Node as Consensus (NetworkP2PMode (..))
 import           Ouroboros.Consensus.Storage.LedgerDB.DiskPolicy (SnapshotInterval (..))
-import           Ouroboros.Network.Block (MaxSlotNo (..), SlotNo (..))
+import           Ouroboros.Network.Block (SlotNo (..))
 import           Ouroboros.Network.NodeToNode (AcceptedConnectionsLimit (..),
                    DiffusionMode (InitiatorAndResponderDiffusionMode))
 
@@ -84,7 +84,7 @@ testPartialCliConfig :: PartialNodeConfiguration
 testPartialCliConfig =
   PartialNodeConfiguration
     { pncSocketConfig = Last . Just $ SocketConfig mempty mempty mempty mempty
-    , pncShutdownConfig = Last . Just $ ShutdownConfig Nothing (Just . MaxSlotNo $ SlotNo 42)
+    , pncShutdownConfig = Last . Just $ ShutdownConfig Nothing (Just . ASlot $ SlotNo 42)
     , pncConfigFile   = mempty
     , pncTopologyFile = mempty
     , pncDatabaseFile = mempty
@@ -117,7 +117,7 @@ eExpectedConfig = do
                     (return $ PartialTracingOnLegacy defaultPartialTraceConfiguration)
   return $ NodeConfiguration
     { ncSocketConfig = SocketConfig mempty mempty mempty mempty
-    , ncShutdownConfig = ShutdownConfig Nothing (Just . MaxSlotNo $ SlotNo 42)
+    , ncShutdownConfig = ShutdownConfig Nothing (Just . ASlot $ SlotNo 42)
     , ncConfigFile = ConfigYamlFilePath "configuration/cardano/mainnet-config.json"
     , ncTopologyFile = TopologyFile "configuration/cardano/mainnet-topology.json"
     , ncDatabaseFile = DbFile "mainnet/db/"