{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}

module Cardano.Wallet.Network
    (
    -- * Interface
      NetworkLayer (..)

    -- * Errors
    , ErrPostTx (..)

    -- * Chain following
    , ChainFollower (..)
    , mapChainFollower
    , ChainFollowLog (..)
    , ChainSyncLog (..)
    , mapChainSyncLog
    , withFollowStatsMonitoring

    -- * Logging (for testing)
    , FollowStats (..)
    , Rearview (..)
    , emptyStats
    , updateStats
    ) where

import Prelude

import Cardano.Api
    ( AnyCardanoEra )
import Cardano.BM.Data.Severity
    ( Severity (..) )
import Cardano.BM.Data.Tracer
    ( HasPrivacyAnnotation (..), HasSeverityAnnotation (..) )
import Cardano.Wallet.Checkpoints.Policy
    ( CheckpointPolicy )
import Cardano.Wallet.Primitive.BlockSummary
    ( LightSummary )
import Cardano.Wallet.Primitive.Slotting
    ( PastHorizonException, TimeInterpreter )
import Cardano.Wallet.Primitive.SyncProgress
    ( SyncProgress (..) )
import Cardano.Wallet.Primitive.Types
    ( Block
    , BlockHeader (..)
    , ChainPoint (..)
    , ProtocolParameters
    , SlotNo (..)
    , SlottingParameters (..)
    , StakePoolsSummary
    )
import Cardano.Wallet.Primitive.Types.Coin
    ( Coin )
import Cardano.Wallet.Primitive.Types.RewardAccount
    ( RewardAccount (..) )
import Cardano.Wallet.Primitive.Types.Tx
    ( SealedTx )
import Control.Monad.Class.MonadSTM
    ( atomically )
import Control.Monad.Class.MonadSTM.Strict
    ( StrictTMVar, newTMVarIO, putTMVar, takeTMVar )
import Control.Monad.Trans.Except
    ( ExceptT (..) )
import Control.Tracer
    ( Tracer, contramapM, traceWith )
import Data.List.NonEmpty
    ( NonEmpty (..) )
import Data.Map
    ( Map )
import Data.Set
    ( Set )
import Data.Text
    ( Text )
import Data.Text.Class
    ( ToText (..) )
import Data.Time.Clock
    ( UTCTime, diffUTCTime, getCurrentTime )
import Fmt
    ( pretty )
import GHC.Generics
    ( Generic )
import NoThunks.Class
    ( AllowThunksIn (..), NoThunks (..) )
import Numeric.Natural
    ( Natural )
import Safe
    ( headMay )
import UnliftIO.Async
    ( race_ )
import UnliftIO.Concurrent
    ( threadDelay )

import qualified Data.List.NonEmpty as NE

{-------------------------------------------------------------------------------
    ChainSync
-------------------------------------------------------------------------------}
-- | Interface for network capabilities.
data NetworkLayer m block = NetworkLayer
    { NetworkLayer m block
-> Tracer IO ChainFollowLog
-> ChainFollower m ChainPoint BlockHeader (NonEmpty block)
-> m ()
chainSync
        :: Tracer IO ChainFollowLog
        -> ChainFollower m ChainPoint BlockHeader (NonEmpty block)
        -> m ()
        -- ^ Connect to the node and run the ChainSync protocol.
        -- The callbacks provided in the 'ChainFollower' argument
        -- are used to handle intersection finding,
        -- the arrival of new blocks, and rollbacks.

    , NetworkLayer m block
-> Maybe
     (ChainFollower m ChainPoint BlockHeader (LightBlocks m Block)
      -> m ())
lightSync
        :: Maybe (
            ChainFollower m ChainPoint BlockHeader (LightBlocks m Block)
            -> m ()
          )
        -- ^ Connect to a data source that offers an efficient
        -- query @Address -> Transactions@.

    , NetworkLayer m block -> m BlockHeader
currentNodeTip
        :: m BlockHeader
        -- ^ Get the current tip from the chain producer

    , NetworkLayer m block -> m AnyCardanoEra
currentNodeEra
        :: m AnyCardanoEra
        -- ^ Get the era the node is currently in.

    , NetworkLayer m block -> m ProtocolParameters
currentProtocolParameters
        :: m ProtocolParameters
        -- ^ Get the last known protocol parameters. In principle, these can
        -- only change once per epoch.

    , NetworkLayer m block -> m SlottingParameters
currentSlottingParameters
        :: m SlottingParameters
        -- ^ Get the last known slotting parameters. In principle, these can
        -- only change once per era.

    , NetworkLayer m block -> (BlockHeader -> m ()) -> m ()
watchNodeTip
        :: (BlockHeader -> m ())
        -> m ()
        -- ^ Register a callback for when the node tip changes.
        -- This function should never finish, unless the callback throws an
        -- exception, which will be rethrown by this function.

    , NetworkLayer m block -> SealedTx -> ExceptT ErrPostTx m ()
postTx
        :: SealedTx -> ExceptT ErrPostTx m ()
        -- ^ Broadcast a transaction to the chain producer

    , NetworkLayer m block -> Coin -> m StakePoolsSummary
stakeDistribution
        :: Coin -- Stake to consider for rewards
        -> m StakePoolsSummary

    , NetworkLayer m block -> RewardAccount -> m Coin
getCachedRewardAccountBalance
        :: RewardAccount
        -> m Coin
        -- ^ Return the cached reward balance of an account.
        --
        -- If there is no cached value, it will return `Coin 0`, and add the
        -- account to the internal set of observed account, such that it will be
        -- fetched later.

    , NetworkLayer m block
-> Set RewardAccount -> m (Map RewardAccount Coin)
fetchRewardAccountBalances
        :: Set RewardAccount
        -> m (Map RewardAccount Coin)
        -- ^ Fetch the reward account balance of a set of accounts without
        -- any caching.

    , NetworkLayer m block
-> TimeInterpreter (ExceptT PastHorizonException m)
timeInterpreter
        :: TimeInterpreter (ExceptT PastHorizonException m)

    , NetworkLayer m block -> SlotNo -> m SyncProgress
syncProgress
        :: SlotNo -> m (SyncProgress)
        -- ^ Compute the ratio between the provided 'SlotNo' and the slot
        -- corresponding to the current wall-clock time.
        --
        -- Unlike using 'Cardano.Wallet.Primitive.SyncProgress.syncProgress'
        -- after retrieving a 'timeInterpreter', this function will return
        -- 'NotResponding' rather than block in the edge case when the era
        -- history has not yet been fetched from the node on startup.
    }

-- | In light-mode, we receive either a list of blocks as usual,
-- or a 'LightSummary' of blocks.
type LightBlocks m block = Either (NonEmpty block) (LightSummary m)

instance Functor m => Functor (NetworkLayer m) where
    fmap :: (a -> b) -> NetworkLayer m a -> NetworkLayer m b
