{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE DeriveAnyClass      #-}
{-# LANGUAGE DerivingStrategies  #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Plutus.ChainIndex.SyncStats where

import Cardano.BM.Tracing (ToObject)
import Control.Monad.Freer (Eff, Member)
import Control.Monad.Freer.Extras (LogMsg, logInfo)
import Data.Aeson (FromJSON, ToJSON)
import Data.Time.Units (Second, fromMicroseconds)
import Data.Time.Units.Extra ()
import GHC.Generics (Generic)
import Ledger (Slot (Slot))
import Plutus.ChainIndex (Point (PointAtGenesis), tipAsPoint)
import Plutus.ChainIndex qualified as CI
import Plutus.ChainIndex.Lib (ChainSyncEvent (Resume, RollBackward, RollForward))
import Prettyprinter (Pretty (pretty), comma, viaShow, (<+>))
import System.Clock (TimeSpec, toNanoSecs)
import Text.Printf (printf)

data SyncStats = SyncStats
    { SyncStats -> Integer
syncStatsAppliedBlocks    :: Integer -- ^ Number of applied blocks
    , SyncStats -> Integer
syncStatsAppliedRollbacks :: Integer -- ^ Number of rollbacks
    , SyncStats -> Point
syncStatsChainSyncPoint   :: CI.Point -- ^ Chain index syncing tip
    , SyncStats -> Point
syncStatsNodePoint        :: CI.Point -- ^ Current tip of the node
    }
    deriving stock (SyncStats -> SyncStats -> Bool
(SyncStats -> SyncStats -> Bool)
-> (SyncStats -> SyncStats -> Bool) -> Eq SyncStats
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SyncStats -> SyncStats -> Bool
$c/= :: SyncStats -> SyncStats -> Bool
== :: SyncStats -> SyncStats -> Bool
$c== :: SyncStats -> SyncStats -> Bool
Eq, Int -> SyncStats -> ShowS
[SyncStats] -> ShowS
SyncStats -> String
(Int -> SyncStats -> ShowS)
-> (SyncStats -> String)
-> ([SyncStats] -> ShowS)
-> Show SyncStats
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SyncStats] -> ShowS
$cshowList :: [SyncStats] -> ShowS
show :: SyncStats -> String
$cshow :: SyncStats -> String
showsPrec :: Int -> SyncStats -> ShowS
$cshowsPrec :: Int -> SyncStats -> ShowS
Show, (forall x. SyncStats -> Rep SyncStats x)
-> (forall x. Rep SyncStats x -> SyncStats) -> Generic SyncStats
forall x. Rep SyncStats x -> SyncStats
forall x. SyncStats -> Rep SyncStats x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep SyncStats x -> SyncStats
$cfrom :: forall x. SyncStats -> Rep SyncStats x
Generic)
    deriving anyclass (Value -> Parser [SyncStats]
Value -> Parser SyncStats
(Value -> Parser SyncStats)
-> (Value -> Parser [SyncStats]) -> FromJSON SyncStats
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [SyncStats]
$cparseJSONList :: Value -> Parser [SyncStats]
parseJSON :: Value -> Parser SyncStats
$cparseJSON :: Value -> Parser SyncStats
FromJSON, [SyncStats] -> Encoding
[SyncStats] -> Value
SyncStats -> Encoding
SyncStats -> Value
(SyncStats -> Value)
-> (SyncStats -> Encoding)
-> ([SyncStats] -> Value)
-> ([SyncStats] -> Encoding)
-> ToJSON SyncStats
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [SyncStats] -> Encoding
$ctoEncodingList :: [SyncStats] -> Encoding
toJSONList :: [SyncStats] -> Value
$ctoJSONList :: [SyncStats] -> Value
toEncoding :: SyncStats -> Encoding
$ctoEncoding :: SyncStats -> Encoding
toJSON :: SyncStats -> Value
$ctoJSON :: SyncStats -> Value
ToJSON, TracingVerbosity -> SyncStats -> Object
SyncStats -> Object -> Text
(TracingVerbosity -> SyncStats -> Object)
-> (SyncStats -> Object -> Text) -> ToObject SyncStats
forall a.
(TracingVerbosity -> a -> Object)
-> (a -> Object -> Text) -> ToObject a
textTransformer :: SyncStats -> Object -> Text
$ctextTransformer :: SyncStats -> Object -> Text
toObject :: TracingVerbosity -> SyncStats -> Object
$ctoObject :: TracingVerbosity -> SyncStats -> Object
ToObject)

instance Semigroup SyncStats where
    SyncStats Integer
n1 Integer
m1 Point
ct1 Point
nt1 <> :: SyncStats -> SyncStats -> SyncStats
<> SyncStats Integer
n2 Integer
m2 Point
ct2 Point
nt2 =
        Integer -> Integer -> Point -> Point -> SyncStats
SyncStats (Integer
n1 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
n2) (Integer
m1 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
m2) (Point
ct1 Point -> Point -> Point
forall a. Semigroup a => a -> a -> a
<> Point
ct2) (Point
nt1 Point -> Point -> Point
forall a. Semigroup a => a -> a -> a
<> Point
nt2)

instance Monoid SyncStats where
    mempty :: SyncStats
mempty = Integer -> Integer -> Point -> Point -> SyncStats
SyncStats Integer
0 Integer
0 Point
forall a. Monoid a => a
mempty Point
forall a. Monoid a => a
mempty

data SyncLog = SyncLog
    { SyncLog -> SyncState
syncStateSyncLog  :: SyncState -- ^ State of the syncing
    , SyncLog -> SyncStats
syncStatsSyncLog  :: SyncStats -- ^ Stats of the syncing
    , SyncLog -> Second
syncPeriodSyncLog :: Second -- ^ Period in seconds used to accumulate log events
    }
    deriving stock (SyncLog -> SyncLog -> Bool
(SyncLog -> SyncLog -> Bool)
-> (SyncLog -> SyncLog -> Bool) -> Eq SyncLog
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SyncLog -> SyncLog -> Bool
$c/= :: SyncLog -> SyncLog -> Bool
== :: SyncLog -> SyncLog -> Bool
$c== :: SyncLog -> SyncLog -> Bool
Eq, Int -> SyncLog -> ShowS
[SyncLog] -> ShowS
SyncLog -> String
(Int -> SyncLog -> ShowS)
-> (SyncLog -> String) -> ([SyncLog] -> ShowS) -> Show SyncLog
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SyncLog] -> ShowS
$cshowList :: [SyncLog] -> ShowS
show :: SyncLog -> String
$cshow :: SyncLog -> String
showsPrec :: Int -> SyncLog -> ShowS
$cshowsPrec :: Int -> SyncLog -> ShowS
Show, (forall x. SyncLog -> Rep SyncLog x)
-> (forall x. Rep SyncLog x -> SyncLog) -> Generic SyncLog
forall x. Rep SyncLog x -> SyncLog
forall x. SyncLog -> Rep SyncLog x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep SyncLog x -> SyncLog
$cfrom :: forall x. SyncLog -> Rep SyncLog x
Generic)
    deriving anyclass (Value -> Parser [SyncLog]
Value -> Parser SyncLog
(Value -> Parser SyncLog)
-> (Value -> Parser [SyncLog]) -> FromJSON SyncLog
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [SyncLog]
$cparseJSONList :: Value -> Parser [SyncLog]
parseJSON :: Value -> Parser SyncLog
$cparseJSON :: Value -> Parser SyncLog
FromJSON, [SyncLog] -> Encoding
[SyncLog] -> Value
SyncLog -> Encoding
SyncLog -> Value
(SyncLog -> Value)
-> (SyncLog -> Encoding)
-> ([SyncLog] -> Value)
-> ([SyncLog] -> Encoding)
-> ToJSON SyncLog
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [SyncLog] -> Encoding
$ctoEncodingList :: [SyncLog] -> Encoding
toJSONList :: [SyncLog] -> Value
$ctoJSONList :: [SyncLog] -> Value
toEncoding :: SyncLog -> Encoding
$ctoEncoding :: SyncLog -> Encoding
toJSON :: SyncLog -> Value
$ctoJSON :: SyncLog -> Value
ToJSON, TracingVerbosity -> SyncLog -> Object
SyncLog -> Object -> Text
(TracingVerbosity -> SyncLog -> Object)
-> (SyncLog -> Object -> Text) -> ToObject SyncLog
forall a.
(TracingVerbosity -> a -> Object)
-> (a -> Object -> Text) -> ToObject a
textTransformer :: SyncLog -> Object -> Text
$ctextTransformer :: SyncLog -> Object -> Text
toObject :: TracingVerbosity -> SyncLog -> Object
$ctoObject :: TracingVerbosity -> SyncLog -> Object
ToObject)

