{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}

module Cardano.Node.Tracing.Tracers.ForgingThreadStats
    ( ForgingStats (..)
    , ForgeThreadStats (..)
    , forgeThreadStats
  ) where

import           Cardano.Logging

import           Control.Concurrent (ThreadId, myThreadId)
import           Control.Monad.IO.Class (MonadIO (..))
import           Data.Aeson (Value (..), (.=))
import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import           Data.Maybe (fromMaybe)

import           Cardano.Node.Tracing.Tracers.StartLeadershipCheck (ForgeTracerType)
import           Cardano.Slotting.Slot (SlotNo (..))
import           Ouroboros.Consensus.Node.Tracers
import qualified Ouroboros.Consensus.Node.Tracers as Consensus
import           Ouroboros.Consensus.Shelley.Node ()

--------------------------------------------------------------------------------
-- ForgeThreadStats Tracer
--------------------------------------------------------------------------------

-- | Per-forging-thread statistics.
data ForgeThreadStats = ForgeThreadStats
  { ForgeThreadStats -> Int
ftsNodeCannotForgeNum :: !Int
  , ForgeThreadStats -> Int
ftsNodeIsLeaderNum    :: !Int
  , ForgeThreadStats -> Int
ftsBlocksForgedNum    :: !Int
  , ForgeThreadStats -> Int
ftsSlotsMissedNum     :: !Int
    -- ^ Potentially missed slots.  Note that this is not the same as the number
    -- of missed blocks, since this includes all occurrences of not reaching a
    -- leadership check decision, whether or not leadership was possible or not.
    --
    -- Also note that when the aggregate total for this metric is reported in the
    -- multi-pool case, it can be much larger than the actual number of slots
    -- occurring since node start, for it is a sum total for all threads.
  , ForgeThreadStats -> Int
ftsLastSlot           :: !Int
  }

instance LogFormatting ForgeThreadStats where
  forHuman :: ForgeThreadStats -> Text
forHuman ForgeThreadStats {Int
ftsLastSlot :: Int
ftsSlotsMissedNum :: Int
ftsBlocksForgedNum :: Int
ftsNodeIsLeaderNum :: Int
ftsNodeCannotForgeNum :: Int
ftsLastSlot :: ForgeThreadStats -> Int
ftsSlotsMissedNum :: ForgeThreadStats -> Int
ftsBlocksForgedNum :: ForgeThreadStats -> Int
ftsNodeIsLeaderNum :: ForgeThreadStats -> Int
ftsNodeCannotForgeNum :: ForgeThreadStats -> Int
..} =
    Text
"Node cannot forge "  forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showT Int
ftsNodeCannotForgeNum
    forall a. Semigroup a => a -> a -> a
<> Text
" node is leader " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showT Int
ftsNodeIsLeaderNum
    forall a. Semigroup a => a -> a -> a
<> Text
" blocks forged "  forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showT Int
ftsBlocksForgedNum
    forall a. Semigroup a => a -> a -> a
<> Text
" slots missed "   forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showT Int
ftsSlotsMissedNum
    forall a. Semigroup a => a -> a -> a
<> Text
" last slot "      forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showT Int
ftsLastSlot
  forMachine :: DetailLevel -> ForgeThreadStats -> Object
forMachine DetailLevel
_dtal ForgeThreadStats {Int
ftsLastSlot :: Int
ftsSlotsMissedNum :: Int
ftsBlocksForgedNum :: Int
ftsNodeIsLeaderNum :: Int
ftsNodeCannotForgeNum :: Int
ftsLastSlot :: ForgeThreadStats -> Int
ftsSlotsMissedNum :: ForgeThreadStats -> Int
ftsBlocksForgedNum :: ForgeThreadStats -> Int
ftsNodeIsLeaderNum :: ForgeThreadStats -> Int
ftsNodeCannotForgeNum :: ForgeThreadStats -> Int
..} =
    forall a. Monoid a => [a] -> a
mconcat [ Key
"kind" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String Text
"ForgeThreadStats"
             , Key
"nodeCannotForgeNum" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String (forall a. Show a => a -> Text
showT Int
ftsNodeCannotForgeNum)
             , Key
"nodeIsLeaderNum"    forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String (forall a. Show a => a -> Text
showT Int
ftsNodeIsLeaderNum)
             , Key
"blocksForgedNum"    forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String (forall a. Show a => a -> Text
showT Int
ftsBlocksForgedNum)
             , Key
"slotsMissed"        forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String (forall a. Show a => a -> Text
showT Int
ftsSlotsMissedNum)
             , Key
"lastSlot"           forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String (forall a. Show a => a -> Text
showT Int
ftsLastSlot)
             ]
  asMetrics :: ForgeThreadStats -> [Metric]
