{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE StandaloneDeriving #-}

{-# OPTIONS_GHC -Wno-orphans #-}

module Cardano.Node.Tracing.StateRep
  ( AddedToCurrentChain (..)
  , InitChainSelection (..)
  , NodeState (..)
  , OpeningDbs (..)
  , Replays (..)
  , StartupState (..)
  , traceNodeStateChainDB
  , traceNodeStateStartup
  , traceNodeStateShutdown
  , namesNodeState
  , severityNodeState
  , docNodeState
  ) where

import           Cardano.Logging
import           Cardano.Prelude
import           Data.Aeson
import           Data.Time.Clock
import           Data.Time.Clock.POSIX

import           Cardano.Node.Protocol.Types (SomeConsensusProtocol (..))
import qualified Ouroboros.Consensus.Block.RealPoint as RP
import qualified Ouroboros.Consensus.Node.NetworkProtocolVersion as NPV
import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB
import           Ouroboros.Consensus.Storage.ImmutableDB.Chunks.Internal
import qualified Ouroboros.Consensus.Storage.LedgerDB.OnDisk as LgrDb
import           Ouroboros.Network.Block (pointSlot)

import           Cardano.Node.Handlers.Shutdown (ShutdownTrace)
import qualified Cardano.Node.Startup as Startup
import           Cardano.Slotting.Slot (EpochNo, SlotNo (..), WithOrigin)
import           Cardano.Tracing.OrphanInstances.Network ()

instance FromJSON ChunkNo
instance FromJSON (WithOrigin SlotNo)

instance ToJSON ChunkNo
instance ToJSON (WithOrigin SlotNo)

data OpeningDbs
  = StartedOpeningImmutableDB
  | OpenedImmutableDB (WithOrigin SlotNo) ChunkNo
  | StartedOpeningVolatileDB
  | OpenedVolatileDB
  | StartedOpeningLgrDB
  | OpenedLgrDB
  deriving ((forall x. OpeningDbs -> Rep OpeningDbs x)
-> (forall x. Rep OpeningDbs x -> OpeningDbs) -> Generic OpeningDbs
forall x. Rep OpeningDbs x -> OpeningDbs
forall x. OpeningDbs -> Rep OpeningDbs x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep OpeningDbs x -> OpeningDbs
$cfrom :: forall x. OpeningDbs -> Rep OpeningDbs x
Generic, Value -> Parser [OpeningDbs]
Value -> Parser OpeningDbs
(Value -> Parser OpeningDbs)
-> (Value -> Parser [OpeningDbs]) -> FromJSON OpeningDbs
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [OpeningDbs]
$cparseJSONList :: Value -> Parser [OpeningDbs]
parseJSON :: Value -> Parser OpeningDbs
$cparseJSON :: Value -> Parser OpeningDbs
FromJSON, [OpeningDbs] -> Encoding
[OpeningDbs] -> Value
OpeningDbs -> Encoding
OpeningDbs -> Value
(OpeningDbs -> Value)
-> (OpeningDbs -> Encoding)
-> ([OpeningDbs] -> Value)
-> ([OpeningDbs] -> Encoding)
-> ToJSON OpeningDbs
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [OpeningDbs] -> Encoding
$ctoEncodingList :: [OpeningDbs] -> Encoding
toJSONList :: [OpeningDbs] -> Value
$ctoJSONList :: [OpeningDbs] -> Value
toEncoding :: OpeningDbs -> Encoding
$ctoEncoding :: OpeningDbs -> Encoding
toJSON :: OpeningDbs -> Value
$ctoJSON :: OpeningDbs -> Value
ToJSON)

data Replays
  = ReplayFromGenesis  (WithOrigin SlotNo)
  | ReplayFromSnapshot SlotNo (WithOrigin SlotNo) (WithOrigin SlotNo)
  | ReplayedBlock      SlotNo (WithOrigin SlotNo) (WithOrigin SlotNo)
  deriving ((forall x. Replays -> Rep Replays x)
-> (forall x. Rep Replays x -> Replays) -> Generic Replays
forall x. Rep Replays x -> Replays
forall x. Replays -> Rep Replays x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Replays x -> Replays
$cfrom :: forall x. Replays -> Rep Replays x
Generic, Value -> Parser [Replays]
Value -> Parser Replays
(Value -> Parser Replays)
-> (Value -> Parser [Replays]) -> FromJSON Replays
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [Replays]
$cparseJSONList :: Value -> Parser [Replays]
parseJSON :: Value -> Parser Replays
$cparseJSON :: Value -> Parser Replays
FromJSON, [Replays] -> Encoding
[Replays] -> Value
Replays -> Encoding
Replays -> Value
(Replays -> Value)
-> (Replays -> Encoding)
-> ([Replays] -> Value)
-> ([Replays] -> Encoding)
-> ToJSON Replays
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [Replays] -> Encoding
$ctoEncodingList :: [Replays] -> Encoding
toJSONList :: [Replays] -> Value
$ctoJSONList :: [Replays] -> Value
toEncoding :: Replays -> Encoding
$ctoEncoding :: Replays -> Encoding
toJSON :: Replays -> Value
$ctoJSON :: Replays -> Value
ToJSON)

data InitChainSelection
  = InitChainStartedSelection
  | InitChainSelected
  deriving ((forall x. InitChainSelection -> Rep InitChainSelection x)
-> (forall x. Rep InitChainSelection x -> InitChainSelection)
-> Generic InitChainSelection
forall x. Rep InitChainSelection x -> InitChainSelection
forall x. InitChainSelection -> Rep InitChainSelection x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep InitChainSelection x -> InitChainSelection
$cfrom :: forall x. InitChainSelection -> Rep InitChainSelection x
Generic, Value -> Parser [InitChainSelection]
Value -> Parser InitChainSelection
(Value -> Parser InitChainSelection)
-> (Value -> Parser [InitChainSelection])
-> FromJSON InitChainSelection
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [InitChainSelection]
$cparseJSONList :: Value -> Parser [InitChainSelection]
parseJSON :: Value -> Parser InitChainSelection
$cparseJSON :: Value -> Parser InitChainSelection
FromJSON, [InitChainSelection] -> Encoding
[InitChainSelection] -> Value
InitChainSelection -> Encoding
InitChainSelection -> Value
(InitChainSelection -> Value)
-> (InitChainSelection -> Encoding)
-> ([InitChainSelection] -> Value)
-> ([InitChainSelection] -> Encoding)
-> ToJSON InitChainSelection
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [InitChainSelection] -> Encoding
$ctoEncodingList :: [InitChainSelection] -> Encoding
toJSONList :: [InitChainSelection] -> Value
$ctoJSONList :: [InitChainSelection] -> Value
toEncoding :: InitChainSelection -> Encoding
$ctoEncoding :: InitChainSelection -> Encoding
toJSON :: InitChainSelection -> Value
$ctoJSON :: InitChainSelection -> Value
ToJSON)

type SyncPercentage = Double

data AddedToCurrentChain
  = AddedToCurrentChain !EpochNo !SlotNo !SyncPercentage
  deriving ((forall x. AddedToCurrentChain -> Rep AddedToCurrentChain x)
-> (forall x. Rep AddedToCurrentChain x -> AddedToCurrentChain)
-> Generic AddedToCurrentChain
forall x. Rep AddedToCurrentChain x -> AddedToCurrentChain
forall x. AddedToCurrentChain -> Rep AddedToCurrentChain x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep AddedToCurrentChain x -> AddedToCurrentChain
$cfrom :: forall x. AddedToCurrentChain -> Rep AddedToCurrentChain x
Generic, Value -> Parser [AddedToCurrentChain]
Value -> Parser AddedToCurrentChain
(Value -> Parser AddedToCurrentChain)
-> (Value -> Parser [AddedToCurrentChain])
-> FromJSON AddedToCurrentChain
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [AddedToCurrentChain]
$cparseJSONList :: Value -> Parser [AddedToCurrentChain]
parseJSON :: Value -> Parser AddedToCurrentChain
$cparseJSON :: Value -> Parser AddedToCurrentChain
FromJSON, [AddedToCurrentChain] -> Encoding
[AddedToCurrentChain] -> Value
AddedToCurrentChain -> Encoding
AddedToCurrentChain -> Value
(AddedToCurrentChain -> Value)
-> (AddedToCurrentChain -> Encoding)
-> ([AddedToCurrentChain] -> Value)
-> ([AddedToCurrentChain] -> Encoding)
-> ToJSON AddedToCurrentChain
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [AddedToCurrentChain] -> Encoding
$ctoEncodingList :: [AddedToCurrentChain] -> Encoding
toJSONList :: [AddedToCurrentChain] -> Value
$ctoJSONList :: [AddedToCurrentChain] -> Value
toEncoding :: AddedToCurrentChain -> Encoding
$ctoEncoding :: AddedToCurrentChain -> Encoding
toJSON :: AddedToCurrentChain -> Value
$ctoJSON :: AddedToCurrentChain -> Value
ToJSON)

deriving instance Generic NPV.NodeToClientVersion
deriving instance Generic NPV.NodeToNodeVersion

instance FromJSON NPV.NodeToClientVersion
instance FromJSON NPV.NodeToNodeVersion

data StartupState
  = StartupSocketConfigError Text
  | StartupDBValidation
  | NetworkConfigUpdate
  | NetworkConfigUpdateError Text
  | P2PWarning
  | P2PWarningDevelopementNetworkProtocols
  | WarningDevelopmentNetworkProtocols [NPV.NodeToNodeVersion] [NPV.NodeToClientVersion]
  deriving ((forall x. StartupState -> Rep StartupState x)
-> (forall x. Rep StartupState x -> StartupState)
-> Generic StartupState
forall x. Rep StartupState x -> StartupState
forall x. StartupState -> Rep StartupState x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep StartupState x -> StartupState
$cfrom :: forall x. StartupState -> Rep StartupState x
Generic, Value -> Parser [StartupState]
Value -> Parser StartupState
(Value -> Parser StartupState)
-> (Value -> Parser [StartupState]) -> FromJSON StartupState
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [StartupState]
$cparseJSONList :: Value -> Parser [StartupState]
parseJSON :: Value -> Parser StartupState
$cparseJSON :: Value -> Parser StartupState
FromJSON, [StartupState] -> Encoding
[StartupState] -> Value
StartupState -> Encoding
StartupState -> Value
(StartupState -> Value)
-> (StartupState -> Encoding)
-> ([StartupState] -> Value)
-> ([StartupState] -> Encoding)
-> ToJSON StartupState
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [StartupState] -> Encoding
$ctoEncodingList :: [StartupState] -> Encoding
toJSONList :: [StartupState] -> Value
$ctoJSONList :: [StartupState] -> Value
toEncoding :: StartupState -> Encoding
$ctoEncoding :: StartupState -> Encoding
toJSON :: StartupState -> Value
$ctoJSON :: StartupState -> Value
ToJSON)

-- | The representation of the current state of node.
--   All node states prior to tracing system going online are effectively invisible.
data NodeState
  = NodeTracingOnlineConfiguring
  | NodeOpeningDbs OpeningDbs
  | NodeReplays Replays
  | NodeInitChainSelection InitChainSelection
  | NodeKernelOnline
  | NodeAddBlock AddedToCurrentChain
  | NodeStartup StartupState
  | NodeShutdown ShutdownTrace
  deriving ((forall x. NodeState -> Rep NodeState x)
-> (forall x. Rep NodeState x -> NodeState) -> Generic NodeState
forall x. Rep NodeState x -> NodeState
forall x. NodeState -> Rep NodeState x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep NodeState x -> NodeState
$cfrom :: forall x. NodeState -> Rep NodeState x
Generic, Value -> Parser [NodeState]
Value -> Parser NodeState
(Value -> Parser NodeState)
-> (Value -> Parser [NodeState]) -> FromJSON NodeState
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [NodeState]
$cparseJSONList :: Value -> Parser [NodeState]
parseJSON :: Value -> Parser NodeState
$cparseJSON :: Value -> Parser NodeState
FromJSON, [NodeState] -> Encoding
[NodeState] -> Value
NodeState -> Encoding
NodeState -> Value
(NodeState -> Value)
-> (NodeState -> Encoding)
-> ([NodeState] -> Value)
-> ([NodeState] -> Encoding)
-> ToJSON NodeState
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [NodeState] -> Encoding
$ctoEncodingList :: [NodeState] -> Encoding
toJSONList :: [NodeState] -> Value
$ctoJSONList :: [NodeState] -> Value
toEncoding :: NodeState -> Encoding
$ctoEncoding :: NodeState -> Encoding
toJSON :: NodeState -> Value
$ctoJSON :: NodeState -> Value
ToJSON)

instance LogFormatting NodeState where
  forMachine :: DetailLevel -> NodeState -> Object
forMachine DetailLevel
_ = \case
    NodeOpeningDbs OpeningDbs
x -> [Object] -> Object
forall a. Monoid a => [a] -> a
mconcat
      [ Key
"kind" Key -> Value -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String Text
"NodeOpeningDbs",         Key
"openingDb" Key -> Value -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= OpeningDbs -> Value
forall a. ToJSON a => a -> Value
toJSON OpeningDbs
x]
    NodeReplays Replays
x -> [Object] -> Object
forall a. Monoid a => [a] -> a
mconcat
      [ Key
"kind" Key -> Value -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String Text
"NodeReplays",            Key
"replays"   Key -> Value -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Replays -> Value
forall a. ToJSON a => a -> Value
toJSON Replays
x]
    NodeInitChainSelection InitChainSelection
x -> [Object] -> Object
forall a. Monoid a => [a] -> a
mconcat
      [ Key
"kind" Key -> Value -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String Text
"NodeInitChainSelection", Key
"chainSel"  Key -> Value -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= InitChainSelection -> Value
forall a. ToJSON a => a -> Value
toJSON InitChainSelection
x]
    NodeAddBlock AddedToCurrentChain
x -> [Object] -> Object
forall a. Monoid a => [a] -> a
mconcat
      [ Key
"kind" Key -> Value -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String Text
"NodeAddBlock",           Key
"addBlock"  Key -> Value -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= AddedToCurrentChain -> Value
forall a. ToJSON a => a -> Value
toJSON AddedToCurrentChain
x]
    NodeStartup StartupState
x -> [Object] -> Object
forall a. Monoid a => [a] -> a
mconcat
      [ Key
"kind" Key -> Value -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String Text
"NodeStartup",            Key
"startup"   Key -> Value -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= StartupState -> Value
forall a. ToJSON a => a -> Value
toJSON StartupState
x]
    NodeShutdown ShutdownTrace
x -> [Object] -> Object
forall a. Monoid a => [a] -> a
mconcat
      [ Key
"kind" Key -> Value -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String Text
"NodeShutdown",           Key
"shutdown"  Key -> Value -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= ShutdownTrace -> Value
forall a. ToJSON a => a -> Value
toJSON ShutdownTrace
x]
    NodeState
_ -> Object
forall a. Monoid a => a
mempty

docNodeState :: Documented NodeState
docNodeState :: Documented NodeState
docNodeState = Namespace -> Documented Any -> Documented NodeState
forall a b. Namespace -> Documented a -> Documented b
addDocumentedNamespace  [] (Documented Any -> Documented NodeState)
-> Documented Any -> Documented NodeState
forall a b. (a -> b) -> a -> b
$
  [DocMsg Any] -> Documented Any
forall a. [DocMsg a] -> Documented a
Documented
  [ Namespace -> [(Text, Text)] -> Text -> DocMsg Any
forall a. Namespace -> [(Text, Text)] -> Text -> DocMsg a
DocMsg [Text
"NodeTracingOnlineConfiguring"] [] Text
"Tracing system came online, system configuring now"
  , Namespace -> [(Text, Text)] -> Text -> DocMsg Any
forall a. Namespace -> [(Text, Text)] -> Text -> DocMsg a
DocMsg [Text
"NodeOpeningDbs"]               [] Text
"ChainDB components being opened"
  , Namespace -> [(Text, Text)] -> Text -> DocMsg Any
forall a. Namespace -> [(Text, Text)] -> Text -> DocMsg a
DocMsg [Text
"NodeReplays"]                  [] Text
"Replaying chain"
  , Namespace -> [(Text, Text)] -> Text -> DocMsg Any
forall a. Namespace -> [(Text, Text)] -> Text -> DocMsg a
DocMsg [Text
"NodeInitChainSelection"]       [] Text
"Performing initial chain selection"
  , Namespace -> [(Text, Text)] -> Text -> DocMsg Any
forall a. Namespace -> [(Text, Text)] -> Text -> DocMsg a
DocMsg [Text
"NodeKernelOnline"]             [] Text
"Node kernel online"
  , Namespace -> [(Text, Text)] -> Text -> DocMsg Any
forall a. Namespace -> [(Text, Text)] -> Text -> DocMsg a
DocMsg [Text
"NodeAddBlock"]                 [] Text
"Applying block"
  , Namespace -> [(Text, Text)] -> Text -> DocMsg Any
forall a. Namespace -> [(Text, Text)] -> Text -> DocMsg a
DocMsg [Text
"NodeStartup"]                  [] Text
"Node startup"
  , Namespace -> [(Text, Text)] -> Text -> DocMsg Any
forall a. Namespace -> [(Text, Text)] -> Text -> DocMsg a
DocMsg [Text
"NodeShutdown"]                 [] Text
"Node shutting down"
  ]

namesNodeState :: NodeState -> [Text]
namesNodeState :: NodeState -> Namespace
namesNodeState = \case
  NodeState
NodeTracingOnlineConfiguring -> [Text
"TracingOnlineConfiguring"]
  NodeOpeningDbs OpeningDbs
_x -> [Text
"OpeningDbs"] -- : namesOpeninDbs x
  NodeReplays Replays
_x -> [Text
"Replays"] -- : namesReplays x
  NodeInitChainSelection InitChainSelection
_x -> [Text
"InitChainSelection"] -- : namesInitChainSelection -- Worth it?
  NodeState
NodeKernelOnline -> [Text
"NodeKernelOnline"]
  NodeAddBlock AddedToCurrentChain
_x -> [Text
"AddBlock"] -- : namesAddBlock x
  NodeStartup StartupState
_x -> [Text
"Startup"] -- : namesForStartup x -- Worth it?
  NodeShutdown ShutdownTrace
_x -> [Text
"Shutdown"] -- : namesShutdown x

severityNodeState :: NodeState -> SeverityS
severityNodeState :: NodeState -> SeverityS
severityNodeState = \case
  NodeState
NodeTracingOnlineConfiguring -> SeverityS
Info
  NodeOpeningDbs OpeningDbs
_x -> SeverityS
Info
  NodeReplays Replays
_x -> SeverityS
Notice
  NodeInitChainSelection InitChainSelection
_x -> SeverityS
Notice
  NodeState
NodeKernelOnline -> SeverityS
Info
  NodeAddBlock AddedToCurrentChain
_x -> SeverityS
Notice
  NodeStartup StartupState
_x -> SeverityS
Info
  NodeShutdown ShutdownTrace
_x -> SeverityS
Warning

traceNodeStateChainDB
  :: SomeConsensusProtocol
  -> Trace IO NodeState
  -> ChainDB.TraceEvent blk
  -> IO ()
traceNodeStateChainDB :: SomeConsensusProtocol
-> Trace IO NodeState -> TraceEvent blk -> IO ()
traceNodeStateChainDB SomeConsensusProtocol
_scp Trace IO NodeState
tr TraceEvent blk
ev =
  case TraceEvent blk
ev of
    ChainDB.TraceOpenEvent TraceOpenEvent blk
ev' ->
      case TraceOpenEvent blk
ev' of
        TraceOpenEvent blk
ChainDB.StartedOpeningImmutableDB ->
          Trace IO NodeState -> NodeState -> IO ()
forall (m :: * -> *) a. Monad m => Trace m a -> a -> m ()
traceWith Trace IO NodeState
tr (NodeState -> IO ()) -> NodeState -> IO ()
forall a b. (a -> b) -> a -> b
$ OpeningDbs -> NodeState
NodeOpeningDbs OpeningDbs
StartedOpeningImmutableDB
        ChainDB.OpenedImmutableDB Point blk
p ChunkNo
chunk ->
          Trace IO NodeState -> NodeState -> IO ()
forall (m :: * -> *) a. Monad m => Trace m a -> a -> m ()
traceWith Trace IO NodeState
tr (NodeState -> IO ()) -> NodeState -> IO ()
forall a b. (a -> b) -> a -> b
$ OpeningDbs -> NodeState
NodeOpeningDbs (OpeningDbs -> NodeState) -> OpeningDbs -> NodeState
forall a b. (a -> b) -> a -> b
$ WithOrigin SlotNo -> ChunkNo -> OpeningDbs
OpenedImmutableDB (Point blk -> WithOrigin SlotNo
forall block. Point block -> WithOrigin SlotNo
pointSlot Point blk
p) ChunkNo
chunk
        TraceOpenEvent blk
ChainDB.StartedOpeningVolatileDB ->
          Trace IO NodeState -> NodeState -> IO ()
forall (m :: * -> *) a. Monad m => Trace m a -> a -> m ()
traceWith Trace IO NodeState
tr (NodeState -> IO ()) -> NodeState -> IO ()
forall a b. (a -> b) -> a -> b
$ OpeningDbs -> NodeState
NodeOpeningDbs OpeningDbs
StartedOpeningVolatileDB
        TraceOpenEvent blk
ChainDB.OpenedVolatileDB ->
          Trace IO NodeState -> NodeState -> IO ()
forall (m :: * -> *) a. Monad m => Trace m a -> a -> m ()
traceWith Trace IO NodeState
tr (NodeState -> IO ()) -> NodeState -> IO ()
forall a b. (a -> b) -> a -> b
$ OpeningDbs -> NodeState
NodeOpeningDbs OpeningDbs
OpenedVolatileDB
        TraceOpenEvent blk
ChainDB.StartedOpeningLgrDB ->
          Trace IO NodeState -> NodeState -> IO ()
forall (m :: * -> *) a. Monad m => Trace m a -> a -> m ()
traceWith Trace IO NodeState
tr (NodeState -> IO ()) -> NodeState -> IO ()
forall a b. (a -> b) -> a -> b
$ OpeningDbs -> NodeState
NodeOpeningDbs OpeningDbs
StartedOpeningLgrDB
        TraceOpenEvent blk
ChainDB.OpenedLgrDB ->
          Trace IO NodeState -> NodeState -> IO ()
forall (m :: * -> *) a. Monad m => Trace m a -> a -> m ()
traceWith Trace IO NodeState
tr (NodeState -> IO ()) -> NodeState -> IO ()
forall a b. (a -> b) -> a -> b
$ OpeningDbs -> NodeState
NodeOpeningDbs OpeningDbs
OpenedLgrDB
        TraceOpenEvent blk
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    ChainDB.TraceLedgerReplayEvent TraceReplayEvent blk
ev' ->
      case TraceReplayEvent blk
ev' of
        LgrDb.ReplayFromGenesis (LgrDb.ReplayGoal Point blk
p) ->
          Trace IO NodeState -> NodeState -> IO ()
forall (m :: * -> *) a. Monad m => Trace m a -> a -> m ()
traceWith Trace IO NodeState
tr (NodeState -> IO ()) -> NodeState -> IO ()
forall a b. (a -> b) -> a -> b
$ Replays -> NodeState
NodeReplays (Replays -> NodeState) -> Replays -> NodeState
forall a b. (a -> b) -> a -> b
$ WithOrigin SlotNo -> Replays
ReplayFromGenesis (Point blk -> WithOrigin SlotNo
forall block. Point block -> WithOrigin SlotNo
pointSlot Point blk
p)
        LgrDb.ReplayFromSnapshot DiskSnapshot
_ (RP.RealPoint SlotNo
s HeaderHash blk
_) (LgrDb.ReplayStart Point blk
rs) (LgrDb.ReplayGoal Point blk
rp) ->
          Trace IO NodeState -> NodeState -> IO ()
forall (m :: * -> *) a. Monad m => Trace m a -> a -> m ()
traceWith Trace IO NodeState
tr (NodeState -> IO ()) -> NodeState -> IO ()
forall a b. (a -> b) -> a -> b
$ Replays -> NodeState
NodeReplays (Replays -> NodeState) -> Replays -> NodeState
forall a b. (a -> b) -> a -> b
$ SlotNo -> WithOrigin SlotNo -> WithOrigin SlotNo -> Replays
ReplayFromSnapshot SlotNo
s (Point blk -> WithOrigin SlotNo
forall block. Point block -> WithOrigin SlotNo
pointSlot Point blk
rs) (Point blk -> WithOrigin SlotNo
forall block. Point block -> WithOrigin SlotNo
pointSlot Point blk
rp)
        LgrDb.ReplayedBlock (RP.RealPoint SlotNo
s HeaderHash blk
_) [LedgerEvent blk]
_ (LgrDb.ReplayStart Point blk
rs) (LgrDb.ReplayGoal Point blk
rp) ->
          Trace IO NodeState -> NodeState -> IO ()
forall (m :: * -> *) a. Monad m => Trace m a -> a -> m ()
traceWith Trace IO NodeState
tr (NodeState -> IO ()) -> NodeState -> IO ()
forall a b. (a -> b) -> a -> b
$ Replays -> NodeState
NodeReplays (Replays -> NodeState) -> Replays -> NodeState
forall a b. (a -> b) -> a -> b
$ SlotNo -> WithOrigin SlotNo -> WithOrigin SlotNo -> Replays
ReplayedBlock SlotNo
s (Point blk -> WithOrigin SlotNo
forall block. Point block -> WithOrigin SlotNo
pointSlot Point blk
rs) (Point blk -> WithOrigin SlotNo
forall block. Point block -> WithOrigin SlotNo
pointSlot Point blk
rp)
    ChainDB.TraceInitChainSelEvent TraceInitChainSelEvent blk
ev' ->
      case TraceInitChainSelEvent blk
ev' of
        TraceInitChainSelEvent blk
ChainDB.StartedInitChainSelection ->
          Trace IO NodeState -> NodeState -> IO ()
forall (m :: * -> *) a. Monad m => Trace m a -> a -> m ()
traceWith Trace IO NodeState
tr (NodeState -> IO ()) -> NodeState -> IO ()
forall a b. (a -> b) -> a -> b
$ InitChainSelection -> NodeState
NodeInitChainSelection InitChainSelection
InitChainStartedSelection
        TraceInitChainSelEvent blk
ChainDB.InitalChainSelected ->
          Trace IO NodeState -> NodeState -> IO ()
forall (m :: * -> *) a. Monad m => Trace m a -> a -> m ()
traceWith Trace IO NodeState
tr (NodeState -> IO ()) -> NodeState -> IO ()
forall a b. (a -> b) -> a -> b
$ InitChainSelection -> NodeState
NodeInitChainSelection InitChainSelection
InitChainSelected
        TraceInitChainSelEvent blk
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    ChainDB.TraceAddBlockEvent TraceAddBlockEvent blk
ev' ->
      case TraceAddBlockEvent blk
ev' of
        ChainDB.AddedToCurrentChain [LedgerEvent blk]
_ (ChainDB.NewTipInfo RealPoint blk
currentTip EpochNo
ntEpoch Word64
sInEpoch RealPoint blk
_) AnchoredFragment (Header blk)
_ AnchoredFragment (Header blk)
_ -> do
          -- The slot of the latest block consumed (our progress).
          let RP.RealPoint SlotNo
ourSlotSinceSystemStart HeaderHash blk
_ = RealPoint blk
currentTip
          -- The slot corresponding to the latest wall-clock time (our target).
          SlotNo
slotSinceSystemStart <- IO SlotNo
getSlotForNow
          let syncProgressPct :: SyncPercentage
              syncProgressPct :: SyncPercentage
syncProgressPct = (   Word64 -> SyncPercentage
forall a b. (Integral a, Num b) => a -> b
fromIntegral (SlotNo -> Word64
unSlotNo SlotNo
ourSlotSinceSystemStart)
                                  SyncPercentage -> SyncPercentage -> SyncPercentage
forall a. Fractional a => a -> a -> a
/ Word64 -> SyncPercentage
forall a b. (Integral a, Num b) => a -> b
fromIntegral (SlotNo -> Word64
unSlotNo SlotNo
slotSinceSystemStart)
                                ) SyncPercentage -> SyncPercentage -> SyncPercentage
forall a. Num a => a -> a -> a
* SyncPercentage
100.0
          Trace IO NodeState -> NodeState -> IO ()
forall (m :: * -> *) a. Monad m => Trace m a -> a -> m ()
traceWith Trace IO NodeState
tr (NodeState -> IO ()) -> NodeState -> IO ()
forall a b. (a -> b) -> a -> b
$ AddedToCurrentChain -> NodeState
NodeAddBlock (AddedToCurrentChain -> NodeState)
-> AddedToCurrentChain -> NodeState
forall a b. (a -> b) -> a -> b
$
            EpochNo -> SlotNo -> SyncPercentage -> AddedToCurrentChain
AddedToCurrentChain EpochNo
ntEpoch (Word64 -> SlotNo
SlotNo Word64
sInEpoch) SyncPercentage
syncProgressPct
        TraceAddBlockEvent blk
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    TraceEvent blk
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

traceNodeStateStartup
  :: Trace IO NodeState
  -> Startup.StartupTrace blk
  -> IO ()
traceNodeStateStartup :: Trace IO NodeState -> StartupTrace blk -> IO ()
traceNodeStateStartup Trace IO NodeState
tr StartupTrace blk
ev =
  case StartupTrace blk
ev of
    Startup.StartupSocketConfigError SocketConfigError
e ->
      Trace IO NodeState -> NodeState -> IO ()
forall (m :: * -> *) a. Monad m => Trace m a -> a -> m ()
traceWith Trace IO NodeState
tr (NodeState -> IO ()) -> NodeState -> IO ()
forall a b. (a -> b) -> a -> b
$ StartupState -> NodeState
NodeStartup (StartupState -> NodeState) -> StartupState -> NodeState
forall a b. (a -> b) -> a -> b
$ Text -> StartupState
StartupSocketConfigError (SocketConfigError -> Text
forall a b. (Show a, ConvertText String b) => a -> b
show SocketConfigError
e)
    StartupTrace blk
Startup.StartupDBValidation ->
      Trace IO NodeState -> NodeState -> IO ()
forall (m :: * -> *) a. Monad m => Trace m a -> a -> m ()
traceWith Trace IO NodeState
tr (NodeState -> IO ()) -> NodeState -> IO ()
forall a b. (a -> b) -> a -> b
$ StartupState -> NodeState
NodeStartup StartupState
StartupDBValidation
    StartupTrace blk
Startup.NetworkConfigUpdate ->
      Trace IO NodeState -> NodeState -> IO ()
forall (m :: * -> *) a. Monad m => Trace m a -> a -> m ()
traceWith Trace IO NodeState
tr (NodeState -> IO ()) -> NodeState -> IO ()
forall a b. (a -> b) -> a -> b
$ StartupState -> NodeState
NodeStartup StartupState
NetworkConfigUpdate
    Startup.NetworkConfigUpdateError Text
e ->
      Trace IO NodeState -> NodeState -> IO ()
forall (m :: * -> *) a. Monad m => Trace m a -> a -> m ()
traceWith Trace IO NodeState
tr (NodeState -> IO ()) -> NodeState -> IO ()
forall a b. (a -> b) -> a -> b
$ StartupState -> NodeState
NodeStartup (StartupState -> NodeState) -> StartupState -> NodeState
forall a b. (a -> b) -> a -> b
$ Text -> StartupState
NetworkConfigUpdateError Text
e
    StartupTrace blk
Startup.P2PWarning ->
      Trace IO NodeState -> NodeState -> IO ()
forall (m :: * -> *) a. Monad m => Trace m a -> a -> m ()
traceWith Trace IO NodeState
tr (NodeState -> IO ()) -> NodeState -> IO ()
forall a b. (a -> b) -> a -> b
$ StartupState -> NodeState
NodeStartup StartupState
P2PWarning
    StartupTrace blk
Startup.P2PWarningDevelopementNetworkProtocols ->
      Trace IO NodeState -> NodeState -> IO ()
forall (m :: * -> *) a. Monad m => Trace m a -> a -> m ()
traceWith Trace IO NodeState
tr (NodeState -> IO ()) -> NodeState -> IO ()
forall a b. (a -> b) -> a -> b
$ StartupState -> NodeState
NodeStartup StartupState
P2PWarningDevelopementNetworkProtocols
    Startup.WarningDevelopmentNetworkProtocols [NodeToNodeVersion]
n2ns [NodeToClientVersion]
n2cs ->
      Trace IO NodeState -> NodeState -> IO ()
forall (m :: * -> *) a. Monad m => Trace m a -> a -> m ()
traceWith Trace IO NodeState
tr (NodeState -> IO ()) -> NodeState -> IO ()
forall a b. (a -> b) -> a -> b
$ StartupState -> NodeState
NodeStartup (StartupState -> NodeState) -> StartupState -> NodeState
forall a b. (a -> b) -> a -> b
$ [NodeToNodeVersion] -> [NodeToClientVersion] -> StartupState
WarningDevelopmentNetworkProtocols [NodeToNodeVersion]
n2ns [NodeToClientVersion]
n2cs
    StartupTrace blk
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

traceNodeStateShutdown
  :: Trace IO NodeState
  -> ShutdownTrace
  -> IO ()
traceNodeStateShutdown :: Trace IO NodeState -> ShutdownTrace -> IO ()
traceNodeStateShutdown Trace IO NodeState
tr = Trace IO NodeState -> NodeState -> IO ()
forall (m :: * -> *) a. Monad m => Trace m a -> a -> m ()
traceWith Trace IO NodeState
tr (NodeState -> IO ())
-> (ShutdownTrace -> NodeState) -> ShutdownTrace -> IO ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ShutdownTrace -> NodeState
NodeShutdown

-- Misc.

getSlotForNow :: IO SlotNo
getSlotForNow :: IO SlotNo
getSlotForNow = do
  Word64
posixNow <- UTCTime -> Word64
utc2s (UTCTime -> Word64) -> IO UTCTime -> IO Word64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime
getCurrentTime
  -- Since Shelley era the slot length is 1 second, so the number of seconds is the number of slots.
  let numberOfSlotsFromShelleyTillNow :: Word64
numberOfSlotsFromShelleyTillNow = Word64
posixNow Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
posixStartOfShelleyEra
      totalNumberOfSlotsTillNow :: Word64
totalNumberOfSlotsTillNow = Word64
numberOfSlotsInByronEra Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
numberOfSlotsFromShelleyTillNow
  SlotNo -> IO SlotNo
forall (m :: * -> *) a. Monad m => a -> m a
return (SlotNo -> IO SlotNo) -> SlotNo -> IO SlotNo
forall a b. (a -> b) -> a -> b
$ Word64 -> SlotNo
SlotNo Word64
totalNumberOfSlotsTillNow
 where
  -- These numbers are taken from 'First-Block-of-Each-Era' wiki page.
  posixStartOfShelleyEra :: Word64
posixStartOfShelleyEra = Word64
1596073491
  numberOfSlotsInByronEra :: Word64
numberOfSlotsInByronEra = Word64
4492799
  utc2s :: UTCTime -> Word64
utc2s = Integer -> Word64
forall a. Num a => Integer -> a
fromInteger (Integer -> Word64) -> (UTCTime -> Integer) -> UTCTime -> Word64
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. POSIXTime -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
round (POSIXTime -> Integer)
-> (UTCTime -> POSIXTime) -> UTCTime -> Integer
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. UTCTime -> POSIXTime
utcTimeToPOSIXSeconds