instance Pretty SyncLog where
  pretty :: SyncLog -> Doc ann
pretty = \case
    SyncLog SyncState
syncState (SyncStats Integer
numRollForward Integer
numRollBackwards Point
chainSyncPoint Point
_) Second
period ->
        let currentTipMsg :: SyncState -> Doc ann
currentTipMsg SyncState
NotSyncing = Doc ann
""
            currentTipMsg SyncState
_          = Doc ann
"Current tip is" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Point -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Point
chainSyncPoint
         in
            SyncState -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty SyncState
syncState
                Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"Processed"
                Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Integer -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Integer
numRollForward
                Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"blocks"
                Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
comma
                Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Integer -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Integer
numRollBackwards
                Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"rollbacks in the last"
                Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Second -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow Second
period
                Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"."
                Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> SyncState -> Doc ann
currentTipMsg SyncState
syncState

data SyncState = Synced | Syncing Double | NotSyncing
    deriving stock (SyncState -> SyncState -> Bool
(SyncState -> SyncState -> Bool)
-> (SyncState -> SyncState -> Bool) -> Eq SyncState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SyncState -> SyncState -> Bool
$c/= :: SyncState -> SyncState -> Bool
== :: SyncState -> SyncState -> Bool
$c== :: SyncState -> SyncState -> Bool
Eq, Int -> SyncState -> ShowS
[SyncState] -> ShowS
SyncState -> String
(Int -> SyncState -> ShowS)
-> (SyncState -> String)
-> ([SyncState] -> ShowS)
-> Show SyncState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SyncState] -> ShowS
$cshowList :: [SyncState] -> ShowS
show :: SyncState -> String
$cshow :: SyncState -> String
showsPrec :: Int -> SyncState -> ShowS
$cshowsPrec :: Int -> SyncState -> ShowS
Show, (forall x. SyncState -> Rep SyncState x)
-> (forall x. Rep SyncState x -> SyncState) -> Generic SyncState
forall x. Rep SyncState x -> SyncState
forall x. SyncState -> Rep SyncState x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep SyncState x -> SyncState
$cfrom :: forall x. SyncState -> Rep SyncState x
Generic)
    deriving anyclass (Value -> Parser [SyncState]
Value -> Parser SyncState
(Value -> Parser SyncState)
-> (Value -> Parser [SyncState]) -> FromJSON SyncState
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [SyncState]
$cparseJSONList :: Value -> Parser [SyncState]
parseJSON :: Value -> Parser SyncState
$cparseJSON :: Value -> Parser SyncState
FromJSON, [SyncState] -> Encoding
[SyncState] -> Value
SyncState -> Encoding
SyncState -> Value
(SyncState -> Value)
-> (SyncState -> Encoding)
-> ([SyncState] -> Value)
-> ([SyncState] -> Encoding)
-> ToJSON SyncState
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [SyncState] -> Encoding
$ctoEncodingList :: [SyncState] -> Encoding
toJSONList :: [SyncState] -> Value
$ctoJSONList :: [SyncState] -> Value
toEncoding :: SyncState -> Encoding
$ctoEncoding :: SyncState -> Encoding
toJSON :: SyncState -> Value
$ctoJSON :: SyncState -> Value
ToJSON, TracingVerbosity -> SyncState -> Object
SyncState -> Object -> Text
(TracingVerbosity -> SyncState -> Object)
-> (SyncState -> Object -> Text) -> ToObject SyncState
forall a.
(TracingVerbosity -> a -> Object)
-> (a -> Object -> Text) -> ToObject a
textTransformer :: SyncState -> Object -> Text
$ctextTransformer :: SyncState -> Object -> Text
toObject :: TracingVerbosity -> SyncState -> Object
$ctoObject :: TracingVerbosity -> SyncState -> Object
ToObject)