fmap a -> b
f NetworkLayer m a
nl = NetworkLayer m a
nl
        { chainSync :: Tracer IO ChainFollowLog
-> ChainFollower m ChainPoint BlockHeader (NonEmpty b) -> m ()
chainSync = \Tracer IO ChainFollowLog
tr ChainFollower m ChainPoint BlockHeader (NonEmpty b)
follower ->
            NetworkLayer m a
-> Tracer IO ChainFollowLog
-> ChainFollower m ChainPoint BlockHeader (NonEmpty a)
-> m ()
forall (m :: * -> *) block.
NetworkLayer m block
-> Tracer IO ChainFollowLog
-> ChainFollower m ChainPoint BlockHeader (NonEmpty block)
-> m ()
chainSync NetworkLayer m a
nl Tracer IO ChainFollowLog
tr (ChainFollower m ChainPoint BlockHeader (NonEmpty a) -> m ())
-> ChainFollower m ChainPoint BlockHeader (NonEmpty a) -> m ()
forall a b. (a -> b) -> a -> b
$ (ChainPoint -> ChainPoint)
-> (ChainPoint -> ChainPoint)
-> (BlockHeader -> BlockHeader)
-> (NonEmpty a -> NonEmpty b)
-> ChainFollower m ChainPoint BlockHeader (NonEmpty b)
-> ChainFollower m ChainPoint BlockHeader (NonEmpty a)
forall (m :: * -> *) point1 point2 tip2 tip1 blocks2 blocks1.
Functor m =>
(point1 -> point2)
-> (point2 -> point1)
-> (tip2 -> tip1)
-> (blocks2 -> blocks1)
-> ChainFollower m point1 tip1 blocks1
-> ChainFollower m point2 tip2 blocks2
mapChainFollower ChainPoint -> ChainPoint
forall a. a -> a
id ChainPoint -> ChainPoint
forall a. a -> a
id BlockHeader -> BlockHeader
forall a. a -> a
id ((a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) ChainFollower m ChainPoint BlockHeader (NonEmpty b)
follower
        }

-- | A collection of callbacks to use with the 'chainSync' function.
data ChainFollower m point tip blocks = ChainFollower
    { ChainFollower m point tip blocks -> Integer -> CheckpointPolicy
checkpointPolicy :: Integer -> CheckpointPolicy
        -- ^ The policy for creating and pruning checkpoints that
        -- is used by the 'ChainFollower'.
        -- The argument of this field is the @epochStability@.
        --
        -- Exposing this policy here enables any chain synchronizer
        -- which does not retrieve full blocks, such as 'lightSync',
        -- to specifically target those block heights at which
        -- the 'ChainFollower' intends to create checkpoints.

    , ChainFollower m point tip blocks -> m [point]
readChainPoints :: m [point]
        -- ^ Callback for reading the local tip. Used to negotiate the
        -- intersection with the node.
        --
        -- A response of [] is interpreted as `Origin` -- i.e. the chain will be
        -- served from genesis.

    , ChainFollower m point tip blocks -> blocks -> tip -> m ()
rollForward :: blocks -> tip -> m ()
        -- ^ Callback for rolling forward.
        --
        -- Implementors _may_ delete old checkpoints while rolling forward.

    , ChainFollower m point tip blocks -> point -> m point
rollBackward :: point -> m point
        -- ^ Roll back to the requested slot, or further, and return the point
        -- actually rolled back to.
        --
        -- __Example 1:__
        --
        -- If the follower stores checkpoints for all blocks, we can always roll
        -- back to the requested point exactly.
        --
        -- @
        -- -- If
        -- knownSlots follower `shouldReturn` [0,1,2,3]
        -- let requested = SlotNo 2
        -- -- Then
        -- actual <- rollBackward follower requested
        -- knownSlots follower shouldReturn` [0,1,2]
        -- actual `shouldBe` SlotNo 2
        -- @
        --
        -- Note that the slotNos are unlikely to be consecutive in real life,
        -- but this doesn't matter, as ouroboros-network asks us to rollback to
        -- points, corresponding to blocks.
        --
        -- __Example 2:__
        --
        -- @
        -- -- If
        -- knownSlots follower `shouldReturn` [0,9,10]
        -- let requested = SlotNo 2
        -- -- Then
        -- actual <- rollBackward follower requested
        -- knownSlots follower shouldReturn` [0]
        -- actual `shouldBe` SlotNo 0
        -- @
        --
    }

mapChainFollower
    :: Functor m
    => (point1 -> point2) -- ^ Covariant
    -> (point2 -> point1) -- ^ Contravariant
    -> (tip2 -> tip1) -- ^ Contravariant
    -> (blocks2 -> blocks1) -- ^ Contravariant
    -> ChainFollower m point1 tip1 blocks1
    -> ChainFollower m point2 tip2 blocks2
mapChainFollower :: (point1 -> point2)
-> (point2 -> point1)
-> (tip2 -> tip1)
-> (blocks2 -> blocks1)
-> ChainFollower m point1 tip1 blocks1
-> ChainFollower m point2 tip2 blocks2
mapChainFollower point1 -> point2
fpoint12 point2 -> point1
fpoint21 tip2 -> tip1
ftip blocks2 -> blocks1
fblocks ChainFollower m point1 tip1 blocks1
cf =
    ChainFollower :: forall (m :: * -> *) point tip blocks.
(Integer -> CheckpointPolicy)
-> m [point]
-> (blocks -> tip -> m ())
-> (point -> m point)
-> ChainFollower m point tip blocks
ChainFollower
        { checkpointPolicy :: Integer -> CheckpointPolicy
checkpointPolicy = ChainFollower m point1 tip1 blocks1 -> Integer -> CheckpointPolicy
forall (m :: * -> *) point tip blocks.
ChainFollower m point tip blocks -> Integer -> CheckpointPolicy
checkpointPolicy ChainFollower m point1 tip1 blocks1
cf
        , readChainPoints :: m [point2]
readChainPoints = (point1 -> point2) -> [point1] -> [point2]
forall a b. (a -> b) -> [a] -> [b]
map point1 -> point2
fpoint12 ([point1] -> [point2]) -> m [point1] -> m [point2]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChainFollower m point1 tip1 blocks1 -> m [point1]
forall (m :: * -> *) point tip blocks.
ChainFollower m point tip blocks -> m [point]
readChainPoints ChainFollower m point1 tip1 blocks1
cf
        , rollForward :: blocks2 -> tip2 -> m ()
rollForward = \blocks2
bs tip2
tip -> ChainFollower m point1 tip1 blocks1 -> blocks1 -> tip1 -> m ()
forall (m :: * -> *) point tip blocks.
ChainFollower m point tip blocks -> blocks -> tip -> m ()
rollForward ChainFollower m point1 tip1 blocks1
cf (blocks2 -> blocks1
fblocks blocks2
bs) (tip2 -> tip1
ftip tip2
tip)
        , rollBackward :: point2 -> m point2
rollBackward = (point1 -> point2) -> m point1 -> m point2
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap point1 -> point2
fpoint12 (m point1 -> m point2)
-> (point2 -> m point1) -> point2 -> m point2
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainFollower m point1 tip1 blocks1 -> point1 -> m point1
forall (m :: * -> *) point tip blocks.
ChainFollower m point tip blocks -> point -> m point
rollBackward ChainFollower m point1 tip1 blocks1
cf (point1 -> m point1) -> (point2 -> point1) -> point2 -> m point1
forall b c a. (b -> c) -> (a -> b) -> a -> c
. point2 -> point1
fpoint21
        }

{-------------------------------------------------------------------------------
    Errors
-------------------------------------------------------------------------------}

-- | Error while trying to send a transaction
newtype ErrPostTx = ErrPostTxValidationError Text
    deriving ((forall x. ErrPostTx -> Rep ErrPostTx x)
-> (forall x. Rep ErrPostTx x -> ErrPostTx) -> Generic ErrPostTx
forall x. Rep ErrPostTx x -> ErrPostTx
forall x. ErrPostTx -> Rep ErrPostTx x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ErrPostTx x -> ErrPostTx
$cfrom :: forall x. ErrPostTx -> Rep ErrPostTx x
Generic, Int -> ErrPostTx -> ShowS
[ErrPostTx] -> ShowS
ErrPostTx -> String
(Int -> ErrPostTx -> ShowS)
-> (ErrPostTx -> String)
-> ([ErrPostTx] -> ShowS)
-> Show ErrPostTx
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ErrPostTx] -> ShowS
$cshowList :: [ErrPostTx] -> ShowS
show :: ErrPostTx -> String
$cshow :: ErrPostTx -> String
showsPrec :: Int -> ErrPostTx -> ShowS
$cshowsPrec :: Int -> ErrPostTx -> ShowS
Show, ErrPostTx -> ErrPostTx -> Bool
(ErrPostTx -> ErrPostTx -> Bool)
-> (ErrPostTx -> ErrPostTx -> Bool) -> Eq ErrPostTx
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ErrPostTx -> ErrPostTx -> Bool
$c/= :: ErrPostTx -> ErrPostTx -> Bool
== :: ErrPostTx -> ErrPostTx -> Bool
$c== :: ErrPostTx -> ErrPostTx -> Bool
Eq)

