{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}

module Ouroboros.Consensus.Tracing.BlockReplayProgress
  ( withReplayedBlock
  , ReplayBlockStats (..)
  ) where

import Cardano.Logging
import Control.Concurrent.MVar
import Data.Aeson (Value (String), (.=))
import Data.Text (Text, pack)
import Numeric (showFFloat)
import Ouroboros.Consensus.Block (SlotNo, realPointSlot)
import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB
import qualified Ouroboros.Consensus.Storage.LedgerDB as LedgerDB
import Ouroboros.Network.Block (pointSlot, unSlotNo)
import Ouroboros.Network.Point (withOrigin)

textShow :: Show a => a -> Text
textShow :: forall a. Show a => a -> Text
textShow = String -> Text
pack (String -> Text) -> (a -> String) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show

newtype ReplayBlockState = ReplayBlockState
  { ReplayBlockState -> Maybe SlotNo
rpsLastSlot :: Maybe SlotNo
  -- ^ Last slot for which a `ReplayBlockStats` message has been issued.
  }

data ReplayBlockStats = ReplayBlockStats
  { ReplayBlockStats -> SlotNo
rpsCurSlot :: SlotNo
  , ReplayBlockStats -> SlotNo
rpsGoalSlot :: SlotNo
  }

initialReplayBlockState :: ReplayBlockState
initialReplayBlockState :: ReplayBlockState
initialReplayBlockState = ReplayBlockState{rpsLastSlot :: Maybe SlotNo
rpsLastSlot = Maybe SlotNo
forall a. Maybe a
Nothing}

progressForMachine :: ReplayBlockStats -> Double
progressForMachine :: ReplayBlockStats -> Double
progressForMachine (ReplayBlockStats SlotNo
curSlot SlotNo
goalSlot) =
  (Word64 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (SlotNo -> Word64
unSlotNo SlotNo
curSlot) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
100.0) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Word64 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (SlotNo -> Word64
unSlotNo (SlotNo -> Word64) -> SlotNo -> Word64
forall a b. (a -> b) -> a -> b
$ SlotNo -> SlotNo -> SlotNo
forall a. Ord a => a -> a -> a
max SlotNo
curSlot SlotNo
goalSlot)

progressForHuman :: ReplayBlockStats -> Double
progressForHuman :: ReplayBlockStats -> Double
progressForHuman = Double -> Double
round2 (Double -> Double)
-> (ReplayBlockStats -> Double) -> ReplayBlockStats -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReplayBlockStats -> Double
progressForMachine
 where
  round2 :: Double -> Double
  round2 :: Double -> Double
round2 Double
num =
    let
      f :: Int
      f :: Int
f = Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (Double -> Int) -> Double -> Int
forall a b. (a -> b) -> a -> b
$ Double
num Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
100
     in
      Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
f Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
100

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

instance LogFormatting ReplayBlockStats where
  forMachine :: DetailLevel -> ReplayBlockStats -> Object
forMachine DetailLevel
_ ReplayBlockStats
stats =
    [Object] -> Object
forall a. Monoid a => [a] -> a
mconcat
      [ Key
"kind" Key -> Value -> Object
forall v. ToJSON v => Key -> v -> Object
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String Text
"ReplayBlockStats"
      , Key
"progress" Key -> Value -> Object
forall v. ToJSON v => Key -> v -> Object
forall e kv v. (KeyValue e 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. Show a => a -> String
show (Double -> String) -> Double -> String
forall a b. (a -> b) -> a -> b
$ ReplayBlockStats -> Double
progressForMachine ReplayBlockStats
stats)
      ]

  forHuman :: ReplayBlockStats -> Text
forHuman stats :: ReplayBlockStats
stats@ReplayBlockStats{SlotNo
rpsCurSlot :: ReplayBlockStats -> SlotNo
rpsGoalSlot :: ReplayBlockStats -> SlotNo
rpsCurSlot :: SlotNo
rpsGoalSlot :: SlotNo
..} =
    Text
"Replayed block: slot "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word64 -> Text
forall a. Show a => a -> Text
textShow (SlotNo -> Word64
unSlotNo SlotNo
rpsCurSlot)
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" out of "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word64 -> Text
forall a. Show a => a -> Text
textShow (SlotNo -> Word64
unSlotNo SlotNo
rpsGoalSlot)
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
". Progress: "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
pack (Maybe Int -> Double -> ShowS
forall a. RealFloat a => Maybe Int -> a -> ShowS
showFFloat (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
2) (ReplayBlockStats -> Double
progressForHuman ReplayBlockStats
stats) String
forall a. Monoid a => a
mempty)
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"%"

  asMetrics :: ReplayBlockStats -> [Metric]
