{-# LANGUAGE RecordWildCards #-}

module Cardano.Node.Tracing.Tracers.BlockReplayProgress
  ( severityReplayBlockStats
  , namesForReplayBlockStats
  , withReplayedBlock
  , docReplayedBlock
  , ReplayBlockStats(..)
  ) where

import           Data.Aeson (Value (String), (.=))
import           Data.Text (pack)

import           Cardano.Logging
import           Cardano.Prelude

import           Ouroboros.Consensus.Block (realPointSlot)
import           Ouroboros.Network.Block (pointSlot, unSlotNo)
import           Ouroboros.Network.Point (withOrigin)

import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB
import qualified Ouroboros.Consensus.Storage.LedgerDB.OnDisk as LedgerDB

data ReplayBlockStats = ReplayBlockStats
  { ReplayBlockStats -> Bool
rpsDisplay      :: Bool
  , ReplayBlockStats -> Double
rpsProgress     :: Double
  , ReplayBlockStats -> Double
rpsLastProgress :: Double
  }

emptyReplayBlockStats :: ReplayBlockStats
emptyReplayBlockStats :: ReplayBlockStats
emptyReplayBlockStats = Bool -> Double -> Double -> ReplayBlockStats
ReplayBlockStats Bool
False Double
0.0 Double
0.0

--------------------------------------------------------------------------------
-- ReplayBlockStats Tracer
--------------------------------------------------------------------------------

namesForReplayBlockStats :: ReplayBlockStats -> Namespace
namesForReplayBlockStats :: ReplayBlockStats -> Namespace
namesForReplayBlockStats ReplayBlockStats
_ = [Text
"LedgerReplay"]

severityReplayBlockStats :: ReplayBlockStats -> SeverityS
severityReplayBlockStats :: ReplayBlockStats -> SeverityS
severityReplayBlockStats ReplayBlockStats
_ = SeverityS
Info

instance LogFormatting ReplayBlockStats where
  forMachine :: DetailLevel -> ReplayBlockStats -> Object
forMachine DetailLevel
_dtal ReplayBlockStats {Bool
Double
rpsLastProgress :: Double
rpsProgress :: Double
rpsDisplay :: Bool
rpsLastProgress :: ReplayBlockStats -> Double
rpsProgress :: ReplayBlockStats -> Double
rpsDisplay :: ReplayBlockStats -> Bool
..} =
    [Object] -> Object
forall a. Monoid a => [a] -> a
mconcat
      [ Key
"kind" Key -> Value -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String Text
"ReplayBlockStats"
      , Key
"progress" Key -> Value -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String (String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Double -> String
forall a b. (Show a, ConvertText String b) => a -> b
show Double
rpsProgress)
      ]
  forHuman :: ReplayBlockStats -> Text
forHuman ReplayBlockStats {Bool
Double
rpsLastProgress :: Double
rpsProgress :: Double
rpsDisplay :: Bool
rpsLastProgress :: ReplayBlockStats -> Double
rpsProgress :: ReplayBlockStats -> Double
rpsDisplay :: ReplayBlockStats -> Bool
..} = Text
"Block replay progress " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Double -> Text
forall a b. (Show a, ConvertText String b) => a -> b
show Double
rpsProgress Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"%"
  asMetrics :: ReplayBlockStats -> [Metric]
asMetrics ReplayBlockStats {Bool
Double
rpsLastProgress :: Double
rpsProgress :: Double
rpsDisplay :: Bool
rpsLastProgress :: ReplayBlockStats -> Double
rpsProgress :: ReplayBlockStats -> Double
rpsDisplay :: ReplayBlockStats -> Bool
..} =
     [Text -> Double -> Metric
DoubleM Text
"Block replay progress (%)" Double
rpsProgress]

docReplayedBlock :: Documented ReplayBlockStats
docReplayedBlock :: Documented ReplayBlockStats
docReplayedBlock = [DocMsg ReplayBlockStats] -> Documented ReplayBlockStats
forall a. [DocMsg a] -> Documented a
Documented [
    Namespace -> [(Text, Text)] -> Text -> DocMsg ReplayBlockStats
forall a. Namespace -> [(Text, Text)] -> Text -> DocMsg a
DocMsg
      [Text
"LedgerReplay"]
      [(Text
"Block replay progress (%)",
        Text
"Progress in percent")]
      Text
"Counts up the percent of a block replay."
  ]

withReplayedBlock :: Trace IO ReplayBlockStats
    -> IO (Trace IO (ChainDB.TraceEvent blk))
withReplayedBlock :: Trace IO ReplayBlockStats -> IO (Trace IO (TraceEvent blk))
withReplayedBlock Trace IO ReplayBlockStats
tr =
    let tr' :: Trace IO ReplayBlockStats
tr' = ((LoggingContext, ReplayBlockStats) -> Bool)
-> Trace IO ReplayBlockStats -> Trace IO ReplayBlockStats
forall (m :: * -> *) a.
Monad m =>
((LoggingContext, a) -> Bool) -> Trace m a -> Trace m a
filterTrace (LoggingContext, ReplayBlockStats) -> Bool
forall a. (a, ReplayBlockStats) -> Bool
filterFunction Trace IO ReplayBlockStats
tr
        tr'' :: Trace IO (Folding a ReplayBlockStats)
tr'' = (Folding a ReplayBlockStats -> ReplayBlockStats)
-> Trace IO ReplayBlockStats
-> Trace IO (Folding a ReplayBlockStats)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap Folding a ReplayBlockStats -> ReplayBlockStats
forall a b. Folding a b -> b
unfold Trace IO ReplayBlockStats
tr'
    in (ReplayBlockStats
 -> LoggingContext -> TraceEvent blk -> IO ReplayBlockStats)
-> ReplayBlockStats
-> Trace IO (Folding (TraceEvent blk) ReplayBlockStats)
-> IO (Trace IO (TraceEvent blk))
forall a acc (m :: * -> *).
MonadUnliftIO m =>
(acc -> LoggingContext -> a -> m acc)
-> acc -> Trace m (Folding a acc) -> m (Trace m a)
foldMTraceM ReplayBlockStats
-> LoggingContext -> TraceEvent blk -> IO ReplayBlockStats
forall (m :: * -> *) blk.
MonadIO m =>
ReplayBlockStats
-> LoggingContext -> TraceEvent blk -> m ReplayBlockStats
replayBlockStats ReplayBlockStats
emptyReplayBlockStats Trace IO (Folding (TraceEvent blk) ReplayBlockStats)
forall a. Trace IO (Folding a ReplayBlockStats)
tr''
  where
    filterFunction :: (a, ReplayBlockStats) -> Bool
filterFunction(a
_, ReplayBlockStats {Bool
Double
rpsLastProgress :: Double
rpsProgress :: Double
rpsDisplay :: Bool
rpsLastProgress :: ReplayBlockStats -> Double
rpsProgress :: ReplayBlockStats -> Double
rpsDisplay :: ReplayBlockStats -> Bool
..}) = Bool
rpsDisplay

replayBlockStats :: MonadIO m
  => ReplayBlockStats
  -> LoggingContext
  -> ChainDB.TraceEvent blk
  -> m ReplayBlockStats
replayBlockStats :: ReplayBlockStats
-> LoggingContext -> TraceEvent blk -> m ReplayBlockStats
replayBlockStats ReplayBlockStats {Bool
Double
rpsLastProgress :: Double
rpsProgress :: Double
rpsDisplay :: Bool
rpsLastProgress :: ReplayBlockStats -> Double
rpsProgress :: ReplayBlockStats -> Double
rpsDisplay :: ReplayBlockStats -> Bool
..} LoggingContext
_context
    (ChainDB.TraceLedgerReplayEvent (LedgerDB.ReplayedBlock RealPoint blk
pt []
                                      (LedgerDB.ReplayStart Point blk
replayTo) ReplayGoal blk
_)) = do
      let slotno :: Integer
slotno = Word64 -> Integer
forall a. Integral a => a -> Integer
toInteger (Word64 -> Integer) -> Word64 -> Integer
forall a b. (a -> b) -> a -> b
$ SlotNo -> Word64
unSlotNo (RealPoint blk -> SlotNo
forall blk. RealPoint blk -> SlotNo
realPointSlot RealPoint blk
pt)
          endslot :: Integer
endslot = Word64 -> Integer
forall a. Integral a => a -> Integer
toInteger (Word64 -> Integer) -> Word64 -> Integer
forall a b. (a -> b) -> a -> b
$ Word64 -> (SlotNo -> Word64) -> WithOrigin SlotNo -> Word64
forall b t. b -> (t -> b) -> WithOrigin t -> b
withOrigin Word64
0 SlotNo -> Word64
unSlotNo (Point blk -> WithOrigin SlotNo
forall block. Point block -> WithOrigin SlotNo
pointSlot Point blk
replayTo)
          progress' :: Double
progress' = (Integer -> Double
forall a. Num a => Integer -> a
fromInteger Integer
slotno Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
100.0) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Integer -> Double
forall a. Num a => Integer -> a
fromInteger (Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
max Integer
slotno Integer
endslot)
      ReplayBlockStats -> m ReplayBlockStats
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ReplayBlockStats -> m ReplayBlockStats)
-> ReplayBlockStats -> m ReplayBlockStats
forall a b. (a -> b) -> a -> b
$ if (Double
progress' Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
0.0 Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
rpsDisplay)
                Bool -> Bool -> Bool
|| ((Double
progress' Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
rpsLastProgress) Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
1.0)
                then Bool -> Double -> Double -> ReplayBlockStats
ReplayBlockStats Bool
True Double
progress' Double
progress'
                else Bool -> Double -> Double -> ReplayBlockStats
ReplayBlockStats Bool
False Double
progress' Double
rpsLastProgress
replayBlockStats st :: ReplayBlockStats
st@ReplayBlockStats {} LoggingContext
_context TraceEvent blk
_ = ReplayBlockStats -> m ReplayBlockStats
forall (f :: * -> *) a. Applicative f => a -> f a
pure ReplayBlockStats
st