instance ToText ErrPostTx where
    toText :: ErrPostTx -> Text
toText = \case
        ErrPostTxValidationError Text
msg -> Text
msg

{-------------------------------------------------------------------------------
    Logging
-------------------------------------------------------------------------------}

-- | Low-level logs of the ChainSync mini-protocol
data ChainSyncLog block point
    = MsgChainFindIntersect [point]
    | MsgChainRollForward (NonEmpty block) point
    | MsgChainRollBackward point Int
    | MsgChainTip point
    | MsgLocalTip point
    | MsgTipDistance Natural
    deriving (Int -> ChainSyncLog block point -> ShowS
[ChainSyncLog block point] -> ShowS
ChainSyncLog block point -> String
(Int -> ChainSyncLog block point -> ShowS)
-> (ChainSyncLog block point -> String)
-> ([ChainSyncLog block point] -> ShowS)
-> Show (ChainSyncLog block point)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall block point.
(Show point, Show block) =>
Int -> ChainSyncLog block point -> ShowS
forall block point.
(Show point, Show block) =>
[ChainSyncLog block point] -> ShowS
forall block point.
(Show point, Show block) =>
ChainSyncLog block point -> String
showList :: [ChainSyncLog block point] -> ShowS
$cshowList :: forall block point.
(Show point, Show block) =>
[ChainSyncLog block point] -> ShowS
show :: ChainSyncLog block point -> String
$cshow :: forall block point.
(Show point, Show block) =>
ChainSyncLog block point -> String
showsPrec :: Int -> ChainSyncLog block point -> ShowS
$cshowsPrec :: forall block point.
(Show point, Show block) =>
Int -> ChainSyncLog block point -> ShowS
Show, ChainSyncLog block point -> ChainSyncLog block point -> Bool
(ChainSyncLog block point -> ChainSyncLog block point -> Bool)
-> (ChainSyncLog block point -> ChainSyncLog block point -> Bool)
-> Eq (ChainSyncLog block point)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall block point.
(Eq point, Eq block) =>
ChainSyncLog block point -> ChainSyncLog block point -> Bool
/= :: ChainSyncLog block point -> ChainSyncLog block point -> Bool
$c/= :: forall block point.
(Eq point, Eq block) =>
ChainSyncLog block point -> ChainSyncLog block point -> Bool
== :: ChainSyncLog block point -> ChainSyncLog block point -> Bool
$c== :: forall block point.
(Eq point, Eq block) =>
ChainSyncLog block point -> ChainSyncLog block point -> Bool
Eq, (forall x.
 ChainSyncLog block point -> Rep (ChainSyncLog block point) x)
-> (forall x.
    Rep (ChainSyncLog block point) x -> ChainSyncLog block point)
-> Generic (ChainSyncLog block point)
forall x.
Rep (ChainSyncLog block point) x -> ChainSyncLog block point
forall x.
ChainSyncLog block point -> Rep (ChainSyncLog block point) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall block point x.
Rep (ChainSyncLog block point) x -> ChainSyncLog block point
forall block point x.
ChainSyncLog block point -> Rep (ChainSyncLog block point) x
$cto :: forall block point x.
Rep (ChainSyncLog block point) x -> ChainSyncLog block point
$cfrom :: forall block point x.
ChainSyncLog block point -> Rep (ChainSyncLog block point) x
Generic)

mapChainSyncLog
    :: (b1 -> b2)
    -> (p1 -> p2)
    -> ChainSyncLog b1 p1
    -> ChainSyncLog b2 p2
mapChainSyncLog :: (b1 -> b2)
-> (p1 -> p2) -> ChainSyncLog b1 p1 -> ChainSyncLog b2 p2
mapChainSyncLog b1 -> b2
f p1 -> p2
g = \case
    MsgChainFindIntersect [p1]
points -> [p2] -> ChainSyncLog b2 p2
forall block point. [point] -> ChainSyncLog block point
MsgChainFindIntersect (p1 -> p2
g (p1 -> p2) -> [p1] -> [p2]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [p1]
points)
    MsgChainRollForward NonEmpty b1
blocks p1
tip ->
        NonEmpty b2 -> p2 -> ChainSyncLog b2 p2
forall block point.
NonEmpty block -> point -> ChainSyncLog block point
MsgChainRollForward (b1 -> b2
f (b1 -> b2) -> NonEmpty b1 -> NonEmpty b2
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty b1
blocks) (p1 -> p2
g p1
tip)
    MsgChainRollBackward p1
point Int
n -> p2 -> Int -> ChainSyncLog b2 p2
forall block point. point -> Int -> ChainSyncLog block point
MsgChainRollBackward (p1 -> p2
g p1
point) Int
n
    MsgChainTip p1
point -> p2 -> ChainSyncLog b2 p2
forall block point. point -> ChainSyncLog block point
MsgChainTip (p1 -> p2
g p1
point)
    MsgLocalTip p1
point -> p2 -> ChainSyncLog b2 p2
forall block point. point -> ChainSyncLog block point
MsgLocalTip (p1 -> p2
g p1
point)
    MsgTipDistance Natural
d -> Natural -> ChainSyncLog b2 p2
forall block point. Natural -> ChainSyncLog block point
MsgTipDistance Natural
d

