WIP implementing PerasVoteForging integration

Integrate Peras vote forging in cardano-node

Author: agustinmista

cardano-node/cardano-node.cabal

@@ -81,6 +81,7 @@ library
                         Cardano.Node.Handlers.Shutdown
                         Cardano.Node.Handlers.TopLevel
                         Cardano.Node.Orphans
+                        Cardano.Node.Peras.Trace
                         Cardano.Node.Parsers
                         Cardano.Node.Pretty
                         Cardano.Node.Protocol
@@ -255,6 +256,7 @@ test-suite cardano-node-test
                       , hedgehog-corpus
                       , hedgehog-extras ^>= 0.10
                       , iproute
+                      , io-classes:{io-classes}
                       , mtl
                       , ouroboros-consensus:{ouroboros-consensus, diffusion}
                       , ouroboros-network:{api, framework, ouroboros-network}

cardano-node/src/Cardano/Node/Peras/Trace.hs

@@ -0,0 +1,11 @@
+module Cardano.Node.Peras.Trace
+  ( PerasVoteForgingUpdateResult (..)
+  ) where
+
+data PerasVoteForgingUpdateResult
+  = PerasVoteForgingInstalled
+  | PerasVoteForgingDisabledUnsupported
+  | PerasVoteForgingCleared
+  | PerasVoteForgingRetainedAfterError String
+  | PerasVoteForgingAmbiguousCredentials Int
+  deriving (Eq, Show)

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

@@ -26,6 +26,7 @@ module Cardano.Node.Run
 import           Cardano.Api (File (..), FileDirection (..))
 import           Cardano.Api.Error (displayError)
 import qualified Cardano.Api as Api
+import           Cardano.Ledger.Keys (coerceKeyRole, hashKey)
 import           System.Random (randomIO)
 
 import qualified Cardano.Crypto.Init as Crypto
@@ -48,7 +49,8 @@ import           Cardano.Node.Protocol (ProtocolInstantiationError (..), mkConse
 import           Cardano.Node.Protocol.Byron (ByronProtocolInstantiationError (CredentialsError))
 import           Cardano.Node.Protocol.Cardano (CardanoProtocolInstantiationError (..))
 import           Cardano.Node.Protocol.Shelley (PraosLeaderCredentialsError (..),
-                   ShelleyProtocolInstantiationError (PraosLeaderCredentialsError), readGenesis)
+                    ShelleyProtocolInstantiationError (PraosLeaderCredentialsError), readGenesis)
+import           Cardano.Node.Peras.Trace (PerasVoteForgingUpdateResult (..))
 import           Cardano.Node.Protocol.Types
 import           Cardano.Node.Queries
 import           Cardano.Rpc.Server
@@ -69,7 +71,13 @@ import           Cardano.Slotting.Slot (WithOrigin (..))
 import           Cardano.Logging.Types (LogFormatting, TraceConfig)
 import           Cardano.Logging.Utils (showT)
 
+import           Ouroboros.Consensus.Cardano.Peras (mkCardanoPerasVoteForging)
+import           Ouroboros.Consensus.Committee.Types (PoolId (..))
+import           Ouroboros.Consensus.Peras.Crypto.BLS.Unsafe (unsafePerasBLSPrivateKeyFromEnv)
+import           Ouroboros.Consensus.Protocol.Praos.Common (PraosCanBeLeader (..))
+import qualified Ouroboros.Consensus.Cardano.Node as CardanoConsensus
 import qualified Ouroboros.Consensus.Config as Consensus
+import           Ouroboros.Consensus.Shelley.Node.Common (ProtocolParamsShelleyBased (..), ShelleyLeaderCredentials (..))
 import           Ouroboros.Consensus.Config.SupportsNode (ConfigSupportsNode (..))
 import           Ouroboros.Consensus.Node (SnapshotPolicyArgs (..),
                    NodeDatabasePaths (..), nonImmutableDbPath, RunNodeArgs (..), StdRunNodeArgs (..))
@@ -164,6 +172,7 @@ import           System.Directory (canonicalizePath, createDirectoryIfMissing, d
                    makeAbsolute)
 import           System.Environment (lookupEnv)
 import           System.FilePath (takeDirectory, (</>))
+import           System.IO.Error (isDoesNotExistError)
 import           System.IO (hPutStrLn)
 #ifdef UNIX
 import           System.Posix.Files
@@ -417,8 +426,19 @@ handleSimpleNode blockType runP tracers forgingStateVar nc cmdPc networkMagic on
               -- set the initial block forging
               blockForging <- mkBlockForging (Consensus.kesAgentTracer $ consensusTracers tracers)
 