isSyncStateSynced :: SyncState -> Bool
isSyncStateSynced :: SyncState -> Bool
isSyncStateSynced SyncState
Synced = Bool
True
isSyncStateSynced SyncState
_      = Bool
False

isSyncStateNotSyncing :: SyncState -> Bool
isSyncStateNotSyncing :: SyncState -> Bool
isSyncStateNotSyncing SyncState
NotSyncing = Bool
True
isSyncStateNotSyncing SyncState
_          = Bool
False

isSyncStateSyncing :: SyncState -> Bool
isSyncStateSyncing :: SyncState -> Bool
isSyncStateSyncing (Syncing Double
_) = Bool
True
isSyncStateSyncing SyncState
_           = Bool
False

instance Pretty SyncState where
  pretty :: SyncState -> Doc ann
pretty = \case
    SyncState
Synced      -> Doc ann
"Still in sync."
    Syncing Double
pct -> Doc ann
"Syncing (" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (String -> Double -> String
forall r. PrintfType r => String -> r
printf String
"%.2f" Double
pct :: String) Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"%)."
    SyncState
NotSyncing  -> Doc ann
"Not syncing."

-- | Log syncing summary.
logProgress :: forall effs. (Member (LogMsg SyncLog) effs) => [ChainSyncEvent] -> TimeSpec -> Eff effs ()
logProgress :: [ChainSyncEvent] -> TimeSpec -> Eff effs ()
logProgress [ChainSyncEvent]
events TimeSpec
period = do
    let syncStats :: SyncStats