instance ToText (ChainSyncLog BlockHeader ChainPoint) where
    toText :: ChainSyncLog BlockHeader ChainPoint -> Text
toText = \case
        MsgChainFindIntersect [ChainPoint]
cps -> [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
            [ Text
"Requesting intersection using "
            , Int -> Text
forall a. ToText a => a -> Text
toText ([ChainPoint] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ChainPoint]
cps)
            , Text
" points"
            , Text -> (ChainPoint -> Text) -> Maybe ChainPoint -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" ((Text
", the latest being " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text) -> (ChainPoint -> Text) -> ChainPoint -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainPoint -> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty) ([ChainPoint] -> Maybe ChainPoint
forall a. [a] -> Maybe a
headMay [ChainPoint]
cps)
            ]
        MsgChainRollForward NonEmpty BlockHeader
headers ChainPoint
tip ->
            let buildRange :: NonEmpty a -> a
buildRange (a
x :| []) = a
x
                buildRange NonEmpty a
xs = NonEmpty a -> a
forall a. NonEmpty a -> a
NE.head NonEmpty a
xs a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
".." a -> a -> a
forall a. Semigroup a => a -> a -> a
<> NonEmpty a -> a
forall a. NonEmpty a -> a
NE.last NonEmpty a
xs
                slots :: NonEmpty Text