asMetrics ForgeThreadStats {Int
ftsLastSlot :: Int
ftsSlotsMissedNum :: Int
ftsBlocksForgedNum :: Int
ftsNodeIsLeaderNum :: Int
ftsNodeCannotForgeNum :: Int
ftsLastSlot :: ForgeThreadStats -> Int
ftsSlotsMissedNum :: ForgeThreadStats -> Int
ftsBlocksForgedNum :: ForgeThreadStats -> Int
ftsNodeIsLeaderNum :: ForgeThreadStats -> Int
ftsNodeCannotForgeNum :: ForgeThreadStats -> Int
..} =
    [ Text -> Integer -> Metric
IntM Text
"Forge.NodeCannotForgeNum" (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
ftsNodeCannotForgeNum)
    , Text -> Integer -> Metric
IntM Text
"Forge.NodeIsLeaderNum"    (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
ftsNodeIsLeaderNum)
    , Text -> Integer -> Metric
IntM Text
"Forge.BlocksForgedNum"    (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
ftsBlocksForgedNum)
    , Text -> Integer -> Metric
IntM Text
"Forge.SlotsMissed"        (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
ftsSlotsMissedNum)
    , Text -> Integer -> Metric
IntM Text
"Forge.LastSlot"           (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
ftsLastSlot)
    ]


emptyForgeThreadStats :: ForgeThreadStats
emptyForgeThreadStats :: ForgeThreadStats
emptyForgeThreadStats = Int -> Int -> Int -> Int -> Int -> ForgeThreadStats
ForgeThreadStats Int
0 Int
0 Int
0 Int
0 Int
0


--------------------------------------------------------------------------------
-- ForgingStats Tracer
--------------------------------------------------------------------------------

-- | This structure stores counters of blockchain-related events,
--   per individual thread in fsStats.
data ForgingStats
  = ForgingStats
  { ForgingStats -> Map ThreadId ForgeThreadStats
fsStats              :: !(Map ThreadId ForgeThreadStats)
  , ForgingStats -> Int
fsNodeCannotForgeNum :: !Int
  , ForgingStats -> Int
fsNodeIsLeaderNum    :: !Int
  , ForgingStats -> Int
fsBlocksForgedNum    :: !Int
  , ForgingStats -> Int
fsSlotsMissedNum     :: !Int
  }

instance LogFormatting ForgingStats where
  forHuman :: ForgingStats -> Text
forHuman ForgingStats {Int
Map ThreadId ForgeThreadStats
fsSlotsMissedNum :: Int
fsBlocksForgedNum :: Int
fsNodeIsLeaderNum :: Int
fsNodeCannotForgeNum :: Int
fsStats :: Map ThreadId ForgeThreadStats
fsSlotsMissedNum :: ForgingStats -> Int
fsBlocksForgedNum :: ForgingStats -> Int
fsNodeIsLeaderNum :: ForgingStats -> Int
fsNodeCannotForgeNum :: ForgingStats -> Int
fsStats :: ForgingStats -> Map ThreadId ForgeThreadStats
..} =
    Text
"Node cannot forge "  forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showT Int
fsNodeCannotForgeNum
    forall a. Semigroup a => a -> a -> a
<> Text
" node is leader " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showT Int
fsNodeIsLeaderNum
    forall a. Semigroup a => a -> a -> a
<> Text
" blocks forged "  forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showT Int
fsBlocksForgedNum
    forall a. Semigroup a => a -> a -> a
<> Text
" slots missed "   forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showT Int
fsSlotsMissedNum
  forMachine :: DetailLevel -> ForgingStats -> Object
forMachine DetailLevel
_dtal ForgingStats {Int
Map ThreadId ForgeThreadStats
fsSlotsMissedNum :: Int
fsBlocksForgedNum :: Int
fsNodeIsLeaderNum :: Int
fsNodeCannotForgeNum :: Int
fsStats :: Map ThreadId ForgeThreadStats
fsSlotsMissedNum :: ForgingStats -> Int
fsBlocksForgedNum :: ForgingStats -> Int
fsNodeIsLeaderNum :: ForgingStats -> Int
fsNodeCannotForgeNum :: ForgingStats -> Int
fsStats :: ForgingStats -> Map ThreadId ForgeThreadStats
..} =
    forall a. Monoid a => [a] -> a
