CAD-2564: trace KES metrics even if the key is expired.

cardano-node/src/Cardano/Node/Protocol/Types.hs

@@ -23,7 +23,7 @@ import qualified Ouroboros.Consensus.Cardano as Consensus (Protocol)
 import           Ouroboros.Consensus.Node.Run (RunNode)
 
 import           Cardano.Tracing.Constraints (TraceConstraints)
-import           Cardano.Tracing.Metrics (HasKESMetricsData)
+import           Cardano.Tracing.Metrics (HasKESMetricsData, HasKESInfo)
 
 data Protocol = ByronProtocol
               | ShelleyProtocol
@@ -51,6 +51,7 @@ instance FromJSON Protocol where
 
 type SomeConsensusProtocolConstraints blk =
      ( HasKESMetricsData blk
+     , HasKESInfo blk
      , RunNode blk
      , TraceConstraints blk
      )

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

@@ -17,6 +17,7 @@ module Cardano.Tracing.Metrics
   , MaxKESEvolutions (..)
   , OperationalCertStartKESPeriod (..)
   , HasKESMetricsData (..)
+  , HasKESInfo (..)
   , ForgingStats (..)
   , ForgeThreadStats (..)
   , mapForgingCurrentThreadStats
@@ -33,17 +34,16 @@ import           Control.Concurrent.STM
 import           Data.IORef (IORef, atomicModifyIORef', newIORef)
 import qualified Data.Map.Strict as Map
 import           Data.SOP.Strict (All, hcmap, K (..), hcollapse)
-import           Ouroboros.Consensus.Block (ForgeStateInfo)
+import           Ouroboros.Consensus.Block (ForgeStateInfo, ForgeStateUpdateError)
 import           Ouroboros.Consensus.Byron.Ledger.Block (ByronBlock)
 import           Ouroboros.Consensus.HardFork.Combinator
-import           Ouroboros.Consensus.TypeFamilyWrappers (WrapForgeStateInfo (..))
-import           Ouroboros.Consensus.HardFork.Combinator.AcrossEras (OneEraForgeStateInfo (..))
+import           Ouroboros.Consensus.TypeFamilyWrappers (WrapForgeStateInfo (..), WrapForgeStateUpdateError (..))
+import           Ouroboros.Consensus.HardFork.Combinator.AcrossEras (OneEraForgeStateInfo (..), OneEraForgeStateUpdateError (..))
 import           Ouroboros.Consensus.Shelley.Ledger.Block (ShelleyBlock)
 import           Ouroboros.Consensus.Shelley.Node ()
 import qualified Ouroboros.Consensus.Shelley.Protocol.HotKey as HotKey
 import           Shelley.Spec.Ledger.OCert (KESPeriod (..))
 
-
 -- | KES-related data to be traced as metrics.
 data KESMetricsData
   = NoKESMetricsData
@@ -104,6 +104,27 @@ instance All HasKESMetricsData xs => HasKESMetricsData (HardForkBlock xs) where
              -> K KESMetricsData blk
       getOne = K . getKESMetricsData (Proxy @blk) . unwrapForgeStateInfo
 
+class HasKESInfo blk where
+  getKESInfo :: Proxy blk -> ForgeStateUpdateError blk -> Maybe HotKey.KESInfo
+  getKESInfo _ _ = Nothing
+
+instance HasKESInfo (ShelleyBlock era) where
+  getKESInfo _ (HotKey.KESCouldNotEvolve ki _) = Just ki
+  getKESInfo _ (HotKey.KESKeyAlreadyPoisoned ki _) = Just ki
+
+instance HasKESInfo ByronBlock
+
+instance All HasKESInfo xs => HasKESInfo (HardForkBlock xs) where
+  getKESInfo _ =
+      hcollapse
+    . hcmap (Proxy @HasKESInfo) getOne
+    . getOneEraForgeStateUpdateError
+   where
+    getOne :: forall blk. HasKESInfo blk
+           => WrapForgeStateUpdateError blk
+           -> K (Maybe HotKey.KESInfo) blk
+    getOne = K . getKESInfo (Proxy @blk) . unwrapForgeStateUpdateError
+
 -- | This structure stores counters of blockchain-related events,
 --   per individual forge thread.
 --   These counters are driven by traces.

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

@@ -71,6 +71,7 @@ import qualified Ouroboros.Consensus.Network.NodeToNode as NodeToNode
 import qualified Ouroboros.Consensus.Node.Run as Consensus (RunNode)
 import qualified Ouroboros.Consensus.Node.Tracers as Consensus
 import           Ouroboros.Consensus.Protocol.Abstract (ValidationErr)
+import qualified Ouroboros.Consensus.Shelley.Protocol.HotKey as HotKey
 
 import qualified Ouroboros.Network.AnchoredFragment as AF
 import           Ouroboros.Network.Block (BlockNo (..), HasHeader (..), Point, StandardHash,
@@ -106,6 +107,8 @@ import qualified Ouroboros.Network.Diffusion as ND
 import qualified Cardano.Node.STM as STM
 import qualified Control.Concurrent.STM as STM
 
+import           Shelley.Spec.Ledger.OCert (KESPeriod (..))
+
 {- HLINT ignore "Redundant bracket" -}
 {- HLINT ignore "Use record patterns" -}
 
@@ -272,6 +275,7 @@ mkTracers
   :: forall peer localPeer blk.
      ( Consensus.RunNode blk
      , HasKESMetricsData blk
+     , HasKESInfo blk
      , TraceConstraints blk
      , Show peer, Eq peer
      , Show localPeer
@@ -492,6 +496,7 @@ mkConsensusTracers
      , ToObject (ForgeStateUpdateError blk)
      , Consensus.RunNode blk
      , HasKESMetricsData blk
+     , HasKESInfo blk
      , Show (Header blk)
      )
   => Maybe EKGDirect
@@ -713,12 +718,14 @@ teeForge' tr =
           LogValue "adoptedSlotLast" $ PureI $ fromIntegral $ unSlotNo slot
 
 forgeTracer
-  :: ( Consensus.RunNode blk
+  :: forall blk.
+     ( Consensus.RunNode blk
      , ToObject (CannotForge blk)
      , ToObject (LedgerErr (LedgerState blk))
      , ToObject (OtherHeaderEnvelopeError blk)
      , ToObject (ValidationErr (BlockProtocol blk))
      , ToObject (ForgeStateUpdateError blk)
+     , HasKESInfo blk
      )
   => TracingVerbosity
   -> Trace IO Text
@@ -734,6 +741,29 @@ forgeTracer verb tr forgeTracers fStats =
     traceWith (annotateSeverity
                  $ teeForge forgeTracers verb
                  $ appendName "Forge" tr) tlcev
+    traceKESInfoIfKESExpired ev
+ where
+  traceKESInfoIfKESExpired ev =
+    case ev of
+      Consensus.TraceForgeStateUpdateError _ reason ->
+        -- KES-key cannot be evolved, but anyway trace KES-values.
+        case getKESInfo (Proxy @blk) reason of
+          Nothing -> pure ()
+          Just kesInfo -> do
+            let logValues :: [LOContent a]
+                logValues =
+                  [ LogValue "operationalCertificateStartKESPeriod"
+                      $ PureI . fromIntegral . unKESPeriod . HotKey.kesStartPeriod $ kesInfo
+                  , LogValue "operationalCertificateExpiryKESPeriod"
+                      $ PureI . fromIntegral . unKESPeriod . HotKey.kesEndPeriod $ kesInfo
+                  , LogValue "currentKESPeriod"
+                      $ PureI 0
+                  , LogValue "remainingKESPeriods"
+                      $ PureI 0
+                  ]
+            meta <- mkLOMeta Critical Confidential
+            mapM_ (traceNamedObject (appendName "metrics" tr) . (meta,)) logValues
+      _ -> pure ()
 
 notifyBlockForging
   :: ForgingStats