-              unless (ncStartAsNonProducingNode nc) $
-                setBlockForging nodeKernel blockForging
+              let installedBlockForging =
+                    if ncStartAsNonProducingNode nc then [] else blockForging
+                  blockForgingStatus =
+                    if null installedBlockForging
+                      then BlockForgingDisabled
+                      else BlockForgingEnabled runP
+              setBlockForging nodeKernel installedBlockForging
+
+              updatePerasVoteForging
+                (startupTracer tracers)
+                blockType
+                nodeKernel
+                blockForgingStatus
 
               maybeSpawnOnSlotSyncedShutdownHandler
                 (ncShutdownConfig nc)
@@ -502,6 +522,7 @@ handleSimpleNode blockType runP tracers forgingStateVar nc cmdPc networkMagic on
                                      blockType nc cmdPc networkMagic nodeKernel localRootsVar publicRootsVar useLedgerVar
                                      useBootstrapVar ledgerPeerSnapshotPathVar ledgerPeerSnapshotVar
                                      rpcConfigVar
+                rnNodeKernelHook nodeArgs registry nodeKernel
                 -- populate node kernel access for RPC server
                 (shelleyGenesisHash, shelleyGenesisFile) <- case ncProtocolConfig nc of
                   NodeProtocolConfigurationCardano _ shelleyCfg _ _ _ _ _ ->
@@ -631,7 +652,9 @@ installSigHUPHandler startupTracer kesAgentTracer forgingStateVar blockType nc c
   void $ Signals.installHandler
     Signals.sigHUP
     (Signals.Catch $ do
-      updateBlockForging startupTracer kesAgentTracer forgingStateVar blockType nodeKernel nc
+      blockForgingStatus <-
+        updateBlockForging startupTracer kesAgentTracer forgingStateVar blockType nodeKernel nc
+      updatePerasVoteForging startupTracer blockType nodeKernel blockForgingStatus
       updateTopologyConfiguration startupTracer nc localRootsVar publicRootsVar
                                   useLedgerVar useBootstrapPeersVar ledgerPeerSnapshotPathVar
       void $ updateLedgerPeerSnapshot
@@ -648,14 +671,22 @@ installSigHUPHandler startupTracer kesAgentTracer forgingStateVar blockType nc c
 #endif
 
 
+-- | Whether reloading produced a protocol snapshot and whether block forging
+-- is installed. 'BlockForgingUnchanged' means the reload was rejected and both
+-- the current block and Peras forgers must be preserved.
+data BlockForgingStatus blk
+  = BlockForgingEnabled (Api.ProtocolInfoArgs IO blk)
+  | BlockForgingDisabled
+  | BlockForgingUnchanged
+
 #ifdef UNIX
 updateBlockForging :: Tracer IO (StartupTrace blk)
                    -> Tracer IO KESAgentClientTrace
                    -> ForgingStateVar
                    -> Api.BlockType blk
                    -> NodeKernel IO RemoteAddress (ConnectionId LocalAddress) blk
                    -> NodeConfiguration
-                   -> IO ()
+                   -> IO (BlockForgingStatus blk)
 updateBlockForging startupTracer kesAgentTracer forgingStateVar blockType nodeKernel nc = do
   eitherSomeProtocol <-
     runExceptT $
@@ -669,8 +700,10 @@ updateBlockForging startupTracer kesAgentTracer forgingStateVar blockType nodeKe
           noteForgingState forgingStateVar False
           traceWith startupTracer (BlockForgingUpdate DisabledBlockForging)
           setBlockForging nodeKernel []
-        _NothingOrOtherFileError ->
+          pure BlockForgingDisabled
+        _NothingOrOtherFileError -> do
           traceWith startupTracer (BlockForgingUpdateError err)
+          pure BlockForgingUnchanged
     Right (SomeConsensusProtocol blockType' runP', _) ->
       case Api.reflBlockType blockType blockType' of
         Just Refl -> do
@@ -689,12 +722,15 @@ updateBlockForging startupTracer kesAgentTracer forgingStateVar blockType nodeKe
                                           then EnabledBlockForging
                                           else DisabledBlockForging))
           setBlockForging nodeKernel blockForging