slots = SlotNo -> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty (SlotNo -> Text) -> (BlockHeader -> SlotNo) -> BlockHeader -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockHeader -> SlotNo
slotNo (BlockHeader -> Text) -> NonEmpty BlockHeader -> NonEmpty Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty BlockHeader
headers
            in [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
                [ Text
"ChainSync roll forward: "
                , Text
"applying blocks at slots [", NonEmpty Text -> Text
forall a. (Semigroup a, IsString a) => NonEmpty a -> a
buildRange NonEmpty Text
slots, Text
"]"
                , Text
", tip is "
                , ChainPoint -> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty ChainPoint
tip
                ]
        MsgChainRollBackward ChainPoint
b Int
0 ->
            Text
"ChainSync roll backward: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ChainPoint -> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty ChainPoint
b
        MsgChainRollBackward ChainPoint
b Int
bufferSize -> [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
            [ Text
"ChainSync roll backward: "
            , ChainPoint -> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty ChainPoint
b
            , Text
", handled inside pipeline buffer with remaining length "
            , Int -> Text
forall a. ToText a => a -> Text
toText Int
bufferSize
            ]
        MsgChainTip ChainPoint
tip ->
            Text
"Node tip is " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ChainPoint -> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty ChainPoint
tip
        MsgLocalTip ChainPoint
point ->
            Text
"Synchronized with point: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ChainPoint -> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty ChainPoint
point
        MsgTipDistance Natural
d -> Text
"Distance to chain tip: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Natural -> Text
forall a. ToText a => a -> Text
toText Natural
d Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" blocks"

instance HasPrivacyAnnotation (ChainSyncLog block point)

instance HasSeverityAnnotation (ChainSyncLog block point) where
    getSeverityAnnotation :: ChainSyncLog block point -> Severity
getSeverityAnnotation = \case
        MsgChainFindIntersect{} -> Severity
Debug
        MsgChainRollForward{} -> Severity
Debug
        MsgChainRollBackward{} -> Severity
Debug
        MsgChainTip{} -> Severity
Debug
        MsgLocalTip{} -> Severity
Debug
        MsgTipDistance{} -> Severity
Debug

-- | Higher level log of a chain follower.
-- Includes computed statistics about synchronization progress.
data ChainFollowLog
    = MsgChainSync (ChainSyncLog BlockHeader ChainPoint)
    | MsgFollowStats (FollowStats Rearview)
    | MsgStartFollowing
    deriving (Int -> ChainFollowLog -> ShowS
[ChainFollowLog] -> ShowS
ChainFollowLog -> String
(Int -> ChainFollowLog -> ShowS)
-> (ChainFollowLog -> String)
-> ([ChainFollowLog] -> ShowS)
-> Show ChainFollowLog
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ChainFollowLog] -> ShowS
$cshowList :: [ChainFollowLog] -> ShowS
show :: ChainFollowLog -> String
$cshow :: ChainFollowLog -> String
showsPrec :: Int -> ChainFollowLog -> ShowS
$cshowsPrec :: Int -> ChainFollowLog -> ShowS
Show, ChainFollowLog -> ChainFollowLog -> Bool
(ChainFollowLog -> ChainFollowLog -> Bool)
-> (ChainFollowLog -> ChainFollowLog -> Bool) -> Eq ChainFollowLog
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ChainFollowLog -> ChainFollowLog -> Bool
$c/= :: ChainFollowLog -> ChainFollowLog -> Bool
== :: ChainFollowLog -> ChainFollowLog -> Bool
$c== :: ChainFollowLog -> ChainFollowLog -> Bool
Eq, (forall x. ChainFollowLog -> Rep ChainFollowLog x)
-> (forall x. Rep ChainFollowLog x -> ChainFollowLog)
-> Generic ChainFollowLog
forall x. Rep ChainFollowLog x -> ChainFollowLog
forall x. ChainFollowLog -> Rep ChainFollowLog x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ChainFollowLog x -> ChainFollowLog
$cfrom :: forall x. ChainFollowLog -> Rep ChainFollowLog x
Generic)

instance ToText ChainFollowLog where
    toText :: ChainFollowLog -> Text
toText = \case
        MsgChainSync ChainSyncLog BlockHeader ChainPoint
msg -> ChainSyncLog BlockHeader ChainPoint -> Text
forall a. ToText a => a -> Text
toText ChainSyncLog BlockHeader ChainPoint
msg
        MsgFollowStats FollowStats Rearview
s -> FollowStats Rearview -> Text
forall a. ToText a => a -> Text
toText FollowStats Rearview
s
        ChainFollowLog
MsgStartFollowing -> Text
"Chain following starting."

instance HasPrivacyAnnotation ChainFollowLog
instance HasSeverityAnnotation ChainFollowLog where
    getSeverityAnnotation :: ChainFollowLog -> Severity
getSeverityAnnotation = \case
        MsgChainSync ChainSyncLog BlockHeader ChainPoint
msg -> ChainSyncLog BlockHeader ChainPoint -> Severity
forall a. HasSeverityAnnotation a => a -> Severity
getSeverityAnnotation ChainSyncLog BlockHeader ChainPoint
msg
        MsgFollowStats FollowStats Rearview
s -> FollowStats Rearview -> Severity
forall a. HasSeverityAnnotation a => a -> Severity
getSeverityAnnotation FollowStats Rearview
s
        ChainFollowLog
MsgStartFollowing -> Severity
Info

{-------------------------------------------------------------------------------
    Log aggregation
-------------------------------------------------------------------------------}
-- | Statistics of interest from the follow-function.
--
-- The @f@ allows us to use 'Rearview' to keep track of both current and
-- previously logged stats, and perform operations over it in a nice way.
data FollowStats f = FollowStats
    { FollowStats f -> f Int
blocksApplied :: !(f Int)
    , FollowStats f -> f Int
rollbacks :: !(f Int)
    , FollowStats f -> f ChainPoint
localTip :: !(f ChainPoint)
    , FollowStats f -> f UTCTime
time :: !(f UTCTime)
      -- ^ NOTE: Current time is not updated until @flush@ is called.
    , FollowStats f -> f SyncProgress
prog :: !(f SyncProgress)
      -- ^ NOTE: prog is not updated until @flush@ is called.
    } deriving ((forall x. FollowStats f -> Rep (FollowStats f) x)
-> (forall x. Rep (FollowStats f) x -> FollowStats f)
-> Generic (FollowStats f)
forall x. Rep (FollowStats f) x -> FollowStats f
forall x. FollowStats f -> Rep (FollowStats f) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (f :: * -> *) x. Rep (FollowStats f) x -> FollowStats f
forall (f :: * -> *) x. FollowStats f -> Rep (FollowStats f) x
$cto :: forall (f :: * -> *) x. Rep (FollowStats f) x -> FollowStats f
$cfrom :: forall (f :: * -> *) x. FollowStats f -> Rep (FollowStats f) x
Generic)

-- It seems UTCTime contains thunks internally. This shouldn't matter as we
-- 1. Change it seldom - from @flush@, not from @updateStats@
-- 2. Set to a completely new value when we do change it.
deriving via (AllowThunksIn '["time"] (FollowStats Rearview))
    instance (NoThunks (FollowStats Rearview))

deriving instance Show (FollowStats Rearview)
deriving instance Eq (FollowStats Rearview)

-- | Change the @f@ wrapping each record field.
hoistStats
    :: (forall a. f a -> g a)
    -> FollowStats f
    -> FollowStats g
hoistStats :: (forall a. f a -> g a) -> FollowStats f -> FollowStats g
hoistStats forall a. f a -> g a
f (FollowStats f Int
a f Int
b f ChainPoint
c f UTCTime
d f SyncProgress
e) =
    g Int
-> g Int
-> g ChainPoint
-> g UTCTime
-> g SyncProgress
-> FollowStats g
forall (f :: * -> *).
f Int
-> f Int
-> f ChainPoint
-> f UTCTime
-> f SyncProgress
-> FollowStats f
FollowStats (f Int -> g Int
forall a. f a -> g a
f f Int
a) (f Int -> g Int
forall a. f a -> g a
f f Int
b) (f ChainPoint -> g ChainPoint
forall a. f a -> g a
f f ChainPoint
c) (f UTCTime -> g UTCTime
forall a. f a -> g a
f f UTCTime
d) (f SyncProgress -> g SyncProgress
forall a. f a -> g a
f f SyncProgress
e)

-- | A 'Rearview' consists of a past value and a present value.
-- Useful for keeping track of past logs.
--
-- The idea is to
-- 1. Reconstruct a model of the @current@ @state@ using a @Trace@
-- 2. Sometimes log the difference between the @current@ state and the most
-- recently logged one.
data Rearview a = Rearview
    { Rearview a -> a
past :: !a -- ^ Most previously logged state
    , Rearview a -> a
current :: !a -- ^ Not-yet logged state
    } deriving (Rearview a -> Rearview a -> Bool
(Rearview a -> Rearview a -> Bool)
-> (Rearview a -> Rearview a -> Bool) -> Eq (Rearview a)
forall a. Eq a => Rearview a -> Rearview a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Rearview a -> Rearview a -> Bool
$c/= :: forall a. Eq a => Rearview a -> Rearview a -> Bool
== :: Rearview a -> Rearview a -> Bool
$c== :: forall a. Eq a => Rearview a -> Rearview a -> Bool
Eq, Int -> Rearview a -> ShowS
[Rearview a] -> ShowS
Rearview a -> String
(Int -> Rearview a -> ShowS)
-> (Rearview a -> String)
-> ([Rearview a] -> ShowS)
-> Show (Rearview a)
forall a. Show a => Int -> Rearview a -> ShowS
forall a. Show a => [Rearview a] -> ShowS
forall a. Show a => Rearview a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Rearview a] -> ShowS
$cshowList :: forall a. Show a => [Rearview a] -> ShowS
show :: Rearview a -> String
$cshow :: forall a. Show a => Rearview a -> String
showsPrec :: Int -> Rearview a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Rearview a -> ShowS
Show, a -> Rearview b -> Rearview a
(a -> b) -> Rearview a -> Rearview b
(forall a b. (a -> b) -> Rearview a -> Rearview b)
-> (forall a b. a -> Rearview b -> Rearview a) -> Functor Rearview
forall a b. a -> Rearview b -> Rearview a
forall a b. (a -> b) -> Rearview a -> Rearview b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Rearview b -> Rearview a
$c<$ :: forall a b. a -> Rearview b -> Rearview a
fmap :: (a -> b) -> Rearview a -> Rearview b
$cfmap :: forall a b. (a -> b) -> Rearview a -> Rearview b
Functor, (forall x. Rearview a -> Rep (Rearview a) x)
-> (forall x. Rep (Rearview a) x -> Rearview a)
-> Generic (Rearview a)
forall x. Rep (Rearview a) x -> Rearview a
forall x. Rearview a -> Rep (Rearview a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (Rearview a) x -> Rearview a
forall a x. Rearview a -> Rep (Rearview a) x
$cto :: forall a x. Rep (Rearview a) x -> Rearview a
$cfrom :: forall a x. Rearview a -> Rep (Rearview a) x
Generic)

instance NoThunks a => NoThunks (Rearview a)

initRearview :: a -> Rearview a
initRearview :: a -> Rearview a
initRearview a
a = a -> a -> Rearview a
forall a. a -> a -> Rearview a
Rearview a
a a
a

-- | Modify the present state of a @Rearview state@
overCurrent :: (a -> a) -> Rearview a -> Rearview a
overCurrent :: (a -> a) -> Rearview a -> Rearview a
overCurrent a -> a
f (Rearview a
pas a
cur) = a -> a -> Rearview a
forall a. a -> a -> Rearview a
Rearview a
pas (a -> a
f a
cur)

emptyStats :: UTCTime -> FollowStats Rearview
emptyStats :: UTCTime -> FollowStats Rearview
emptyStats UTCTime
t = Rearview Int
-> Rearview Int
-> Rearview ChainPoint
-> Rearview UTCTime
-> Rearview SyncProgress
-> FollowStats Rearview
forall (f :: * -> *).
f Int
-> f Int
-> f ChainPoint
-> f UTCTime
-> f SyncProgress
-> FollowStats f
FollowStats (Int -> Rearview Int
forall a. a -> Rearview a
f Int
0) (Int -> Rearview Int
forall a. a -> Rearview a
f Int
0) (ChainPoint -> Rearview ChainPoint
forall a. a -> Rearview a
f ChainPoint
ChainPointAtGenesis) (UTCTime -> Rearview UTCTime
forall a. a -> Rearview a
f UTCTime
t) (SyncProgress -> Rearview SyncProgress
forall a. a -> Rearview a
f SyncProgress
p)
  where
    f :: a -> Rearview a
f = a -> Rearview a
forall a. a -> Rearview a
initRearview
    p :: SyncProgress
p = SyncProgress
NotResponding -- Hijacked as an initial value for simplicity.

-- | Update the current statistics based on a new log message.
updateStats
    :: ChainSyncLog block ChainPoint
    -> FollowStats Rearview -> FollowStats Rearview
updateStats :: ChainSyncLog block ChainPoint
-> FollowStats Rearview -> FollowStats Rearview
updateStats ChainSyncLog block ChainPoint
msg FollowStats Rearview
s = case ChainSyncLog block ChainPoint
msg of
    MsgChainRollForward NonEmpty block
blocks ChainPoint
_tip ->
        FollowStats Rearview
s { blocksApplied :: Rearview Int
blocksApplied = (Int -> Int) -> Rearview Int -> Rearview Int
forall a. (a -> a) -> Rearview a -> Rearview a
overCurrent (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ NonEmpty block -> Int
forall a. NonEmpty a -> Int
NE.length NonEmpty block
blocks) (FollowStats Rearview -> Rearview Int
forall (f :: * -> *). FollowStats f -> f Int
blocksApplied FollowStats Rearview
s) }
    MsgChainRollBackward ChainPoint
_ Int
0 ->
        -- rolled back in a way that could not be handled by the pipeline buffer
        FollowStats Rearview
s { rollbacks :: Rearview Int
rollbacks = (Int -> Int) -> Rearview Int -> Rearview Int
forall a. (a -> a) -> Rearview a -> Rearview a
overCurrent (Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+) (FollowStats Rearview -> Rearview Int
forall (f :: * -> *). FollowStats f -> f Int
rollbacks FollowStats Rearview
s) }
    MsgLocalTip ChainPoint
point ->
        FollowStats Rearview
s { localTip :: Rearview ChainPoint
localTip = (ChainPoint -> ChainPoint)
-> Rearview ChainPoint -> Rearview ChainPoint
forall a. (a -> a) -> Rearview a -> Rearview a
overCurrent (ChainPoint -> ChainPoint -> ChainPoint
forall a b. a -> b -> a
const ChainPoint
point) (FollowStats Rearview -> Rearview ChainPoint
forall (f :: * -> *). FollowStats f -> f ChainPoint
localTip FollowStats Rearview
s) }
    ChainSyncLog block ChainPoint
_ -> FollowStats Rearview
s

instance ToText (FollowStats Rearview) where
    toText :: FollowStats Rearview -> Text
toText st :: FollowStats Rearview
st@(FollowStats Rearview Int
b Rearview Int
r Rearview ChainPoint
tip Rearview UTCTime
t Rearview SyncProgress
progress) =
        Text
syncStatus Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
stats Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
sevExpl
      where
        syncStatus :: Text
syncStatus = case Rearview SyncProgress
progress of
            Rearview SyncProgress
NotResponding SyncProgress
Ready ->
                Text
"In sync."
            Rearview SyncProgress
Ready SyncProgress
Ready ->
                Text
"Still in sync."
            Rearview SyncProgress
NotResponding SyncProgress
NotResponding ->
                Text
"Still not syncing."
            Rearview (Syncing Quantity "percent" Percentage
_p) SyncProgress
Ready ->
                Text
"In sync!"
            Rearview SyncProgress
Ready (Syncing Quantity "percent" Percentage
p) ->
                Text
"Fell out of sync (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (Quantity "percent" Percentage -> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty Quantity "percent" Percentage
p) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
            Rearview SyncProgress
_ (Syncing Quantity "percent" Percentage
p) ->
                Text
"Syncing (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (Quantity "percent" Percentage -> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty Quantity "percent" Percentage
p) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
            Rearview SyncProgress