mconcat [ Key
"kind" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String Text
"ForgingStats"
             , Key
"nodeCannotForgeNum" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String (forall a. Show a => a -> Text
showT Int
fsNodeCannotForgeNum)
             , Key
"nodeIsLeaderNum"    forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String (forall a. Show a => a -> Text
showT Int
fsNodeIsLeaderNum)
             , Key
"blocksForgedNum"    forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String (forall a. Show a => a -> Text
showT Int
fsBlocksForgedNum)
             , Key
"slotsMissed"        forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String (forall a. Show a => a -> Text
showT Int
fsSlotsMissedNum)
             ]
  asMetrics :: ForgingStats -> [Metric]
asMetrics ForgingStats {Int
Map ThreadId ForgeThreadStats
fsSlotsMissedNum :: Int
fsBlocksForgedNum :: Int
fsNodeIsLeaderNum :: Int
fsNodeCannotForgeNum :: Int
fsStats :: Map ThreadId ForgeThreadStats
fsSlotsMissedNum :: ForgingStats -> Int
fsBlocksForgedNum :: ForgingStats -> Int
fsNodeIsLeaderNum :: ForgingStats -> Int
fsNodeCannotForgeNum :: ForgingStats -> Int
fsStats :: ForgingStats -> Map ThreadId ForgeThreadStats
..} =
    [ Text -> Integer -> Metric
IntM Text
"Forge.NodeCannotForgeNum" (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
fsNodeCannotForgeNum)
    , Text -> Integer -> Metric
IntM Text
"Forge.NodeIsLeaderNum"    (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
fsNodeIsLeaderNum)
    , Text -> Integer -> Metric
IntM Text
"Forge.BlocksForgedNum"    (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
fsBlocksForgedNum)
    , Text -> Integer -> Metric
IntM Text
"Forge.SlotsMissed"        (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
fsSlotsMissedNum)
    ]

instance MetaTrace ForgingStats where
    namespaceFor :: ForgingStats -> Namespace ForgingStats
namespaceFor ForgingStats {} = forall a. [Text] -> [Text] -> Namespace a
Namespace [] [Text
"ForgingStats"]

    severityFor :: Namespace ForgingStats -> Maybe ForgingStats -> Maybe SeverityS
severityFor Namespace ForgingStats
_ Maybe ForgingStats
_ = forall a. a -> Maybe a
Just SeverityS
Info

    documentFor :: Namespace ForgingStats -> Maybe Text
documentFor Namespace ForgingStats
_ = forall a. a -> Maybe a
Just
      Text
"nodeCannotForgeNum shows how many times this node could not forge.\
      \\nnodeIsLeaderNum shows how many times this node was leader.\
      \\nblocksForgedNum shows how many blocks did forge in this node.\
      \\nslotsMissed shows how many slots were missed in this node."

    metricsDocFor :: Namespace ForgingStats -> [(Text, Text)]
metricsDocFor Namespace ForgingStats
_ =
      [(Text
"Forge.NodeCannotForgeNum",
        Text
"How many times this node could not forge?")
      ,(Text
"Forge.NodeIsLeaderNum",
        Text
"How many times this node was leader?")
      ,(Text
"Forge.BlocksForgedNum",
        Text
"How many blocks did forge in this node?")
      ,(Text
"Forge.SlotsMissed",
        Text
"How many slots were missed in this node?")
      ,(Text
"Forge.LastSlot",
        Text
"")
      ]

    allNamespaces :: [Namespace ForgingStats]
allNamespaces = [forall a. [Text] -> [Text] -> Namespace a
Namespace [] [Text
"ForgingStats"]]


emptyForgingStats :: ForgingStats
emptyForgingStats :: ForgingStats
emptyForgingStats = Map ThreadId ForgeThreadStats
-> Int -> Int -> Int -> Int -> ForgingStats
ForgingStats forall a. Monoid a => a
mempty Int
0 Int
0 Int
0 Int
0

forgeThreadStats :: Trace IO ForgingStats
  -> IO (Trace IO (ForgeTracerType blk))