asMetrics ReplayBlockStats
stats =
    [Text -> Double -> Metric
DoubleM Text
"blockReplayProgress" (ReplayBlockStats -> Double
progressForMachine ReplayBlockStats
stats)]

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

  severityFor :: Namespace ReplayBlockStats
-> Maybe ReplayBlockStats -> Maybe SeverityS
severityFor (Namespace [Text]
_ [Text
"LedgerReplay"]) Maybe ReplayBlockStats
_ = SeverityS -> Maybe SeverityS
forall a. a -> Maybe a
Just SeverityS
Info
  severityFor Namespace ReplayBlockStats
_ Maybe ReplayBlockStats
_ = Maybe SeverityS
forall a. Maybe a
Nothing

  documentFor :: Namespace ReplayBlockStats -> Maybe Text
documentFor (Namespace [Text]
_ [Text
"LedgerReplay"]) =
    Text -> Maybe Text
forall a. a -> Maybe a
Just
      Text
"Counts block replays and calculates the percent."
  documentFor Namespace ReplayBlockStats
_ = Maybe Text
forall a. Maybe a
Nothing

  metricsDocFor :: Namespace ReplayBlockStats -> [(Text, Text)]
metricsDocFor (Namespace [Text]
_ [Text
"LedgerReplay"]) =
    [(Text
"blockReplayProgress", Text
"Progress in percent")]
  metricsDocFor Namespace ReplayBlockStats
_ = []

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

withReplayedBlock ::
  Trace IO ReplayBlockStats ->
  IO (Trace IO (ChainDB.TraceEvent blk))
withReplayedBlock :: forall blk.
Trace IO ReplayBlockStats -> IO (Trace IO (TraceEvent blk))
withReplayedBlock Trace IO ReplayBlockStats
tr = do
  var <- ReplayBlockState -> IO (MVar ReplayBlockState)
forall a. a -> IO (MVar a)
newMVar ReplayBlockState
initialReplayBlockState
  contramapMCond tr (process var)
 where
  process ::
    MVar ReplayBlockState ->
    (LoggingContext, Either TraceControl (ChainDB.TraceEvent blk)) ->
    IO (Maybe (LoggingContext, Either TraceControl ReplayBlockStats))
  process :: forall blk.
MVar ReplayBlockState
-> (LoggingContext, Either TraceControl (TraceEvent blk))
-> IO
     (Maybe (LoggingContext, Either TraceControl ReplayBlockStats))
process MVar ReplayBlockState
var (LoggingContext
ctx, Right TraceEvent blk
msg) = MVar ReplayBlockState
-> (ReplayBlockState
    -> IO
         (ReplayBlockState,
          Maybe (LoggingContext, Either TraceControl ReplayBlockStats)))
-> IO
     (Maybe (LoggingContext, Either TraceControl ReplayBlockStats))
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar ReplayBlockState
var ((ReplayBlockState
  -> IO
       (ReplayBlockState,
        Maybe (LoggingContext, Either TraceControl ReplayBlockStats)))
 -> IO
      (Maybe (LoggingContext, Either TraceControl ReplayBlockStats)))
-> (ReplayBlockState
    -> IO
         (ReplayBlockState,
          Maybe (LoggingContext, Either TraceControl ReplayBlockStats)))
-> IO
     (Maybe (LoggingContext, Either TraceControl ReplayBlockStats))
forall a b. (a -> b) -> a -> b
$ \ReplayBlockState
st -> do
    let !(!ReplayBlockState
st', Maybe ReplayBlockStats
mbStats) = TraceEvent blk
-> ReplayBlockState -> (ReplayBlockState, Maybe ReplayBlockStats)
forall blk.
TraceEvent blk
-> ReplayBlockState -> (ReplayBlockState, Maybe ReplayBlockStats)
mbProduceBlockStats TraceEvent blk
msg ReplayBlockState
st
    (ReplayBlockState,
 Maybe (LoggingContext, Either TraceControl ReplayBlockStats))
-> IO
     (ReplayBlockState,
      Maybe (LoggingContext, Either TraceControl ReplayBlockStats))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ReplayBlockState
st', (ReplayBlockStats
 -> (LoggingContext, Either TraceControl ReplayBlockStats))