-        Nothing ->
+          pure $ if enabled
+            then BlockForgingEnabled runP'
+            else BlockForgingDisabled
+        Nothing -> do
           traceWith startupTracer
             $ BlockForgingBlockTypeMismatch
                 (Api.SomeBlockType blockType)
                 (Api.SomeBlockType blockType')
-  return ()
+          pure BlockForgingUnchanged
   where
     wasFileRemovedFromScope :: ProtocolInstantiationError
                             -> Maybe (Api.FileError Api.TextEnvelopeError)
@@ -712,7 +748,63 @@ updateBlockForging startupTracer kesAgentTracer forgingStateVar blockType nodeKe
     wasFileRemovedFromScope (ShelleyProtocolInstantiationError _) = Nothing
     wasFileRemovedFromScope (CardanoProtocolInstantiationError _) = Nothing
 
+#endif
+
+updatePerasVoteForging
+  :: forall blk.
+     Tracer IO (StartupTrace blk)
+  -> Api.BlockType blk
+  -> NodeKernel IO RemoteAddress (ConnectionId LocalAddress) blk
+  -> BlockForgingStatus blk
+  -> IO ()
+updatePerasVoteForging startupTracer blockType nodeKernel blockForgingStatus = do
+  case blockForgingStatus of
+    BlockForgingUnchanged ->
+      pure ()
+    BlockForgingDisabled -> do
+      setPerasVoteForging nodeKernel Nothing
+      tracePerasVoteForgingUpdate PerasVoteForgingCleared
+    BlockForgingEnabled args ->
+      updateFromProtocolArgs args
+  where
+    updateFromProtocolArgs args =
+      case blockType of
+        Api.CardanoBlockType ->
+          case poolIdFromProtocolInfoArgs args of
+            Nothing -> do
+              setPerasVoteForging nodeKernel Nothing
+              tracePerasVoteForgingUpdate PerasVoteForgingCleared
+            Just poolId -> do
+              case perasPrivateKey of
+                Left err ->
+                  tracePerasVoteForgingUpdate (PerasVoteForgingRetainedAfterError (show err))
+                Right privateKey -> do
+                  let voteForging = mkCardanoPerasVoteForging poolId privateKey
+                  setPerasVoteForging nodeKernel (Just voteForging)
+                  tracePerasVoteForgingUpdate PerasVoteForgingInstalled
+        _ -> do
+          setPerasVoteForging nodeKernel Nothing
+          tracePerasVoteForgingUpdate PerasVoteForgingDisabledUnsupported
+
+    perasPrivateKey =
+      unsafePerasBLSPrivateKeyFromEnv
+
+    poolIdFromProtocolInfoArgs (Api.ProtocolInfoArgsCardano _ params) =
+      case shelleyBasedLeaderCredentials (CardanoConsensus.shelleyBasedProtocolParams params) of
+        [credential] -> Just (poolIdFromShelleyLeaderCredentials credential)
+        _ -> Nothing
+
+    poolIdFromShelleyLeaderCredentials =
+      PoolId
+        . hashKey
+        . coerceKeyRole
+        . praosCanBeLeaderColdVerKey
+        . shelleyLeaderCredentialsCanBeLeader
+
+    tracePerasVoteForgingUpdate =
+      traceWith startupTracer . PerasVoteForgingUpdate
 
+#ifdef UNIX
 updateTopologyConfiguration :: Tracer IO (StartupTrace blk)
                             -> NodeConfiguration
                             -> StrictTVar IO [(HotValency, WarmValency, Map RelayAccessPoint (LocalRootConfig PeerTrustable))]

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

@@ -27,6 +27,7 @@ import           Cardano.Network.NodeToClient (NodeToClientVersion)
 import           Cardano.Network.NodeToNode (DiffusionMode (..), NodeToNodeVersion, PeerAdvertise)
 import           Cardano.Node.Configuration.POM (NodeConfiguration (..), ncProtocol)
 import           Cardano.Node.Configuration.Socket
+import           Cardano.Node.Peras.Trace (PerasVoteForgingUpdateResult)
 import           Cardano.Node.Protocol (ProtocolInstantiationError)
 import           Cardano.Node.Types (PeerSnapshotFile (..))
 import           Cardano.Rpc.Server.Config (RpcEndpoint (..))
@@ -94,6 +95,9 @@ data StartupTrace blk =
        Api.SomeBlockType -- ^ expected
        Api.SomeBlockType -- ^ provided
 
+  -- | Node-owned Peras vote-forging lifecycle update.
+  | PerasVoteForgingUpdate PerasVoteForgingUpdateResult
+
   -- | Log that the network configuration is being updated.
   --
   | NetworkConfigUpdate

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

@@ -27,6 +27,7 @@ import           Cardano.Network.NodeToNode (DiffusionMode (..))
 import           Cardano.Network.OrphanInstances ()
 import           Cardano.Node.Configuration.POM (NodeConfiguration, ncProtocol)
 import           Cardano.Node.Configuration.Socket
+import           Cardano.Node.Peras.Trace (PerasVoteForgingUpdateResult (..))
 import           Cardano.Node.Startup
 import           Cardano.Node.Types (PeerSnapshotFile (..))
 import           Cardano.Rpc.Server.Config (RpcEndpoint (..))
@@ -212,6 +213,10 @@ instance ( Show (BlockNodeToNodeVersion blk)
               , "expected" .= String (showT expected)
               , "provided" .= String (showT provided)
               ]
+  forMachine _dtal (PerasVoteForgingUpdate outcome) =
+      mconcat [ "kind" .= String "PerasVoteForgingUpdate"
+              , "message" .= String (ppPerasVoteForgingUpdateResult outcome)
+              ]
   forMachine _dtal NetworkConfigUpdate =
       mconcat [ "kind" .= String "NetworkConfigUpdate"
                , "message" .= String "network configuration update" ]
@@ -345,6 +350,8 @@ instance MetaTrace  (StartupTrace blk) where
     Namespace [] ["BlockForgingUpdateError"]
   namespaceFor BlockForgingBlockTypeMismatch {} =
     Namespace [] ["BlockForgingBlockTypeMismatch"]
+  namespaceFor PerasVoteForgingUpdate {} =
+    Namespace [] ["PerasVoteForgingUpdate"]
   namespaceFor NetworkConfigUpdate {}  =
     Namespace [] ["NetworkConfigUpdate"]
   namespaceFor (LedgerPeerSnapshotLoaded {}) =
@@ -411,6 +418,13 @@ instance MetaTrace  (StartupTrace blk) where
   severityFor (Namespace _ ["RpcTlsPrivateKeyPermissive"]) _ = Just Warning
   severityFor (Namespace _ ["BlockForgingUpdateError"]) _ = Just Error
   severityFor (Namespace _ ["BlockForgingBlockTypeMismatch"]) _ = Just Error
+  severityFor (Namespace _ ["PerasVoteForgingUpdate"]) (Just (PerasVoteForgingUpdate outcome)) =
+    Just $ case outcome of
+      PerasVoteForgingDisabledUnsupported -> Warning
+      PerasVoteForgingAmbiguousCredentials _ -> Warning
+      PerasVoteForgingRetainedAfterError _ -> Error
+      PerasVoteForgingInstalled -> Info
+      PerasVoteForgingCleared -> Info
   severityFor (Namespace _ ["MovedTopLevelOption"]) _ = Just Warning
   severityFor (Namespace _ ["LedgerPeerSnapshot"]) _ = Just Notice
   severityFor (Namespace _ ["LedgerPeerSnapshot", "Incompatible"]) _ = Just Warning
@@ -435,6 +449,8 @@ instance MetaTrace  (StartupTrace blk) where
     ""
   documentFor (Namespace [] ["BlockForgingBlockTypeMismatch"]) = Just
     ""
+  documentFor (Namespace [] ["PerasVoteForgingUpdate"]) = Just
+    "Peras vote-forging lifecycle update."
   documentFor (Namespace [] ["RpcConfigUpdate"]) = Just
     ""
   documentFor (Namespace [] ["RpcConfigUpdateError"]) = Just
@@ -521,6 +537,7 @@ instance MetaTrace  (StartupTrace blk) where
     , Namespace [] ["BlockForgingUpdate"]
     , Namespace [] ["BlockForgingUpdateError"]
     , Namespace [] ["BlockForgingBlockTypeMismatch"]
+    , Namespace [] ["PerasVoteForgingUpdate"]
     , Namespace [] ["RpcConfigUpdate"]
     , Namespace [] ["RpcConfigUpdateError"]
     , Namespace [] ["RpcUnsupportedBlockType"]
@@ -559,6 +576,17 @@ nodeToNodeVersionToInt = \case
 
 -- | Pretty print 'StartupInfoTrace'
 --
+ppPerasVoteForgingUpdateResult :: PerasVoteForgingUpdateResult -> Text
+ppPerasVoteForgingUpdateResult = \case
+  PerasVoteForgingInstalled -> "installed Peras vote forging"
+  PerasVoteForgingDisabledUnsupported ->
+    "Peras vote forging disabled: resolved consensus package lacks the vote-forging API"
+  PerasVoteForgingCleared -> "cleared Peras vote forging"
+  PerasVoteForgingRetainedAfterError err ->
+    "retained Peras vote forging after credential load error: " <> pack err
+  PerasVoteForgingAmbiguousCredentials count ->
+    "cleared Peras vote forging: " <> showT count <> " credentials are ambiguous"
+
 ppStartupInfoTrace :: StartupTrace blk -> Text
 ppStartupInfoTrace (StartupInfo addresses
                                 localSocket
@@ -615,6 +643,8 @@ ppStartupInfoTrace (BlockForgingBlockTypeMismatch expected provided) =
     <> showT expected
     <> " provided "
     <> showT provided
+ppStartupInfoTrace (PerasVoteForgingUpdate outcome) =
+  "Peras vote-forging lifecycle: " <> ppPerasVoteForgingUpdateResult outcome
 
 ppStartupInfoTrace NetworkConfigUpdate = "Performing topology configuration update"
 ppStartupInfoTrace NetworkConfigUpdateUnsupported =