syncStats = (SyncStats -> SyncStats -> SyncStats)
-> SyncStats -> [SyncStats] -> SyncStats
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl SyncStats -> SyncStats -> SyncStats
forall a. Semigroup a => a -> a -> a
(<>) SyncStats
forall a. Monoid a => a
mempty ([SyncStats] -> SyncStats) -> [SyncStats] -> SyncStats
forall a b. (a -> b) -> a -> b
$ (ChainSyncEvent -> SyncStats) -> [ChainSyncEvent] -> [SyncStats]
forall a b. (a -> b) -> [a] -> [b]
map ChainSyncEvent -> SyncStats
convertEventToSyncStats [ChainSyncEvent]
events
    let syncState :: SyncState
syncState = SyncStats -> SyncState
getSyncStateFromStats SyncStats
syncStats
    let syncLog :: SyncLog
syncLog = SyncState -> SyncStats -> Second -> SyncLog
SyncLog SyncState
syncState SyncStats
syncStats (Integer -> Second
forall a. TimeUnit a => Integer -> a
fromMicroseconds (Integer -> Second) -> Integer -> Second
forall a b. (a -> b) -> a -> b
$ TimeSpec -> Integer
toNanoSecs TimeSpec
period Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
1000)
    case SyncState
syncState of
      SyncState
NotSyncing -> () -> Eff effs ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure () -- logWarn syncLog
      SyncState
_          -> SyncLog -> Eff effs ()
forall a (effs :: [* -> *]).
Member (LogMsg a) effs =>
a -> Eff effs ()
logInfo SyncLog
syncLog

-- | Get the 'SyncState' for a 'SyncState'.
--
-- TODO: The syncing percentage is valid when the node is already fully synced.
-- But when the node and chain-index are started at the same time, the syncing
-- percentage is not a valid number considering the actual tip of the node.
-- Find a better way to calculate this percentage.
getSyncStateFromStats :: SyncStats -> SyncState
getSyncStateFromStats :: SyncStats -> SyncState
getSyncStateFromStats (SyncStats Integer
_ Integer
_ Point
chainSyncPoint Point
nodePoint) =
    Point -> Point -> SyncState
getSyncState Point
chainSyncPoint Point
nodePoint

getSyncState :: CI.Point -> CI.Point -> SyncState
getSyncState :: Point -> Point -> SyncState
getSyncState Point
chainIndexSyncPoint Point
nodePoint =
    case (Point
chainIndexSyncPoint, Point
nodePoint) of
        (Point
_, Point
PointAtGenesis) -> SyncState
NotSyncing
        (Point
CI.PointAtGenesis, CI.Point Slot
_ BlockId
_) -> Double -> SyncState
Syncing Double
0
        (CI.Point (Slot Integer
chainSyncSlot) BlockId
_, CI.Point (Slot Integer
nodeSlot) BlockId
_)
          -- TODO: MAGIC number here. Is there a better number?
          -- 100 represents the number of slots before the
          -- node where we consider the chain-index to be synced.
          | Integer
nodeSlot Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
chainSyncSlot Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
100 -> SyncState
Synced
        (CI.Point (Slot Integer
chainSyncSlot) BlockId
_, CI.Point (Slot Integer
nodeSlot) BlockId
_) ->
            let pct :: Double
pct = ((Double
100 :: Double) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Integer -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
chainSyncSlot) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Integer -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
nodeSlot
             in Double -> SyncState
Syncing Double
pct

convertEventToSyncStats :: ChainSyncEvent -> SyncStats
convertEventToSyncStats :: ChainSyncEvent -> SyncStats
convertEventToSyncStats (RollForward (CI.Block Tip
chainSyncTip [(ChainIndexTx, TxProcessOption)]
_) Tip
nodeTip) =
    Integer -> Integer -> Point -> Point -> SyncStats
SyncStats Integer
1 Integer
0 (Tip -> Point
tipAsPoint Tip
chainSyncTip) (Tip -> Point
tipAsPoint Tip
nodeTip)
convertEventToSyncStats (RollBackward Point
chainSyncPoint Tip
nodeTip) =
    Integer -> Integer -> Point -> Point -> SyncStats
SyncStats Integer
0 Integer
1 Point
chainSyncPoint (Tip -> Point
tipAsPoint Tip
nodeTip)
convertEventToSyncStats (Resume Point
chainSyncPoint) =
    Integer -> Integer -> Point -> Point -> SyncStats
SyncStats Integer
0 Integer
0 Point
chainSyncPoint Point
forall a. Monoid a => a
mempty