past_ SyncProgress
NotResponding ->
                Text
"Not responding. Previously " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (SyncProgress -> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty SyncProgress
past_) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"."
        stats :: Text
stats = [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
            [ Text
"Applied " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty ((Int -> Int -> Int) -> Rearview Int -> Int
forall t t. (t -> t -> t) -> Rearview t -> t
using (-) Rearview Int
b) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" blocks, "
            , Int -> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty ((Int -> Int -> Int) -> Rearview Int -> Int
forall t t. (t -> t -> t) -> Rearview t -> t
using (-) Rearview Int
r) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" rollbacks "
            , Text
"in the last " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> NominalDiffTime -> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty ((UTCTime -> UTCTime -> NominalDiffTime)
-> Rearview UTCTime -> NominalDiffTime
forall t t. (t -> t -> t) -> Rearview t -> t
using UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime Rearview UTCTime
t) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
". "
            , Text
"Current tip is " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ChainPoint -> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty (Rearview ChainPoint -> ChainPoint
forall a. Rearview a -> a
current Rearview ChainPoint
tip) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"."
            ]
          where
            using :: (t -> t -> t) -> Rearview t -> t
using t -> t -> t
f Rearview t
x = t -> t -> t
f (Rearview t -> t
forall a. Rearview a -> a
current Rearview t
x) (Rearview t -> t
forall a. Rearview a -> a
past Rearview t
x)

        sevExpl :: Text
sevExpl = Text -> (Text -> Text) -> Maybe Text -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
            Text
""
            (\Text
x -> Text
" (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
            ((Severity, Maybe Text) -> Maybe Text
forall a b. (a, b) -> b
snd ((Severity, Maybe Text) -> Maybe Text)
-> (Severity, Maybe Text) -> Maybe Text
forall a b. (a -> b) -> a -> b
$ FollowStats Rearview -> (Severity, Maybe Text)
explainedSeverityAnnotation FollowStats Rearview
st)

-- NOTE: Here we check if the sync progress is going backwards, which
-- would be a sign the wallet is overloaded (or rollbacks)
--
-- But this check might be in the wrong place. Might be better to
-- produce new logs from inside the updateStats function and immeditely
-- warn there.
explainedSeverityAnnotation :: FollowStats Rearview -> (Severity, Maybe Text)
explainedSeverityAnnotation :: FollowStats Rearview -> (Severity, Maybe Text)
explainedSeverityAnnotation FollowStats Rearview
s
    | Bool
progressMovedBackwards = (Severity
Warning, Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"progress decreased")
    | Bool
noBlocks Bool -> Bool -> Bool
&& Bool
notRestored = (Severity
Warning, Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"not applying blocks")
    | Bool
nowInSync = (Severity
Notice, Maybe Text
forall a. Maybe a
Nothing)
    | Bool
otherwise = (Severity
Info, Maybe Text
forall a. Maybe a
Nothing)
  where
    progressMovedBackwards :: Bool
progressMovedBackwards = Rearview SyncProgress -> SyncProgress
forall a. Rearview a -> a
current (FollowStats Rearview -> Rearview SyncProgress
forall (f :: * -> *). FollowStats f -> f SyncProgress
prog FollowStats Rearview
s) SyncProgress -> SyncProgress -> Bool
forall a. Ord a => a -> a -> Bool
< Rearview SyncProgress -> SyncProgress
forall a. Rearview a -> a
past (FollowStats Rearview -> Rearview SyncProgress
forall (f :: * -> *). FollowStats f -> f SyncProgress
prog FollowStats Rearview
s)
    nowInSync :: Bool
nowInSync = Rearview SyncProgress -> SyncProgress
forall a. Rearview a -> a
current (FollowStats Rearview -> Rearview SyncProgress
forall (f :: * -> *). FollowStats f -> f SyncProgress
prog FollowStats Rearview
s) SyncProgress -> SyncProgress -> Bool
forall a. Eq a => a -> a -> Bool
== SyncProgress
Ready Bool -> Bool -> Bool
&& Rearview SyncProgress -> SyncProgress
forall a. Rearview a -> a
past (FollowStats Rearview -> Rearview SyncProgress
forall (f :: * -> *). FollowStats f -> f SyncProgress
prog FollowStats Rearview
s) SyncProgress -> SyncProgress -> Bool
forall a. Ord a => a -> a -> Bool
< SyncProgress
Ready
    notRestored :: Bool
notRestored = Rearview SyncProgress -> SyncProgress
forall a. Rearview a -> a
current (FollowStats Rearview -> Rearview SyncProgress
forall (f :: * -> *). FollowStats f -> f SyncProgress
prog FollowStats Rearview
s) SyncProgress -> SyncProgress -> Bool
forall a. Eq a => a -> a -> Bool
/= SyncProgress
Ready
    noBlocks :: Bool
noBlocks = (Rearview Int -> Int
forall a. Rearview a -> a
current (FollowStats Rearview -> Rearview Int
forall (f :: * -> *). FollowStats f -> f Int
blocksApplied FollowStats Rearview
s) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Rearview Int -> Int
forall a. Rearview a -> a
past (FollowStats Rearview -> Rearview Int
forall (f :: * -> *). FollowStats f -> f Int
blocksApplied FollowStats Rearview
s)) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0

instance HasSeverityAnnotation (FollowStats Rearview) where
    getSeverityAnnotation :: FollowStats Rearview -> Severity
getSeverityAnnotation = (Severity, Maybe Text) -> Severity
forall a b. (a, b) -> a
fst ((Severity, Maybe Text) -> Severity)
-> (FollowStats Rearview -> (Severity, Maybe Text))
-> FollowStats Rearview
-> Severity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FollowStats Rearview -> (Severity, Maybe Text)
explainedSeverityAnnotation

-- | Update the 'TMVar' holding the 'FollowStats'@ @'Rearview'
-- to forget the 'past' values and replace them with the 'current' ones.
-- Also update the time and sync process.
flushStats
    :: UTCTime
    -> (SlotNo -> IO SyncProgress)
    -> StrictTMVar IO (FollowStats Rearview)
    -> IO (FollowStats Rearview)
flushStats :: UTCTime
-> (SlotNo -> IO SyncProgress)
-> StrictTMVar IO (FollowStats Rearview)
-> IO (FollowStats Rearview)
flushStats UTCTime
t SlotNo -> IO SyncProgress
calcSyncProgress StrictTMVar IO (FollowStats Rearview)
var = do
    FollowStats Rearview
s <- STM IO (FollowStats Rearview) -> IO (FollowStats Rearview)
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM IO (FollowStats Rearview) -> IO (FollowStats Rearview))
-> STM IO (FollowStats Rearview) -> IO (FollowStats Rearview)
forall a b. (a -> b) -> a -> b
$ StrictTMVar IO (FollowStats Rearview)
-> STM IO (FollowStats Rearview)
forall (m :: * -> *) a. MonadSTM m => StrictTMVar m a -> STM m a
takeTMVar StrictTMVar IO (FollowStats Rearview)
var
    SyncProgress
p <- SlotNo -> IO SyncProgress
calcSyncProgress (SlotNo -> IO SyncProgress) -> SlotNo -> IO SyncProgress
forall a b. (a -> b) -> a -> b
$ ChainPoint -> SlotNo
pseudoSlotNo (ChainPoint -> SlotNo) -> ChainPoint -> SlotNo
forall a b. (a -> b) -> a -> b
$ Rearview ChainPoint -> ChainPoint
forall a. Rearview a -> a
current (Rearview ChainPoint -> ChainPoint)
-> Rearview ChainPoint -> ChainPoint
forall a b. (a -> b) -> a -> b
$ FollowStats Rearview -> Rearview ChainPoint
forall (f :: * -> *). FollowStats f -> f ChainPoint
localTip FollowStats Rearview
s
    let s' :: FollowStats Rearview
s' = FollowStats Rearview
s { time :: Rearview UTCTime
time = (UTCTime -> UTCTime) -> Rearview UTCTime -> Rearview UTCTime
forall a. (a -> a) -> Rearview a -> Rearview a
overCurrent (UTCTime -> UTCTime -> UTCTime
forall a b. a -> b -> a
const UTCTime
t) (FollowStats Rearview -> Rearview UTCTime
forall (f :: * -> *). FollowStats f -> f UTCTime
time FollowStats Rearview
s) }
               { prog :: Rearview SyncProgress
prog = (SyncProgress -> SyncProgress)
-> Rearview SyncProgress -> Rearview SyncProgress
forall a. (a -> a) -> Rearview a -> Rearview a
overCurrent (SyncProgress -> SyncProgress -> SyncProgress
forall a b. a -> b -> a
const SyncProgress
p) (FollowStats Rearview -> Rearview SyncProgress
forall (f :: * -> *). FollowStats f -> f SyncProgress
prog FollowStats Rearview
s) }
    STM IO () -> IO ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM IO () -> IO ()) -> STM IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ StrictTMVar IO (FollowStats Rearview)