forgeThreadStats :: forall blk.
Trace IO ForgingStats -> IO (Trace IO (ForgeTracerType blk))
forgeThreadStats Trace IO ForgingStats
tr =
  let tr' :: Trace IO (Folding a ForgingStats)
tr' = forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap forall a b. Folding a b -> b
unfold Trace IO ForgingStats
tr
  in forall a acc (m :: * -> *).
MonadUnliftIO m =>
(acc -> LoggingContext -> a -> m acc)
-> acc -> (a -> Bool) -> Trace m (Folding a acc) -> m (Trace m a)
foldMCondTraceM forall (m :: * -> *) blk.
MonadIO m =>
ForgingStats
-> LoggingContext -> ForgeTracerType blk -> m ForgingStats
calculateThreadStats ForgingStats
emptyForgingStats
      (\case
          Left Consensus.TraceStartLeadershipCheck{} -> Bool
True
          Left TraceForgeEvent blk
_ -> Bool
False
          Right TraceStartLeadershipCheckPlus
_  -> Bool
True
          )
      forall {a}. Trace IO (Folding a ForgingStats)
tr'

calculateThreadStats :: MonadIO m
  => ForgingStats
  -> LoggingContext
  -> ForgeTracerType blk
  -> m ForgingStats
calculateThreadStats :: forall (m :: * -> *) blk.
MonadIO m =>
ForgingStats
-> LoggingContext -> ForgeTracerType blk -> m ForgingStats
calculateThreadStats ForgingStats
stats LoggingContext
_context
    (Left TraceNodeCannotForge {}) = do
      forall (m :: * -> *) a.
MonadIO m =>
ForgingStats
-> (ForgeThreadStats -> (ForgeThreadStats, Maybe a))
-> (ForgingStats -> Maybe a -> ForgingStats)
-> m ForgingStats
mapThreadStats
        ForgingStats