-> Maybe ReplayBlockStats
-> Maybe (LoggingContext, Either TraceControl ReplayBlockStats)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((LoggingContext
ctx,) (Either TraceControl ReplayBlockStats
 -> (LoggingContext, Either TraceControl ReplayBlockStats))
-> (ReplayBlockStats -> Either TraceControl ReplayBlockStats)
-> ReplayBlockStats
-> (LoggingContext, Either TraceControl ReplayBlockStats)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReplayBlockStats -> Either TraceControl ReplayBlockStats
forall a b. b -> Either a b
Right) Maybe ReplayBlockStats
mbStats)
  process MVar ReplayBlockState
_ (LoggingContext
ctx, Left TraceControl
control) = Maybe (LoggingContext, Either TraceControl ReplayBlockStats)
-> IO
     (Maybe (LoggingContext, Either TraceControl ReplayBlockStats))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((LoggingContext, Either TraceControl ReplayBlockStats)
-> Maybe (LoggingContext, Either TraceControl ReplayBlockStats)
forall a. a -> Maybe a
Just (LoggingContext
ctx, TraceControl -> Either TraceControl ReplayBlockStats
forall a b. a -> Either a b
Left TraceControl
control))

  mbProduceBlockStats ::
    ChainDB.TraceEvent blk -> ReplayBlockState -> (ReplayBlockState, Maybe ReplayBlockStats)
  mbProduceBlockStats :: forall blk.
TraceEvent blk
-> ReplayBlockState -> (ReplayBlockState, Maybe ReplayBlockStats)
mbProduceBlockStats
    ( ChainDB.TraceLedgerDBEvent
        ( LedgerDB.LedgerReplayEvent
            ( LedgerDB.TraceReplayProgressEvent
                (LedgerDB.ReplayedBlock RealPoint blk
curSlot [] ReplayStart blk
_ (LedgerDB.ReplayGoal Point blk
replayToSlot))
              )
          )
      )
    st :: ReplayBlockState
st@(ReplayBlockState Maybe SlotNo
mLastSlot) =
      let curSlotNo :: SlotNo
curSlotNo = RealPoint blk -> SlotNo
forall blk. RealPoint blk -> SlotNo
realPointSlot RealPoint blk
curSlot
          goalSlotNo :: SlotNo
goalSlotNo = SlotNo -> (SlotNo -> SlotNo) -> WithOrigin SlotNo -> SlotNo
forall b t. b -> (t -> b) -> WithOrigin t -> b
withOrigin SlotNo
0 SlotNo -> SlotNo
forall a. a -> a
id (WithOrigin SlotNo -> SlotNo) -> WithOrigin SlotNo -> SlotNo
forall a b. (a -> b) -> a -> b
$ Point blk -> WithOrigin SlotNo
forall {k} (block :: k). Point block -> WithOrigin SlotNo
pointSlot Point blk
replayToSlot
          stats :: ReplayBlockStats
stats = SlotNo -> SlotNo -> ReplayBlockStats
ReplayBlockStats SlotNo
curSlotNo SlotNo
goalSlotNo
          progressFor :: SlotNo -> SlotNo -> Double
progressFor SlotNo
soFar SlotNo
goal = ReplayBlockStats -> Double
progressForHuman (SlotNo -> SlotNo -> ReplayBlockStats
ReplayBlockStats SlotNo
soFar SlotNo
goal)
          shouldEmit :: Bool
shouldEmit =
            Bool -> (SlotNo -> Bool) -> Maybe SlotNo -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
              Bool
True
              (\SlotNo
lastSlot -> SlotNo -> SlotNo -> Double
progressFor SlotNo
curSlotNo SlotNo
goalSlotNo Double -> Double -> Double
forall a. Num a => a -> a -> a
- SlotNo -> SlotNo -> Double
progressFor SlotNo
lastSlot SlotNo
goalSlotNo Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
0.01)
              Maybe SlotNo
mLastSlot
       in if Bool
shouldEmit
            then (Maybe SlotNo -> ReplayBlockState
ReplayBlockState (SlotNo -> Maybe SlotNo
forall a. a -> Maybe a
Just SlotNo
curSlotNo), ReplayBlockStats -> Maybe ReplayBlockStats
forall a. a -> Maybe a
Just ReplayBlockStats
stats)
            else (ReplayBlockState
st, Maybe ReplayBlockStats
forall a. Maybe a
Nothing)
  mbProduceBlockStats TraceEvent blk
_ ReplayBlockState
st = (ReplayBlockState
st, Maybe ReplayBlockStats
forall a. Maybe a
Nothing)