{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DisambiguateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE UndecidableInstances #-}

module Cardano.Tracing.Metrics
  ( ForgingStats (..)
  , ForgeThreadStats (..)
  , mapForgingCurrentThreadStats
  , mapForgingCurrentThreadStats_
  , mapForgingStatsTxsProcessed
  , mkForgingStats
  , threadStatsProjection
  ) where

import           Cardano.Prelude hiding (All, (:.:))

import           Control.Concurrent.STM
import           Data.IORef (IORef, atomicModifyIORef', newIORef)
import qualified Data.Map.Strict as Map


-- | This structure stores counters of blockchain-related events,
--   per individual forge thread.
--   These counters are driven by traces.
data ForgingStats
  = ForgingStats
  { ForgingStats -> IORef Int
fsTxsProcessedNum :: !(IORef Int)
    -- ^ Transactions removed from mempool.
  , ForgingStats -> TVar (Map ThreadId (TVar ForgeThreadStats))
fsState           :: !(TVar (Map ThreadId (TVar ForgeThreadStats)))
  , ForgingStats -> TVar Int64
fsBlocksUncoupled :: !(TVar Int64)
    -- ^ Blocks forged since last restart not on the current chain
  }

-- | 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
  }

mkForgingStats :: IO ForgingStats
mkForgingStats :: IO ForgingStats
mkForgingStats =
  IORef Int
-> TVar (Map ThreadId (TVar ForgeThreadStats))
-> TVar Int64
-> ForgingStats
ForgingStats
    (IORef Int
 -> TVar (Map ThreadId (TVar ForgeThreadStats))
 -> TVar Int64
 -> ForgingStats)
-> IO (IORef Int)
-> IO
     (TVar (Map ThreadId (TVar ForgeThreadStats))
      -> TVar Int64 -> ForgingStats)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef Int
0
    IO
  (TVar (Map ThreadId (TVar ForgeThreadStats))
   -> TVar Int64 -> ForgingStats)
-> IO (TVar (Map ThreadId (TVar ForgeThreadStats)))
-> IO (TVar Int64 -> ForgingStats)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Map ThreadId (TVar ForgeThreadStats)
-> IO (TVar (Map ThreadId (TVar ForgeThreadStats)))
forall a. a -> IO (TVar a)
newTVarIO Map ThreadId (TVar ForgeThreadStats)
forall a. Monoid a => a
mempty
    IO (TVar Int64 -> ForgingStats)
-> IO (TVar Int64) -> IO ForgingStats
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int64 -> IO (TVar Int64)
forall a. a -> IO (TVar a)
newTVarIO Int64
0

mapForgingStatsTxsProcessed ::
     ForgingStats
  -> (Int -> Int)
  -> IO Int
mapForgingStatsTxsProcessed :: ForgingStats -> (Int -> Int) -> IO Int
mapForgingStatsTxsProcessed ForgingStats
fs Int -> Int
f =
  IORef Int -> (Int -> (Int, Int)) -> IO Int
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' (ForgingStats -> IORef Int
fsTxsProcessedNum ForgingStats
fs) ((Int -> (Int, Int)) -> IO Int) -> (Int -> (Int, Int)) -> IO Int
forall a b. (a -> b) -> a -> b
$
    \Int
txCount -> (Int -> Int -> (Int, Int)) -> Int -> (Int, Int)
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (,) (Int -> (Int, Int)) -> Int -> (Int, Int)
forall a b. (a -> b) -> a -> b
$ Int -> Int
f Int
txCount

mapForgingCurrentThreadStats ::
     ForgingStats
  -> (ForgeThreadStats -> (ForgeThreadStats, a))
  -> IO a
mapForgingCurrentThreadStats :: ForgingStats -> (ForgeThreadStats -> (ForgeThreadStats, a)) -> IO a
mapForgingCurrentThreadStats ForgingStats { TVar (Map ThreadId (TVar ForgeThreadStats))
fsState :: TVar (Map ThreadId (TVar ForgeThreadStats))
fsState :: ForgingStats -> TVar (Map ThreadId (TVar ForgeThreadStats))
fsState } ForgeThreadStats -> (ForgeThreadStats, a)
f = do
  ThreadId
tid <- IO ThreadId
myThreadId
  Map ThreadId (TVar ForgeThreadStats)
allStats <- TVar (Map ThreadId (TVar ForgeThreadStats))
-> IO (Map ThreadId (TVar ForgeThreadStats))
forall a. TVar a -> IO a
readTVarIO TVar (Map ThreadId (TVar ForgeThreadStats))
fsState
  TVar ForgeThreadStats
varStats <- case ThreadId
-> Map ThreadId (TVar ForgeThreadStats)
-> Maybe (TVar ForgeThreadStats)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ThreadId
tid Map ThreadId (TVar ForgeThreadStats)
allStats of
    Maybe (TVar ForgeThreadStats)
Nothing -> do
      TVar ForgeThreadStats