stats
        (\ForgeThreadStats
fts -> (ForgeThreadStats
fts { ftsNodeCannotForgeNum :: Int
ftsNodeCannotForgeNum = ForgeThreadStats -> Int
ftsNodeCannotForgeNum ForgeThreadStats
fts forall a. Num a => a -> a -> a
+ Int
1}
                      , forall a. Maybe a
Nothing))
        (\ForgingStats
fs Maybe Any
_ ->  (ForgingStats
fs  { fsNodeCannotForgeNum :: Int
fsNodeCannotForgeNum  = ForgingStats -> Int
fsNodeCannotForgeNum ForgingStats
fs forall a. Num a => a -> a -> a
+ Int
1 }))
calculateThreadStats ForgingStats
stats LoggingContext
_context
    (Left (TraceNodeIsLeader (SlotNo Word64
slot'))) = do
      let slot :: Int
slot = forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
slot'
      forall (m :: * -> *) a.
MonadIO m =>
ForgingStats
-> (ForgeThreadStats -> (ForgeThreadStats, Maybe a))
-> (ForgingStats -> Maybe a -> ForgingStats)
-> m ForgingStats
mapThreadStats
        ForgingStats
stats
        (\ForgeThreadStats
fts -> (ForgeThreadStats
fts { ftsNodeIsLeaderNum :: Int
ftsNodeIsLeaderNum = ForgeThreadStats -> Int
ftsNodeIsLeaderNum ForgeThreadStats
fts forall a. Num a => a -> a -> a
+ Int
1
                   , ftsLastSlot :: Int
ftsLastSlot = Int
slot}, forall a. Maybe a
Nothing))
        (\ForgingStats
fs Maybe Any
_ ->  (ForgingStats
fs  { fsNodeIsLeaderNum :: Int
fsNodeIsLeaderNum  = ForgingStats -> Int
fsNodeIsLeaderNum ForgingStats
fs forall a. Num a => a -> a -> a
+ Int
1 }))
calculateThreadStats ForgingStats
stats LoggingContext
_context
    (Left TraceForgedBlock {}) = do
      forall (m :: * -> *) a.
MonadIO m =>
ForgingStats
-> (ForgeThreadStats -> (ForgeThreadStats, Maybe a))
-> (ForgingStats -> Maybe a -> ForgingStats)
-> m ForgingStats
mapThreadStats
        ForgingStats
stats
        (\ForgeThreadStats
fts -> (ForgeThreadStats
fts { ftsBlocksForgedNum :: Int
ftsBlocksForgedNum = ForgeThreadStats -> Int
ftsBlocksForgedNum ForgeThreadStats
fts forall a. Num a => a -> a -> a
+ Int
1}
                      , forall a. Maybe a
Nothing))
        (\ForgingStats
fs Maybe Any
_ ->  (ForgingStats
fs  { fsBlocksForgedNum :: Int
fsBlocksForgedNum  = ForgingStats -> Int
fsBlocksForgedNum ForgingStats
fs forall a. Num a => a -> a -> a
+ Int
1 }))
calculateThreadStats ForgingStats
stats LoggingContext
_context
    (Left (TraceNodeNotLeader (SlotNo Word64
slot'))) = do
      let slot :: Int
slot = forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
slot'
      forall (m :: * -> *) a.
MonadIO m =>
ForgingStats
-> (ForgeThreadStats -> (ForgeThreadStats, Maybe a))
-> (ForgingStats -> Maybe a -> ForgingStats)
-> m ForgingStats
mapThreadStats
        ForgingStats
stats
        (\ForgeThreadStats
fts ->
          if ForgeThreadStats -> Int
ftsLastSlot ForgeThreadStats
fts forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
|| forall a. Enum a => a -> a
succ (ForgeThreadStats -> Int
ftsLastSlot ForgeThreadStats
fts) forall a. Eq a => a -> a -> Bool
== Int
slot
            then (ForgeThreadStats
fts { ftsLastSlot :: Int
ftsLastSlot = Int
slot }, forall a. Maybe a
Nothing)
            else
              let missed :: Int
missed = (Int
slot forall a. Num a => a -> a -> a
- ForgeThreadStats -> Int
ftsLastSlot ForgeThreadStats
fts)
              in (ForgeThreadStats
fts { ftsLastSlot :: Int
ftsLastSlot = Int
slot
                      , ftsSlotsMissedNum :: Int
ftsSlotsMissedNum = ForgeThreadStats -> Int
ftsSlotsMissedNum ForgeThreadStats
fts forall a. Num a => a -> a -> a
+ Int
missed}
                 , forall a. a -> Maybe a
Just Int
missed))
        (\ForgingStats
fs Maybe Int
mbMissed -> case Maybe Int
mbMissed of
                            Maybe Int
Nothing -> ForgingStats
fs
                            Just Int
missed -> (ForgingStats
fs { fsSlotsMissedNum :: Int
fsSlotsMissedNum =
                              ForgingStats -> Int
fsSlotsMissedNum ForgingStats
fs forall a. Num a => a -> a -> a
+ Int
missed}))
calculateThreadStats ForgingStats
stats LoggingContext
_context Either (TraceForgeEvent blk) TraceStartLeadershipCheckPlus
_message = forall (f :: * -> *) a. Applicative f => a -> f a
pure ForgingStats
stats

mapThreadStats ::
     MonadIO m
  => ForgingStats
  -> (ForgeThreadStats -> (ForgeThreadStats, Maybe a))
  -> (ForgingStats -> Maybe a -> ForgingStats)
  -> m ForgingStats
mapThreadStats :: forall (m :: * -> *) a.
MonadIO m =>
ForgingStats
-> (ForgeThreadStats -> (ForgeThreadStats, Maybe a))
-> (ForgingStats -> Maybe a -> ForgingStats)
-> m ForgingStats
mapThreadStats fs :: ForgingStats
fs@ForgingStats { Map ThreadId ForgeThreadStats
fsStats :: Map ThreadId ForgeThreadStats
fsStats :: ForgingStats -> Map ThreadId ForgeThreadStats
fsStats } ForgeThreadStats -> (ForgeThreadStats, Maybe a)
f1 ForgingStats -> Maybe a -> ForgingStats
f2 = do
  ThreadId
tid <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ThreadId
myThreadId
  let threadStats :: ForgeThreadStats
threadStats   =  forall a. a -> Maybe a -> a
fromMaybe ForgeThreadStats
emptyForgeThreadStats (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ThreadId
tid Map ThreadId ForgeThreadStats
fsStats)
      (ForgeThreadStats
newStats, Maybe a
w) = ForgeThreadStats -> (ForgeThreadStats, Maybe a)
f1 ForgeThreadStats
threadStats
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ ForgingStats -> Maybe a -> ForgingStats
f2 (ForgingStats
fs {fsStats :: Map ThreadId ForgeThreadStats
fsStats = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ThreadId
tid ForgeThreadStats
newStats Map ThreadId ForgeThreadStats
fsStats}) Maybe a
w