{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NamedFieldPuns    #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Marconi.Logging (logging) where

import Cardano.Api (Block (Block), BlockHeader (BlockHeader), BlockInMode (BlockInMode), CardanoMode,
                    ChainPoint (ChainPoint), ChainTip (ChainTip), SlotNo (SlotNo))
import Cardano.BM.Trace (Trace, logInfo)
import Control.Monad (when)
import Data.IORef (IORef, modifyIORef', newIORef, readIORef)
import Data.Text (Text)
import Data.Time (NominalDiffTime, UTCTime, defaultTimeLocale, diffUTCTime, formatTime, getCurrentTime)
import Prettyprinter (Pretty (pretty), defaultLayoutOptions, layoutPretty, (<+>))
import Prettyprinter.Render.Text (renderStrict)
import Streaming (Of, Stream, effect)
import Streaming.Prelude qualified as S
import Text.Printf (printf)

import Cardano.Streaming (ChainSyncEvent (RollBackward, RollForward))
import Marconi.Orphans ()

data SyncStats = SyncStats
  { -- | Number of applied blocks since last message
    SyncStats -> Int
syncStatsNumBlocks    :: !Int,
    -- | Number of rollbacks
    SyncStats -> Int
syncStatsNumRollbacks :: !Int,
    -- | Timestamp of last printed message
    SyncStats -> Maybe UTCTime
syncStatsLastMessage  :: !(Maybe UTCTime)
  }

logging ::
  Trace IO Text ->
  Stream (Of (ChainSyncEvent (BlockInMode CardanoMode))) IO r ->
  Stream (Of (ChainSyncEvent (BlockInMode CardanoMode))) IO r
logging :: Trace IO Text
-> Stream (Of (ChainSyncEvent (BlockInMode CardanoMode))) IO r
-> Stream (Of (ChainSyncEvent (BlockInMode CardanoMode))) IO r
logging Trace IO Text
tracer Stream (Of (ChainSyncEvent (BlockInMode CardanoMode))) IO r
s = IO (Stream (Of (ChainSyncEvent (BlockInMode CardanoMode))) IO r)
-> Stream (Of (ChainSyncEvent (BlockInMode CardanoMode))) IO r
forall (m :: * -> *) (f :: * -> *) r.
(Monad m, Functor f) =>
m (Stream f m r) -> Stream f m r
effect (IO (Stream (Of (ChainSyncEvent (BlockInMode CardanoMode))) IO r)
 -> Stream (Of (ChainSyncEvent (BlockInMode CardanoMode))) IO r)
-> IO (Stream (Of (ChainSyncEvent (BlockInMode CardanoMode))) IO r)
-> Stream (Of (ChainSyncEvent (BlockInMode CardanoMode))) IO r
forall a b. (a -> b) -> a -> b
$ do
  IORef SyncStats
stats <- SyncStats -> IO (IORef SyncStats)
forall a. a -> IO (IORef a)
newIORef (Int -> Int -> Maybe UTCTime -> SyncStats
SyncStats Int
0 Int
0 Maybe UTCTime
forall a. Maybe a
Nothing)
  Stream (Of (ChainSyncEvent (BlockInMode CardanoMode))) IO r
-> IO (Stream (Of (ChainSyncEvent (BlockInMode CardanoMode))) IO r)
forall (m :: * -> *) a. Monad m => a -> m a
return (Stream (Of (ChainSyncEvent (BlockInMode CardanoMode))) IO r
 -> IO
      (Stream (Of (ChainSyncEvent (BlockInMode CardanoMode))) IO r))
-> Stream (Of (ChainSyncEvent (BlockInMode CardanoMode))) IO r
-> IO (Stream (Of (ChainSyncEvent (BlockInMode CardanoMode))) IO r)
forall a b. (a -> b) -> a -> b
$ (ChainSyncEvent (BlockInMode CardanoMode) -> IO ())
-> Stream (Of (ChainSyncEvent (BlockInMode CardanoMode))) IO r
-> Stream (Of (ChainSyncEvent (BlockInMode CardanoMode))) IO r
forall (m :: * -> *) a y r.
Monad m =>
(a -> m y) -> Stream (Of a) m r -> Stream (Of a) m r
S.chain (IORef SyncStats
-> ChainSyncEvent (BlockInMode CardanoMode) -> IO ()
update IORef SyncStats
stats) Stream (Of (ChainSyncEvent (BlockInMode CardanoMode))) IO r
s
  where
    minSecondsBetweenMsg :: NominalDiffTime
    minSecondsBetweenMsg :: NominalDiffTime
minSecondsBetweenMsg = NominalDiffTime
10

    update :: IORef SyncStats -> ChainSyncEvent (BlockInMode CardanoMode) -> IO ()
    update :: IORef SyncStats
-> ChainSyncEvent (BlockInMode CardanoMode) -> IO ()
update IORef SyncStats
statsRef (RollForward BlockInMode CardanoMode
bim ChainTip
ct) = do
      let cp :: ChainPoint
cp = case BlockInMode CardanoMode
bim of (BlockInMode (Block (BlockHeader SlotNo
slotNo Hash BlockHeader
hash BlockNo
_blockNo) [Tx era]
_txs) EraInMode era CardanoMode
_eim) -> SlotNo -> Hash BlockHeader -> ChainPoint
ChainPoint SlotNo
slotNo Hash BlockHeader
hash
      IORef SyncStats -> (SyncStats -> SyncStats) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef SyncStats
statsRef ((SyncStats -> SyncStats) -> IO ())
-> (SyncStats -> SyncStats) -> IO ()
forall a b. (a -> b) -> a -> b
$ \SyncStats
stats ->
        SyncStats
stats {syncStatsNumBlocks :: Int
syncStatsNumBlocks = SyncStats -> Int
syncStatsNumBlocks SyncStats
stats Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1}
      IORef SyncStats -> ChainPoint -> ChainTip -> IO ()
printMessage IORef SyncStats
statsRef ChainPoint
cp ChainTip
ct
    update IORef SyncStats
statsRef (RollBackward ChainPoint
cp ChainTip
ct) = do
      IORef SyncStats -> (SyncStats -> SyncStats) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef SyncStats
statsRef ((SyncStats -> SyncStats) -> IO ())
-> (SyncStats -> SyncStats) -> IO ()
forall a b. (a -> b) -> a -> b
$ \SyncStats
stats ->
        SyncStats
stats {syncStatsNumRollbacks :: Int
syncStatsNumRollbacks = SyncStats -> Int
syncStatsNumRollbacks SyncStats
stats Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1}
      IORef SyncStats -> ChainPoint -> ChainTip -> IO ()
printMessage IORef SyncStats
statsRef ChainPoint
cp ChainTip
ct

    printMessage :: IORef SyncStats -> ChainPoint -> ChainTip -> IO ()
printMessage IORef SyncStats
statsRef ChainPoint
cp ChainTip
ct = do
      SyncStats {Int
syncStatsNumBlocks :: Int
syncStatsNumBlocks :: SyncStats -> Int
syncStatsNumBlocks, Int
syncStatsNumRollbacks :: Int
syncStatsNumRollbacks :: SyncStats -> Int
syncStatsNumRollbacks, Maybe UTCTime
syncStatsLastMessage :: Maybe UTCTime
syncStatsLastMessage :: SyncStats -> Maybe UTCTime
syncStatsLastMessage} <- IORef SyncStats -> IO SyncStats
forall a. IORef a -> IO a
readIORef IORef SyncStats
statsRef

      UTCTime
now <- IO UTCTime
getCurrentTime

      let timeSinceLastMsg :: Maybe NominalDiffTime
timeSinceLastMsg = UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
now (UTCTime -> NominalDiffTime)
-> Maybe UTCTime -> Maybe NominalDiffTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe UTCTime
syncStatsLastMessage

      let blocksMsg :: Doc Any -> Doc Any
blocksMsg = case Maybe NominalDiffTime
timeSinceLastMsg of
            Maybe NominalDiffTime
Nothing -> Doc Any -> Doc Any
forall a. a -> a
id
            Just NominalDiffTime
t -> \Doc Any
k ->
              Doc Any
"Processed"
                Doc Any -> Doc Any -> Doc Any
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Int -> Doc Any
forall a ann. Pretty a => a -> Doc ann
pretty Int
syncStatsNumBlocks
                Doc Any -> Doc Any -> Doc Any
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc Any
"blocks in the last"
                Doc Any -> Doc Any -> Doc Any
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc Any
forall a ann. Pretty a => a -> Doc ann
pretty (TimeLocale -> String -> NominalDiffTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%s" NominalDiffTime
t)
                Doc Any -> Doc Any -> Doc Any
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc Any
"seconds"
                Doc Any -> Doc Any -> Doc Any
forall ann. Doc ann -> Doc ann -> Doc ann
<+> let rate :: Double
rate = Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
syncStatsNumBlocks Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ NominalDiffTime -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac NominalDiffTime
t :: Double
                     in String -> Doc Any
forall a ann. Pretty a => a -> Doc ann
pretty (String -> Double -> String
forall r. PrintfType r => String -> r
printf String
"(%.0f blocks/sec)." Double
rate :: String)
                Doc Any -> Doc Any -> Doc Any
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc Any
k

      let rollbackMsg :: Doc Any -> Doc Any
rollbackMsg = case Maybe NominalDiffTime
timeSinceLastMsg of
            Maybe NominalDiffTime
Nothing -> Doc Any -> Doc Any
forall a. a -> a
id
            Just NominalDiffTime
t -> \Doc Any
k ->
              ( case Int
syncStatsNumRollbacks of
                  Int
0 -> Doc Any
"No"
                  Int
_ -> Int -> Doc Any
forall a ann. Pretty a => a -> Doc ann
pretty Int
syncStatsNumRollbacks
              )
                Doc Any -> Doc Any -> Doc Any
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc Any
"rollbacks in the last"
                Doc Any -> Doc Any -> Doc Any
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc Any
forall a ann. Pretty a => a -> Doc ann
pretty (TimeLocale -> String -> NominalDiffTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%s" NominalDiffTime
t)
                Doc Any -> Doc Any -> Doc Any
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc Any
"seconds."
                Doc Any -> Doc Any -> Doc Any
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc Any
k

      let syncMsg :: Doc Any
syncMsg = case (ChainPoint
cp, ChainTip
ct) of
            (ChainPoint (SlotNo Word64
chainPointSlot) Hash BlockHeader
_, ChainTip (SlotNo Word64
chainTipSlot) Hash BlockHeader
_header BlockNo
_blockNo)
              -- 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.
              | Word64
chainTipSlot Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
chainPointSlot Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
< Word64
100 ->
                Doc Any
"Synchronised."
            (ChainPoint (SlotNo Word64
chainPointSlotNo) Hash BlockHeader
_, ChainTip (SlotNo Word64
chainTipSlotNo) Hash BlockHeader
_header BlockNo
_blockNo) ->
              let pct :: Double
pct = (Double
100 :: Double) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Word64 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
chainPointSlotNo Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Word64 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
chainTipSlotNo
               in String -> Doc Any
forall a ann. Pretty a => a -> Doc ann
pretty
                    ( String -> Word64 -> Word64 -> Double -> String
forall r. PrintfType r => String -> r
printf
                        String
"Synchronising. Current slot %d out of %d (%0.2f%%)."
                        Word64
chainPointSlotNo
                        Word64
chainTipSlotNo
                        Double
pct ::
                        String
                    )
            (ChainPoint, ChainTip)
_ -> Doc Any
"Starting."

      let shouldPrint :: Bool
shouldPrint = case Maybe NominalDiffTime
timeSinceLastMsg of
            Maybe NominalDiffTime
Nothing -> Bool
True
            Just NominalDiffTime
t
              | NominalDiffTime
t NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
> NominalDiffTime
minSecondsBetweenMsg -> Bool
True
              | Bool
otherwise -> Bool
False

      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
shouldPrint (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Trace IO Text -> Text -> IO ()
forall (m :: * -> *) a. MonadIO m => Trace m a -> a -> m ()
logInfo Trace IO Text
tracer (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$
          SimpleDocStream Any -> Text
forall ann. SimpleDocStream ann -> Text
renderStrict (SimpleDocStream Any -> Text) -> SimpleDocStream Any -> Text
forall a b. (a -> b) -> a -> b
$
            LayoutOptions -> Doc Any -> SimpleDocStream Any
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
layoutPretty LayoutOptions
defaultLayoutOptions (Doc Any -> SimpleDocStream Any) -> Doc Any -> SimpleDocStream Any
forall a b. (a -> b) -> a -> b
$
              Doc Any
syncMsg Doc Any -> Doc Any -> Doc Any
forall ann. Doc ann -> Doc ann -> Doc ann
<+> (Doc Any -> Doc Any
blocksMsg (Doc Any -> Doc Any) -> Doc Any -> Doc Any
forall a b. (a -> b) -> a -> b
$ Doc Any -> Doc Any
rollbackMsg (Doc Any -> Doc Any) -> Doc Any -> Doc Any
forall a b. (a -> b) -> a -> b
$ Doc Any
"Last block processed" Doc Any -> Doc Any -> Doc Any
forall ann. Doc ann -> Doc ann -> Doc ann
<+> ChainPoint -> Doc Any
forall a ann. Pretty a => a -> Doc ann
pretty ChainPoint
cp Doc Any -> Doc Any -> Doc Any
forall a. Semigroup a => a -> a -> a
<> Doc Any
".")
        IORef SyncStats -> (SyncStats -> SyncStats) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef SyncStats
statsRef ((SyncStats -> SyncStats) -> IO ())
-> (SyncStats -> SyncStats) -> IO ()
forall a b. (a -> b) -> a -> b
$ \SyncStats
stats ->
          SyncStats
stats
            { syncStatsNumBlocks :: Int
syncStatsNumBlocks = Int
0,
              syncStatsNumRollbacks :: Int
syncStatsNumRollbacks = Int
0,
              syncStatsLastMessage :: Maybe UTCTime
syncStatsLastMessage = UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just UTCTime
now
            }