-> FollowStats Rearview -> STM IO ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTMVar m a -> a -> STM m ()
putTMVar StrictTMVar IO (FollowStats Rearview)
var (FollowStats Rearview -> STM IO ())
-> FollowStats Rearview -> STM IO ()
forall a b. (a -> b) -> a -> b
$ (forall a. Rearview a -> Rearview a)
-> FollowStats Rearview -> FollowStats Rearview
forall (f :: * -> *) (g :: * -> *).
(forall a. f a -> g a) -> FollowStats f -> FollowStats g
hoistStats forall a. Rearview a -> Rearview a
forgetPast FollowStats Rearview
s'
    FollowStats Rearview -> IO (FollowStats Rearview)
forall (m :: * -> *) a. Monad m => a -> m a
return FollowStats Rearview
s'
  where
    forgetPast :: Rearview a -> Rearview a
forgetPast (Rearview a
_past a
curr) = a -> Rearview a
forall a. a -> Rearview a
initRearview a
curr

-- See NOTE [PointSlotNo]
pseudoSlotNo :: ChainPoint -> SlotNo
pseudoSlotNo :: ChainPoint -> SlotNo
pseudoSlotNo ChainPoint
ChainPointAtGenesis = Word64 -> SlotNo
SlotNo Word64
0
pseudoSlotNo (ChainPoint SlotNo
slot Hash "BlockHeader"
_) = SlotNo
slot

-- | Monitors health and statistics by inspecting the messages
-- submitted to a 'ChainSyncLog' tracer.
--
-- Statistics are computed in regular time intervals.
-- In order to do that, the monitor runs in separate thread.
-- The results are submitted to the outer 'ChainFollowLog' tracer.
withFollowStatsMonitoring
    :: Tracer IO ChainFollowLog
    -> (SlotNo -> IO SyncProgress)
    -> (Tracer IO (ChainSyncLog BlockHeader ChainPoint) -> IO ())
    -> IO ()