varStats <- ForgeThreadStats -> IO (TVar ForgeThreadStats)
forall a. a -> IO (TVar a)
newTVarIO (ForgeThreadStats -> IO (TVar ForgeThreadStats))
-> ForgeThreadStats -> IO (TVar ForgeThreadStats)
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int -> Int -> Int -> ForgeThreadStats
ForgeThreadStats Int
0 Int
0 Int
0 Int
0 Int
0
      STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar (Map ThreadId (TVar ForgeThreadStats))
-> (Map ThreadId (TVar ForgeThreadStats)
    -> Map ThreadId (TVar ForgeThreadStats))
-> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (Map ThreadId (TVar ForgeThreadStats))
fsState ((Map ThreadId (TVar ForgeThreadStats)
  -> Map ThreadId (TVar ForgeThreadStats))
 -> STM ())
-> (Map ThreadId (TVar ForgeThreadStats)
    -> Map ThreadId (TVar ForgeThreadStats))
-> STM ()
forall a b. (a -> b) -> a -> b
$ ThreadId
-> TVar ForgeThreadStats
-> Map ThreadId (TVar ForgeThreadStats)
-> Map ThreadId (TVar ForgeThreadStats)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ThreadId
tid TVar ForgeThreadStats
varStats
      TVar ForgeThreadStats -> IO (TVar ForgeThreadStats)
forall (m :: * -> *) a. Monad m => a -> m a
return TVar ForgeThreadStats
varStats
    Just TVar ForgeThreadStats
varStats ->
      TVar ForgeThreadStats -> IO (TVar ForgeThreadStats)
forall (m :: * -> *) a. Monad m => a -> m a
return TVar ForgeThreadStats
varStats
  STM a -> IO a
forall a. STM a -> IO a
atomically (STM a -> IO a) -> STM a -> IO a
forall a b. (a -> b) -> a -> b
$ do
    ForgeThreadStats
stats <- TVar ForgeThreadStats -> STM ForgeThreadStats
forall a. TVar a -> STM a
readTVar TVar ForgeThreadStats
varStats
    let !(!ForgeThreadStats
stats', a
x) = ForgeThreadStats -> (ForgeThreadStats, a)
f ForgeThreadStats
stats
    TVar ForgeThreadStats -> ForgeThreadStats -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar ForgeThreadStats
varStats ForgeThreadStats
stats'
    a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x

mapForgingCurrentThreadStats_ ::
     ForgingStats
  -> (ForgeThreadStats -> ForgeThreadStats)
  -> IO ()
mapForgingCurrentThreadStats_ :: ForgingStats -> (ForgeThreadStats -> ForgeThreadStats) -> IO ()
mapForgingCurrentThreadStats_ ForgingStats
fs ForgeThreadStats -> ForgeThreadStats
f =
  IO () -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ForgingStats
-> (ForgeThreadStats -> (ForgeThreadStats, ())) -> IO ()
forall a.
ForgingStats -> (ForgeThreadStats -> (ForgeThreadStats, a)) -> IO a
mapForgingCurrentThreadStats ForgingStats
fs ((, ()) (ForgeThreadStats -> (ForgeThreadStats, ()))
-> (ForgeThreadStats -> ForgeThreadStats)
-> ForgeThreadStats
-> (ForgeThreadStats, ())
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ForgeThreadStats -> ForgeThreadStats
f)

threadStatsProjection ::
     ForgingStats
  -> (ForgeThreadStats -> a)
  -> IO [a]
threadStatsProjection :: ForgingStats -> (ForgeThreadStats -> a) -> IO [a]
threadStatsProjection ForgingStats
fs ForgeThreadStats -> a
f = STM [a] -> IO [a]
forall a. STM a -> IO a
atomically (STM [a] -> IO [a]) -> STM [a] -> IO [a]
forall a b. (a -> b) -> a -> b
$ do
  Map ThreadId (TVar ForgeThreadStats)
allStats <- TVar (Map ThreadId (TVar ForgeThreadStats))
-> STM (Map ThreadId (TVar ForgeThreadStats))
forall a. TVar a -> STM a
readTVar (ForgingStats -> TVar (Map ThreadId (TVar ForgeThreadStats))
fsState ForgingStats
fs)
  (TVar ForgeThreadStats -> STM a)
-> [TVar ForgeThreadStats] -> STM [a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((ForgeThreadStats -> a) -> STM ForgeThreadStats -> STM a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ForgeThreadStats -> a
f (STM ForgeThreadStats -> STM a)
-> (TVar ForgeThreadStats -> STM ForgeThreadStats)
-> TVar ForgeThreadStats
-> STM a
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. TVar ForgeThreadStats -> STM ForgeThreadStats
forall a. TVar a -> STM a
readTVar) ([TVar ForgeThreadStats] -> STM [a])
-> [TVar ForgeThreadStats] -> STM [a]
forall a b. (a -> b) -> a -> b
$ Map ThreadId (TVar ForgeThreadStats) -> [TVar ForgeThreadStats]
forall k a. Map k a -> [a]
Map.elems Map ThreadId (TVar ForgeThreadStats)
allStats