withFollowStatsMonitoring :: Tracer IO ChainFollowLog
-> (SlotNo -> IO SyncProgress)
-> (Tracer IO (ChainSyncLog BlockHeader ChainPoint) -> IO ())
-> IO ()
withFollowStatsMonitoring Tracer IO ChainFollowLog
tr SlotNo -> IO SyncProgress
calcSyncProgress Tracer IO (ChainSyncLog BlockHeader ChainPoint) -> IO ()
act = do
    UTCTime
t0  <- IO UTCTime
getCurrentTime
    StrictTMVar IO (FollowStats Rearview)
var <- FollowStats Rearview -> IO (StrictTMVar IO (FollowStats Rearview))
forall (m :: * -> *) a. MonadSTM m => a -> m (StrictTMVar m a)
newTMVarIO (FollowStats Rearview
 -> IO (StrictTMVar IO (FollowStats Rearview)))
-> FollowStats Rearview
-> IO (StrictTMVar IO (FollowStats Rearview))
forall a b. (a -> b) -> a -> b
$ UTCTime -> FollowStats Rearview
emptyStats UTCTime
t0
    let trChainSyncLog :: Tracer IO (ChainSyncLog BlockHeader ChainPoint)
trChainSyncLog = ((ChainSyncLog BlockHeader ChainPoint -> IO ChainFollowLog)
 -> Tracer IO ChainFollowLog
 -> Tracer IO (ChainSyncLog BlockHeader ChainPoint))
-> Tracer IO ChainFollowLog
-> (ChainSyncLog BlockHeader ChainPoint -> IO ChainFollowLog)
-> Tracer IO (ChainSyncLog BlockHeader ChainPoint)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (ChainSyncLog BlockHeader ChainPoint -> IO ChainFollowLog)
-> Tracer IO ChainFollowLog
-> Tracer IO (ChainSyncLog BlockHeader ChainPoint)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Tracer m b -> Tracer m a
contramapM Tracer IO ChainFollowLog
tr ((ChainSyncLog BlockHeader ChainPoint -> IO ChainFollowLog)
 -> Tracer IO (ChainSyncLog BlockHeader ChainPoint))
-> (ChainSyncLog BlockHeader ChainPoint -> IO ChainFollowLog)
-> Tracer IO (ChainSyncLog BlockHeader ChainPoint)
forall a b. (a -> b) -> a -> b
$ \ChainSyncLog BlockHeader ChainPoint
msg -> do
            STM IO () -> IO ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM IO () -> IO ()) -> STM IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                FollowStats Rearview
s <- StrictTMVar IO (FollowStats Rearview)
-> STM IO (FollowStats Rearview)
forall (m :: * -> *) a. MonadSTM m => StrictTMVar m a -> STM m a
takeTMVar StrictTMVar IO (FollowStats Rearview)
var
                StrictTMVar IO (FollowStats Rearview)
-> FollowStats Rearview -> STM IO ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTMVar m a -> a -> STM m ()
putTMVar StrictTMVar IO (FollowStats Rearview)
var (FollowStats Rearview -> STM ()) -> FollowStats Rearview -> STM ()
forall a b. (a -> b) -> a -> b
$! ChainSyncLog BlockHeader ChainPoint
-> FollowStats Rearview -> FollowStats Rearview
forall block.
ChainSyncLog block ChainPoint
-> FollowStats Rearview -> FollowStats Rearview
updateStats ChainSyncLog BlockHeader ChainPoint
msg FollowStats Rearview
s
            ChainFollowLog -> IO ChainFollowLog
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ChainFollowLog -> IO ChainFollowLog)
-> ChainFollowLog -> IO ChainFollowLog
forall a b. (a -> b) -> a -> b
$ ChainSyncLog BlockHeader ChainPoint -> ChainFollowLog
MsgChainSync ChainSyncLog BlockHeader ChainPoint
msg
    Tracer IO (ChainSyncLog BlockHeader ChainPoint)
-> ChainSyncLog BlockHeader ChainPoint -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO (ChainSyncLog BlockHeader ChainPoint)
trChainSyncLog (ChainSyncLog BlockHeader ChainPoint -> IO ())
-> ChainSyncLog BlockHeader ChainPoint -> IO ()
forall a b. (a -> b) -> a -> b
$ ChainPoint -> ChainSyncLog BlockHeader ChainPoint
forall block point. point -> ChainSyncLog block point
MsgLocalTip ChainPoint
ChainPointAtGenesis
    IO () -> IO Any -> IO ()
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m ()
race_
        (Tracer IO (ChainSyncLog BlockHeader ChainPoint) -> IO ()
act Tracer IO (ChainSyncLog BlockHeader ChainPoint)
trChainSyncLog)
        (StrictTMVar IO (FollowStats Rearview) -> Int -> IO Any
loop StrictTMVar IO (FollowStats Rearview)
var Int
startupDelay)
  where
    loop :: StrictTMVar IO (FollowStats Rearview) -> Int -> IO Any
loop StrictTMVar IO (FollowStats Rearview)
var Int
delay = do
        Int -> IO ()
forall (m :: * -> *). MonadIO m => Int -> m ()
threadDelay Int
delay
        UTCTime
t <- IO UTCTime
getCurrentTime
        FollowStats Rearview
s <- UTCTime
-> (SlotNo -> IO SyncProgress)
-> StrictTMVar IO (FollowStats Rearview)
-> IO (FollowStats Rearview)
flushStats UTCTime
t SlotNo -> IO SyncProgress
calcSyncProgress StrictTMVar IO (FollowStats Rearview)
var
        Tracer IO ChainFollowLog -> ChainFollowLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO ChainFollowLog
tr (ChainFollowLog -> IO ()) -> ChainFollowLog -> IO ()
forall a b. (a -> b) -> a -> b
$ FollowStats Rearview -> ChainFollowLog
MsgFollowStats FollowStats Rearview
s
        let delay' :: Int
delay' =
                if (Rearview SyncProgress -> SyncProgress
forall a. Rearview a -> a
current (FollowStats Rearview -> Rearview SyncProgress
forall (f :: * -> *). FollowStats f -> f SyncProgress
prog FollowStats Rearview
s)) SyncProgress -> SyncProgress -> Bool
forall a. Eq a => a -> a -> Bool
== SyncProgress
Ready
                then Int
restoredDelay
                else Int
syncingDelay
        StrictTMVar IO (FollowStats Rearview) -> Int -> IO Any
loop StrictTMVar IO (FollowStats Rearview)
var Int
delay'

    -- | Delay from launch to the first status update
    startupDelay :: Int
startupDelay = Int
5 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
second
    -- | Delay between status updates when restored
    restoredDelay :: Int
restoredDelay = Int
5 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
minute
    -- | Delay between status updates when not restored
    syncingDelay :: Int
syncingDelay = Int
30 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
second

    second :: Int
second = Int
1000Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
1000
    minute :: Int
minute = Int
60 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
second