{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

{-# OPTIONS_GHC -Wno-orphans  #-}

module Cardano.Node.Tracing.Tracers.Consensus
  ( severityChainSyncClientEvent
  , namesForChainSyncClientEvent
  , docChainSyncClientEvent

  , severityChainSyncServerEvent
  , namesForChainSyncServerEvent
  , docChainSyncServerEventHeader
  , docChainSyncServerEventBlock

  , severityBlockFetchDecision
  , namesForBlockFetchDecision
  , docBlockFetchDecision

  , severityBlockFetchClient
  , namesForBlockFetchClient
  , docBlockFetchClient

  , ClientMetrics(..)
  , initialClientMetrics
  , calculateBlockFetchClientMetrics

  , severityBlockFetchServer
  , namesForBlockFetchServer
  , docBlockFetchServer

  , severityTxInbound
  , namesForTxInbound
  , docTxInbound

  , severityTxOutbound
  , namesForTxOutbound
  , docTxOutbound

  , severityLocalTxSubmissionServer
  , namesForLocalTxSubmissionServer
  , docLocalTxSubmissionServer

  , severityMempool
  , namesForMempool
  , docMempool

  , TraceStartLeadershipCheckPlus (..)
  , ForgeTracerType
  , forgeTracerTransform
  , severityForge
  , namesForForge
  , docForge

  , namesForBlockchainTime
  , severityBlockchainTime
  , docBlockchainTime

  , namesForKeepAliveClient
  , severityKeepAliveClient
  , docKeepAliveClient

  ) where


import           Control.Monad.Class.MonadTime (Time (..))
import           Data.Aeson (ToJSON, Value (Number, String), toJSON, (.=))
import           Data.IntPSQ (IntPSQ)
import qualified Data.IntPSQ as Pq
import           Data.SOP.Strict
import qualified Data.Text as Text
import           Data.Time (DiffTime, NominalDiffTime)
import           Text.Show


import           Cardano.Slotting.Slot (WithOrigin (..))

import           Cardano.Logging
import           Cardano.Node.Queries (HasKESInfo (..))
import           Cardano.Node.Tracing.Era.Byron ()
import           Cardano.Node.Tracing.Era.Shelley ()
import           Cardano.Node.Tracing.Formatting ()
import           Cardano.Node.Tracing.Render
import           Cardano.Node.Tracing.Tracers.StartLeadershipCheck
import           Cardano.Prelude hiding (All, Show, show)

import           Cardano.Protocol.TPraos.OCert (KESPeriod (..))

import qualified Ouroboros.Network.AnchoredFragment as AF
import qualified Ouroboros.Network.AnchoredSeq as AS
import           Ouroboros.Network.Block hiding (blockPrevHash)
import           Ouroboros.Network.BlockFetch.ClientState (TraceLabelPeer (..))
import qualified Ouroboros.Network.BlockFetch.ClientState as BlockFetch
import           Ouroboros.Network.BlockFetch.Decision
import           Ouroboros.Network.DeltaQ (GSV (..), PeerGSV (..))
import           Ouroboros.Network.KeepAlive (TraceKeepAliveClient (..))
import           Ouroboros.Network.TxSubmission.Inbound hiding (txId)
import           Ouroboros.Network.TxSubmission.Outbound

import qualified Data.Aeson as Aeson
import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.BlockchainTime (SystemStart (..))
import           Ouroboros.Consensus.BlockchainTime.WallClock.Util (TraceBlockchainTimeEvent (..))
import           Ouroboros.Consensus.Cardano.Block
import           Ouroboros.Consensus.Ledger.Inspect (LedgerEvent (..), LedgerUpdate, LedgerWarning)
import           Ouroboros.Consensus.Ledger.SupportsMempool (ApplyTxErr, GenTxId, HasTxId,
                   LedgerSupportsMempool, txForgetValidated, txId)
import           Ouroboros.Consensus.Ledger.SupportsProtocol
import           Ouroboros.Consensus.Mempool.API (MempoolSize (..), TraceEventMempool (..))
import           Ouroboros.Consensus.MiniProtocol.BlockFetch.Server
                   (TraceBlockFetchServerEvent (..))
import           Ouroboros.Consensus.MiniProtocol.ChainSync.Client
import           Ouroboros.Consensus.MiniProtocol.ChainSync.Server
import           Ouroboros.Consensus.MiniProtocol.LocalTxSubmission.Server
                   (TraceLocalTxSubmissionServerEvent (..))
import           Ouroboros.Consensus.Node.Run (SerialiseNodeToNodeConstraints, estimateBlockSize)
import           Ouroboros.Consensus.Node.Tracers
import qualified Ouroboros.Consensus.Protocol.Ledger.HotKey as HotKey
import           Ouroboros.Consensus.Util.Enclose



instance LogFormatting a => LogFormatting (TraceLabelCreds a) where
  forMachine :: DetailLevel -> TraceLabelCreds a -> Object
forMachine DetailLevel
dtal (TraceLabelCreds Text
creds a
a)  =
    [Object] -> Object
forall a. Monoid a => [a] -> a
mconcat [ Key
"credentials" Key -> Value -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
forall a. ToJSON a => a -> Value
toJSON Text
creds
             , Key
"val"         Key -> Object -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= DetailLevel -> a -> Object
forall a. LogFormatting a => DetailLevel -> a -> Object
forMachine DetailLevel
dtal a
a
            ]
-- TODO Trace label creds as well
  forHuman :: TraceLabelCreds a -> Text
forHuman (TraceLabelCreds Text
_t a
a)         = a -> Text
forall a. LogFormatting a => a -> Text
forHuman a
a
  asMetrics :: TraceLabelCreds a -> [Metric]
asMetrics (TraceLabelCreds Text
_t a
a)        = a -> [Metric]
forall a. LogFormatting a => a -> [Metric]
asMetrics a
a


instance (LogFormatting (LedgerUpdate blk), LogFormatting (LedgerWarning blk))
      =>  LogFormatting (LedgerEvent blk) where
  forMachine :: DetailLevel -> LedgerEvent blk -> Object
forMachine DetailLevel
dtal = \case
    LedgerUpdate  LedgerUpdate blk
update  -> DetailLevel -> LedgerUpdate blk -> Object
forall a. LogFormatting a => DetailLevel -> a -> Object
forMachine DetailLevel
dtal LedgerUpdate blk
update
    LedgerWarning LedgerWarning blk
warning -> DetailLevel -> LedgerWarning blk -> Object
forall a. LogFormatting a => DetailLevel -> a -> Object
forMachine DetailLevel
dtal LedgerWarning blk
warning

tipToObject :: forall blk. ConvertRawHash blk => Tip blk -> Aeson.Object
tipToObject :: Tip blk -> Object
tipToObject = \case
  Tip blk
TipGenesis -> [Object] -> Object
forall a. Monoid a => [a] -> a
mconcat
    [ Key
"slot"    Key -> Value -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Int -> Value
forall a. ToJSON a => a -> Value
toJSON (Int
0 :: Int)
    , Key
"block"   Key -> Value -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String Text
"genesis"
    , Key
"blockNo" Key -> Value -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Int -> Value
forall a. ToJSON a => a -> Value
toJSON ((-Int
1) :: Int)
    ]
  Tip SlotNo
slot HeaderHash blk
hash BlockNo
blockno -> [Object] -> Object
forall a. Monoid a => [a] -> a
mconcat
    [ Key
"slot"    Key -> SlotNo -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= SlotNo
slot
    , Key
"block"   Key -> Value -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String (Proxy blk -> HeaderHash blk -> Text
forall blk (proxy :: * -> *).
ConvertRawHash blk =>
proxy blk -> HeaderHash blk -> Text
renderHeaderHash (Proxy blk
forall k (t :: k). Proxy t
Proxy @blk) HeaderHash blk
hash)
    , Key
"blockNo" Key -> BlockNo -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= BlockNo
blockno
    ]

--------------------------------------------------------------------------------
-- ChainSyncClient Tracer
--------------------------------------------------------------------------------

severityChainSyncClientEvent ::
  BlockFetch.TraceLabelPeer peer (TraceChainSyncClientEvent blk) -> SeverityS
severityChainSyncClientEvent :: TraceLabelPeer peer (TraceChainSyncClientEvent blk) -> SeverityS
severityChainSyncClientEvent (BlockFetch.TraceLabelPeer peer
_ TraceChainSyncClientEvent blk
e) =
    TraceChainSyncClientEvent blk -> SeverityS
forall blk. TraceChainSyncClientEvent blk -> SeverityS
severityChainSyncClientEvent' TraceChainSyncClientEvent blk
e

namesForChainSyncClientEvent ::
  BlockFetch.TraceLabelPeer peer (TraceChainSyncClientEvent blk) -> [Text]
namesForChainSyncClientEvent :: TraceLabelPeer peer (TraceChainSyncClientEvent blk) -> [Text]
namesForChainSyncClientEvent (BlockFetch.TraceLabelPeer peer
_ TraceChainSyncClientEvent blk
e) =
    Text
"ChainSyncClientEvent" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: TraceChainSyncClientEvent blk -> [Text]
forall blk. TraceChainSyncClientEvent blk -> [Text]
namesForChainSyncClientEvent' TraceChainSyncClientEvent blk
e

severityChainSyncClientEvent' :: TraceChainSyncClientEvent blk -> SeverityS
severityChainSyncClientEvent' :: TraceChainSyncClientEvent blk -> SeverityS
severityChainSyncClientEvent' TraceDownloadedHeader {}  = SeverityS
Info
severityChainSyncClientEvent' TraceFoundIntersection {} = SeverityS
Info
severityChainSyncClientEvent' TraceRolledBack {}        = SeverityS
Notice
severityChainSyncClientEvent' TraceException {}         = SeverityS
Warning
severityChainSyncClientEvent' TraceTermination {}       = SeverityS
Notice

namesForChainSyncClientEvent' :: TraceChainSyncClientEvent blk -> [Text]
namesForChainSyncClientEvent' :: TraceChainSyncClientEvent blk -> [Text]
namesForChainSyncClientEvent' TraceDownloadedHeader {} =
      [Text
"DownloadedHeader"]
namesForChainSyncClientEvent' TraceFoundIntersection {} =
      [Text
"FoundIntersection"]
namesForChainSyncClientEvent' TraceRolledBack {} =
      [Text
"RolledBack"]
namesForChainSyncClientEvent' TraceException {} =
      [Text
"Exception"]
namesForChainSyncClientEvent' TraceTermination {} =
      [Text
"Termination"]

instance (ConvertRawHash blk, LedgerSupportsProtocol blk)
      => LogFormatting (TraceChainSyncClientEvent blk) where
  forHuman :: TraceChainSyncClientEvent blk -> Text
forHuman (TraceDownloadedHeader Header blk
pt) =
    Text
"While following a candidate chain, we rolled forward by downloading a\
    \ header. " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Point blk -> Text
forall a. Show a => a -> Text
showT (Header blk -> Point blk
forall blk. HasHeader (Header blk) => Header blk -> Point blk
headerPoint Header blk
pt)
  forHuman (TraceRolledBack Point blk
tip) =
    Text
"While following a candidate chain, we rolled back to the given point: "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Point blk -> Text
forall a. Show a => a -> Text
showT Point blk
tip
  forHuman (TraceException ChainSyncClientException
exc) =
    Text
"An exception was thrown by the Chain Sync Client. "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ChainSyncClientException -> Text
forall a. Show a => a -> Text
showT ChainSyncClientException
exc
  forHuman TraceFoundIntersection {} =
      Text
"We found an intersection between our chain fragment and the\
      \ candidate's chain."
  forHuman (TraceTermination ChainSyncClientResult
res) =
      Text
"The client has terminated. " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ChainSyncClientResult -> Text
forall a. Show a => a -> Text
showT ChainSyncClientResult
res

  forMachine :: DetailLevel -> TraceChainSyncClientEvent blk -> Object
forMachine DetailLevel
_dtal (TraceDownloadedHeader Header blk
h) =
      [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
"DownloadedHeader"
              , Tip (Header blk) -> Object
forall blk. ConvertRawHash blk => Tip blk -> Object
tipToObject (Header blk -> Tip (Header blk)
forall a. HasHeader a => a -> Tip a
tipFromHeader Header blk
h)
              ]
  forMachine DetailLevel
dtal (TraceRolledBack Point blk
tip) =
      [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
"RolledBack"
               , Key
"tip" Key -> Object -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= DetailLevel -> Point blk -> Object
forall a. LogFormatting a => DetailLevel -> a -> Object
forMachine DetailLevel
dtal Point blk
tip ]
  forMachine DetailLevel
_dtal (TraceException ChainSyncClientException
exc) =
      [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
"Exception"
               , Key
"exception" Key -> Value -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String (String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ ChainSyncClientException -> String
forall a. Show a => a -> String
show ChainSyncClientException
exc) ]
  forMachine DetailLevel
_dtal TraceFoundIntersection {} =
      [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
"FoundIntersection" ]
  forMachine DetailLevel
_dtal (TraceTermination ChainSyncClientResult
reason) =
      [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
"Termination"
               , Key
"reason" Key -> Value -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String (String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ ChainSyncClientResult -> String
forall a. Show a => a -> String
show ChainSyncClientResult
reason) ]

docChainSyncClientEvent ::
  Documented (BlockFetch.TraceLabelPeer peer (TraceChainSyncClientEvent blk))
docChainSyncClientEvent :: Documented (TraceLabelPeer peer (TraceChainSyncClientEvent blk))
docChainSyncClientEvent =
    [Text]
-> Documented (TraceLabelPeer Any (TraceChainSyncClientEvent Any))
-> Documented (TraceLabelPeer peer (TraceChainSyncClientEvent blk))
forall a b. [Text] -> Documented a -> Documented b
addDocumentedNamespace
      [Text
"ChainSyncClientEvent"]
      Documented (TraceLabelPeer Any (TraceChainSyncClientEvent Any))
forall peer blk.
Documented (TraceLabelPeer peer (TraceChainSyncClientEvent blk))
docChainSyncClientEvent'

docChainSyncClientEvent' ::
  Documented (BlockFetch.TraceLabelPeer peer (TraceChainSyncClientEvent blk))
docChainSyncClientEvent' :: Documented (TraceLabelPeer peer (TraceChainSyncClientEvent blk))
docChainSyncClientEvent' = [DocMsg (TraceLabelPeer peer (TraceChainSyncClientEvent blk))]
-> Documented (TraceLabelPeer peer (TraceChainSyncClientEvent blk))
forall a. [DocMsg a] -> Documented a
Documented [
    [Text]
-> [(Text, Text)]
-> Text
-> DocMsg (TraceLabelPeer peer (TraceChainSyncClientEvent blk))
forall a. [Text] -> [(Text, Text)] -> Text -> DocMsg a
DocMsg
      [Text
"DownloadedHeader"]
      []
      Text
"While following a candidate chain, we rolled forward by downloading a\
      \ header."
  , [Text]
-> [(Text, Text)]
-> Text
-> DocMsg (TraceLabelPeer peer (TraceChainSyncClientEvent blk))
forall a. [Text] -> [(Text, Text)] -> Text -> DocMsg a
DocMsg
      [Text
"RolledBack"]
      []
      Text
"While following a candidate chain, we rolled back to the given point."
  , [Text]
-> [(Text, Text)]
-> Text
-> DocMsg (TraceLabelPeer peer (TraceChainSyncClientEvent blk))
forall a. [Text] -> [(Text, Text)] -> Text -> DocMsg a
DocMsg
      [Text
"FoundIntersection"]
      []
      Text
"We found an intersection between our chain fragment and the\
      \ candidate's chain."
  , [Text]
-> [(Text, Text)]
-> Text
-> DocMsg (TraceLabelPeer peer (TraceChainSyncClientEvent blk))
forall a. [Text] -> [(Text, Text)] -> Text -> DocMsg a
DocMsg
      [Text
"Exception"]
      []
      Text
"An exception was thrown by the Chain Sync Client."
  , [Text]
-> [(Text, Text)]
-> Text
-> DocMsg (TraceLabelPeer peer (TraceChainSyncClientEvent blk))
forall a. [Text] -> [(Text, Text)] -> Text -> DocMsg a
DocMsg
      [Text
"Termination"]
      []
      Text
"The client has terminated."
  ]

--------------------------------------------------------------------------------
-- ChainSyncServer Tracer
--------------------------------------------------------------------------------

severityChainSyncServerEvent :: TraceChainSyncServerEvent blk -> SeverityS
severityChainSyncServerEvent :: TraceChainSyncServerEvent blk -> SeverityS
severityChainSyncServerEvent (TraceChainSyncServerUpdate Tip blk
_tip ChainUpdate blk (Point blk)
_upd BlockingType
_blocking Enclosing
enclosing) =
    case Enclosing
enclosing of
      Enclosing
RisingEdge  -> SeverityS
Info
      Enclosing
FallingEdge -> SeverityS
Debug

namesForChainSyncServerEvent :: TraceChainSyncServerEvent blk -> [Text]
namesForChainSyncServerEvent :: TraceChainSyncServerEvent blk -> [Text]
namesForChainSyncServerEvent TraceChainSyncServerEvent blk
ev =
    Text
"ChainSyncServerEvent" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: TraceChainSyncServerEvent blk -> [Text]
forall blk. TraceChainSyncServerEvent blk -> [Text]
namesForChainSyncServerEvent' TraceChainSyncServerEvent blk
ev

namesForChainSyncServerEvent' :: TraceChainSyncServerEvent blk -> [Text]
namesForChainSyncServerEvent' :: TraceChainSyncServerEvent blk -> [Text]
namesForChainSyncServerEvent' (TraceChainSyncServerUpdate Tip blk
_tip ChainUpdate blk (Point blk)
_update BlockingType
_blocking Enclosing
_enclosing) =
      [Text
"Update"]

instance ConvertRawHash blk
      => LogFormatting (TraceChainSyncServerEvent blk) where
  forMachine :: DetailLevel -> TraceChainSyncServerEvent blk -> Object
forMachine DetailLevel
dtal (TraceChainSyncServerUpdate Tip blk
tip ChainUpdate blk (Point blk)
update BlockingType
blocking Enclosing
enclosing) =
      [Object] -> Object
forall a. Monoid a => [a] -> a
mconcat ([Object] -> Object) -> [Object] -> Object
forall a b. (a -> b) -> a -> b
$
               [ Key
"kind" Key -> Value -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String Text
"ChainSyncServer.Update"
               , Key
"tip" Key -> Object -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Tip blk -> Object
forall blk. ConvertRawHash blk => Tip blk -> Object
tipToObject Tip blk
tip
               , case ChainUpdate blk (Point blk)
update of
                   AddBlock Point blk
pt -> Key
"addBlock" Key -> Text -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= DetailLevel -> Point blk -> Text
forall blk. ConvertRawHash blk => DetailLevel -> Point blk -> Text
renderPointForDetails DetailLevel
dtal Point blk
pt
                   RollBack Point blk
pt -> Key
"rollBackTo" Key -> Text -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= DetailLevel -> Point blk -> Text
forall blk. ConvertRawHash blk => DetailLevel -> Point blk -> Text
renderPointForDetails DetailLevel
dtal Point blk
pt
               , Key
"blockingRead" Key -> Bool -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= case BlockingType
blocking of BlockingType
Blocking -> Bool
True; BlockingType
NonBlocking -> Bool
False
               ]
               [Object] -> [Object] -> [Object]
forall a. Semigroup a => a -> a -> a
<> [ Key
"risingEdge" Key -> Bool -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Bool
True | Enclosing
RisingEdge <- [Enclosing
enclosing] ]

  asMetrics :: TraceChainSyncServerEvent blk -> [Metric]
asMetrics (TraceChainSyncServerUpdate Tip blk
_tip (AddBlock Point blk
_pt) BlockingType
_blocking Enclosing
FallingEdge) =
      [Text -> Maybe Int -> Metric
CounterM Text
"cardano.node.chainSync.rollForward" Maybe Int
forall a. Maybe a
Nothing]
  asMetrics TraceChainSyncServerEvent blk
_ = []


docChainSyncServerEventHeader :: Documented (TraceChainSyncServerEvent blk)
docChainSyncServerEventHeader :: Documented (TraceChainSyncServerEvent blk)
docChainSyncServerEventHeader =
    [Text]
-> Documented (TraceChainSyncServerEvent Any)
-> Documented (TraceChainSyncServerEvent blk)
forall a b. [Text] -> Documented a -> Documented b
addDocumentedNamespace
      [Text
"ChainSyncServerEvent", Text
"Update"]
      Documented (TraceChainSyncServerEvent Any)
forall blk. Documented (TraceChainSyncServerEvent blk)
docChainSyncServerEventHeader'

-- | Metrics documented here, but implemented specially
docChainSyncServerEventHeader' :: Documented (TraceChainSyncServerEvent blk)
docChainSyncServerEventHeader' :: Documented (TraceChainSyncServerEvent blk)
docChainSyncServerEventHeader' = [DocMsg (TraceChainSyncServerEvent blk)]
-> Documented (TraceChainSyncServerEvent blk)
forall a. [DocMsg a] -> Documented a
Documented [
    [Text]
-> [(Text, Text)] -> Text -> DocMsg (TraceChainSyncServerEvent blk)
forall a. [Text] -> [(Text, Text)] -> Text -> DocMsg a
DocMsg
      [Text
"Update"]
      [(Text
"cardano.node.metrics.served.header", Text
"A counter triggered only on header event")]
      Text
"A server read has occurred, either for an add block or a rollback"
  ]

docChainSyncServerEventBlock :: Documented (TraceChainSyncServerEvent blk)
docChainSyncServerEventBlock :: Documented (TraceChainSyncServerEvent blk)
docChainSyncServerEventBlock =
    [Text]
-> Documented (TraceChainSyncServerEvent Any)
-> Documented (TraceChainSyncServerEvent blk)
forall a b. [Text] -> Documented a -> Documented b
addDocumentedNamespace
      [Text
"ChainSyncServerEvent", Text
"Update"]
      Documented (TraceChainSyncServerEvent Any)
forall blk. Documented (TraceChainSyncServerEvent blk)
docChainSyncServerEventBlock'

docChainSyncServerEventBlock' :: Documented (TraceChainSyncServerEvent blk)
docChainSyncServerEventBlock' :: Documented (TraceChainSyncServerEvent blk)
docChainSyncServerEventBlock' = [DocMsg (TraceChainSyncServerEvent blk)]
-> Documented (TraceChainSyncServerEvent blk)
forall a. [DocMsg a] -> Documented a
Documented [
    [Text]
-> [(Text, Text)] -> Text -> DocMsg (TraceChainSyncServerEvent blk)
forall a. [Text] -> [(Text, Text)] -> Text -> DocMsg a
DocMsg
      [Text
"Update"]
      []
      Text
"A server read has occurred, either for an add block or a rollback"
  ]

--------------------------------------------------------------------------------
-- BlockFetchDecision Tracer
--------------------------------------------------------------------------------

severityBlockFetchDecision ::
     [BlockFetch.TraceLabelPeer peer (FetchDecision [Point header])]
  -> SeverityS
severityBlockFetchDecision :: [TraceLabelPeer peer (FetchDecision [Point header])] -> SeverityS
severityBlockFetchDecision []  = SeverityS
Info
severityBlockFetchDecision [TraceLabelPeer peer (FetchDecision [Point header])]
l   = [SeverityS] -> SeverityS
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([SeverityS] -> SeverityS) -> [SeverityS] -> SeverityS
forall a b. (a -> b) -> a -> b
$
  (TraceLabelPeer peer (FetchDecision [Point header]) -> SeverityS)
-> [TraceLabelPeer peer (FetchDecision [Point header])]
-> [SeverityS]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (\(BlockFetch.TraceLabelPeer peer
_ FetchDecision [Point header]
a) -> FetchDecision [Point header] -> SeverityS
forall a. FetchDecision a -> SeverityS
fetchDecisionSeverity FetchDecision [Point header]
a) [TraceLabelPeer peer (FetchDecision [Point header])]
l
    where
      fetchDecisionSeverity :: FetchDecision a -> SeverityS
      fetchDecisionSeverity :: FetchDecision a -> SeverityS
fetchDecisionSeverity FetchDecision a
fd =
        case FetchDecision a
fd of
          Left FetchDecline
FetchDeclineChainNotPlausible     -> SeverityS
Debug
          Left FetchDecline
FetchDeclineChainNoIntersection   -> SeverityS
Notice
          Left FetchDecline
FetchDeclineAlreadyFetched        -> SeverityS
Debug
          Left FetchDecline
FetchDeclineInFlightThisPeer      -> SeverityS
Debug
          Left FetchDecline
FetchDeclineInFlightOtherPeer     -> SeverityS
Debug
          Left FetchDecline
FetchDeclinePeerShutdown          -> SeverityS
Info
          Left FetchDecline
FetchDeclinePeerSlow              -> SeverityS
Info
          Left FetchDeclineReqsInFlightLimit {}  -> SeverityS
Info
          Left FetchDeclineBytesInFlightLimit {} -> SeverityS
Info
          Left FetchDeclinePeerBusy {}           -> SeverityS
Info
          Left FetchDeclineConcurrencyLimit {}   -> SeverityS
Info
          Right a
_                                -> SeverityS
Info

namesForBlockFetchDecision ::
     [BlockFetch.TraceLabelPeer peer (FetchDecision [Point header])]
  -> [Text]
namesForBlockFetchDecision :: [TraceLabelPeer peer (FetchDecision [Point header])] -> [Text]
namesForBlockFetchDecision [TraceLabelPeer peer (FetchDecision [Point header])]
_ = []

instance (LogFormatting peer, Show peer) =>
    LogFormatting [TraceLabelPeer peer (FetchDecision [Point header])] where
  forMachine :: DetailLevel
-> [TraceLabelPeer peer (FetchDecision [Point header])] -> Object
forMachine DetailLevel
DMinimal [TraceLabelPeer peer (FetchDecision [Point header])]
_ = Object
forall a. Monoid a => a
mempty
  forMachine DetailLevel
_ []       = [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
"EmptyPeersFetch"]
  forMachine DetailLevel
_ [TraceLabelPeer peer (FetchDecision [Point header])]
xs       = [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
"PeersFetch"
    , Key
"peers" Key -> Value -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [Object] -> Value
forall a. ToJSON a => a -> Value
toJSON
      (([Object]
 -> TraceLabelPeer peer (FetchDecision [Point header]) -> [Object])
-> [Object]
-> [TraceLabelPeer peer (FetchDecision [Point header])]
-> [Object]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\[Object]
acc TraceLabelPeer peer (FetchDecision [Point header])
x -> DetailLevel
-> TraceLabelPeer peer (FetchDecision [Point header]) -> Object
forall a. LogFormatting a => DetailLevel -> a -> Object
forMachine DetailLevel
DDetailed TraceLabelPeer peer (FetchDecision [Point header])
x Object -> [Object] -> [Object]
forall a. a -> [a] -> [a]
: [Object]
acc) [] [TraceLabelPeer peer (FetchDecision [Point header])]
xs) ]

  asMetrics :: [TraceLabelPeer peer (FetchDecision [Point header])] -> [Metric]
asMetrics [TraceLabelPeer peer (FetchDecision [Point header])]
peers = [Text -> Integer -> Metric
IntM Text
"cardano.node.connectedPeers" (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([TraceLabelPeer peer (FetchDecision [Point header])] -> Int
forall a. HasLength a => a -> Int
length [TraceLabelPeer peer (FetchDecision [Point header])]
peers))]

instance (LogFormatting peer, Show peer, LogFormatting a)
  => LogFormatting (TraceLabelPeer peer a) where
  forMachine :: DetailLevel -> TraceLabelPeer peer a -> Object
forMachine DetailLevel
dtal (TraceLabelPeer peer
peerid a
a) =
    [Object] -> Object
forall a. Monoid a => [a] -> a
mconcat [ Key
"peer" Key -> Object -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= DetailLevel -> peer -> Object
forall a. LogFormatting a => DetailLevel -> a -> Object
forMachine DetailLevel
dtal peer
peerid ] Object -> Object -> Object
forall a. Semigroup a => a -> a -> a
<> DetailLevel -> a -> Object
forall a. LogFormatting a => DetailLevel -> a -> Object
forMachine DetailLevel
dtal a
a
  forHuman :: TraceLabelPeer peer a -> Text
forHuman (TraceLabelPeer peer
peerid a
a) = Text
"Peer is " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> peer -> Text
forall a. Show a => a -> Text
showT peer
peerid
                                        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
". " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> a -> Text
forall a. LogFormatting a => a -> Text
forHuman a
a
  asMetrics :: TraceLabelPeer peer a -> [Metric]
asMetrics (TraceLabelPeer peer
_peerid a
a) = a -> [Metric]
forall a. LogFormatting a => a -> [Metric]
asMetrics a
a

instance LogFormatting (FetchDecision [Point header]) where
  forMachine :: DetailLevel -> FetchDecision [Point header] -> Object
forMachine DetailLevel
_dtal (Left FetchDecline
decline) =
    [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
"FetchDecision declined"
             , Key
"declined" Key -> Value -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String (FetchDecline -> Text
forall a. Show a => a -> Text
showT FetchDecline
decline)
             ]
  forMachine DetailLevel
_dtal (Right [Point header]
results) =
    [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
"FetchDecision results"
             , Key
"length" Key -> Value -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String (Int -> Text
forall a. Show a => a -> Text
showT (Int -> Text) -> Int -> Text
forall a b. (a -> b) -> a -> b
$ [Point header] -> Int
forall a. HasLength a => a -> Int
length [Point header]
results)
             ]

docBlockFetchDecision ::
  Documented [BlockFetch.TraceLabelPeer remotePeer (FetchDecision [Point (Header blk)])]
docBlockFetchDecision :: Documented
  [TraceLabelPeer remotePeer (FetchDecision [Point (Header blk)])]
docBlockFetchDecision = [DocMsg
   [TraceLabelPeer remotePeer (FetchDecision [Point (Header blk)])]]
-> Documented
     [TraceLabelPeer remotePeer (FetchDecision [Point (Header blk)])]
forall a. [DocMsg a] -> Documented a
Documented [
    [Text]
-> [(Text, Text)]
-> Text
-> DocMsg
     [TraceLabelPeer remotePeer (FetchDecision [Point (Header blk)])]
forall a. [Text] -> [(Text, Text)] -> Text -> DocMsg a
DocMsg
      []
      [(Text
"cardano.node.connectedPeers", Text
"Number of connected peers")]
      Text
"Throughout the decision making process we accumulate reasons to decline\
      \ to fetch any blocks. This message carries the intermediate and final\
      \ results."
  ]

--------------------------------------------------------------------------------
-- BlockFetchClient Tracer
--------------------------------------------------------------------------------

data CdfCounter = CdfCounter {
    CdfCounter -> Int64
limit :: Int64
  , CdfCounter -> Int64
counter :: Int64
}

decCdf :: Ord a => Num a => a -> CdfCounter -> CdfCounter
decCdf :: a -> CdfCounter -> CdfCounter
decCdf a
v CdfCounter
cdf =
  if a
v a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< Int64 -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CdfCounter -> Int64
limit CdfCounter
cdf)
    then CdfCounter
cdf {counter :: Int64
counter = CdfCounter -> Int64
counter CdfCounter
cdf Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
1}
    else CdfCounter
cdf

incCdf ::Ord a => Num a => a -> CdfCounter -> CdfCounter
incCdf :: a -> CdfCounter -> CdfCounter
incCdf a
v CdfCounter
cdf =
  if a
v a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< Int64 -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CdfCounter -> Int64
limit CdfCounter
cdf)
    then CdfCounter
cdf {counter :: Int64
counter = CdfCounter -> Int64
counter CdfCounter
cdf Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
1}
    else CdfCounter
cdf

data ClientMetrics = ClientMetrics {
    ClientMetrics -> IntPSQ Word64 NominalDiffTime
cmSlotMap  :: IntPSQ Word64 NominalDiffTime
  , ClientMetrics -> CdfCounter
cmCdf1sVar :: CdfCounter
  , ClientMetrics -> CdfCounter
cmCdf3sVar :: CdfCounter
  , ClientMetrics -> CdfCounter
cmCdf5sVar :: CdfCounter
  , ClientMetrics -> Double
cmDelay    :: Double
  , ClientMetrics -> Word32
cmBlockSize :: Word32
  , ClientMetrics -> Bool
cmTraceIt  :: Bool
}

instance LogFormatting ClientMetrics where
  forMachine :: DetailLevel -> ClientMetrics -> Object
forMachine DetailLevel
_dtal ClientMetrics
_ = Object
forall a. Monoid a => a
mempty
  asMetrics :: ClientMetrics -> [Metric]
asMetrics ClientMetrics {Bool
Double
Word32
IntPSQ Word64 NominalDiffTime
CdfCounter
cmTraceIt :: Bool
cmBlockSize :: Word32
cmDelay :: Double
cmCdf5sVar :: CdfCounter
cmCdf3sVar :: CdfCounter
cmCdf1sVar :: CdfCounter
cmSlotMap :: IntPSQ Word64 NominalDiffTime
cmTraceIt :: ClientMetrics -> Bool
cmBlockSize :: ClientMetrics -> Word32
cmDelay :: ClientMetrics -> Double
cmCdf5sVar :: ClientMetrics -> CdfCounter
cmCdf3sVar :: ClientMetrics -> CdfCounter
cmCdf1sVar :: ClientMetrics -> CdfCounter
cmSlotMap :: ClientMetrics -> IntPSQ Word64 NominalDiffTime
..} =
    if Bool
cmTraceIt
      then
        let  size :: Int
size = IntPSQ Word64 NominalDiffTime -> Int
forall p v. IntPSQ p v -> Int
Pq.size IntPSQ Word64 NominalDiffTime
cmSlotMap
             msgs :: [Metric]
msgs =
               [ Text -> Double -> Metric
DoubleM
                    Text
"cardano.node.metrics.blockfetchclient.blockdelay.s"
                    Double
cmDelay
               , Text -> Integer -> Metric
IntM
                    Text
"cardano.node.metrics.blockfetchclient.blocksize"
                    (Word32 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
cmBlockSize)
               , Text -> Double -> Metric
DoubleM Text
"cardano.node.metrics.blockfetchclient.blockdelay.cdfOne"
                    (Int64 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CdfCounter -> Int64
counter CdfCounter
cmCdf1sVar) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
size)
               , Text -> Double -> Metric
DoubleM Text
"cardano.node.metrics.blockfetchclient.blockdelay.cdfThree"
                    (Int64 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CdfCounter -> Int64
counter CdfCounter
cmCdf3sVar) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
size)
               , Text -> Double -> Metric
DoubleM Text
"cardano.node.metrics.blockfetchclient.blockdelay.cdfFive"
                    (Int64 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CdfCounter -> Int64
counter CdfCounter
cmCdf5sVar) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
size)
               ]
        in if Double
cmDelay Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
5
             then
               Text -> Maybe Int -> Metric
CounterM Text
"cardano.node.metrics.blockfetchclient.lateblocks" Maybe Int
forall a. Maybe a
Nothing
                 Metric -> [Metric] -> [Metric]
forall a. a -> [a] -> [a]
: [Metric]
msgs
             else [Metric]
msgs
      else []

initialClientMetrics :: ClientMetrics
initialClientMetrics :: ClientMetrics
initialClientMetrics =
    IntPSQ Word64 NominalDiffTime
-> CdfCounter
-> CdfCounter
-> CdfCounter
-> Double
-> Word32
-> Bool
-> ClientMetrics
ClientMetrics
      IntPSQ Word64 NominalDiffTime
forall p v. IntPSQ p v
Pq.empty
      (Int64 -> Int64 -> CdfCounter
CdfCounter Int64
1 Int64
0)
      (Int64 -> Int64 -> CdfCounter
CdfCounter Int64
3 Int64
0)
      (Int64 -> Int64 -> CdfCounter
CdfCounter Int64
5 Int64
0)
      Double
0
      Word32
0
      Bool
False

calculateBlockFetchClientMetrics ::
     ClientMetrics
  -> LoggingContext
  -> BlockFetch.TraceLabelPeer peer (BlockFetch.TraceFetchClientState header)
  -> IO ClientMetrics
calculateBlockFetchClientMetrics :: ClientMetrics
-> LoggingContext
-> TraceLabelPeer peer (TraceFetchClientState header)
-> IO ClientMetrics
calculateBlockFetchClientMetrics cm :: ClientMetrics
cm@ClientMetrics {Bool
Double
Word32
IntPSQ Word64 NominalDiffTime
CdfCounter
cmTraceIt :: Bool
cmBlockSize :: Word32
cmDelay :: Double
cmCdf5sVar :: CdfCounter
cmCdf3sVar :: CdfCounter
cmCdf1sVar :: CdfCounter
cmSlotMap :: IntPSQ Word64 NominalDiffTime
cmTraceIt :: ClientMetrics -> Bool
cmBlockSize :: ClientMetrics -> Word32
cmDelay :: ClientMetrics -> Double
cmCdf5sVar :: ClientMetrics -> CdfCounter
cmCdf3sVar :: ClientMetrics -> CdfCounter
cmCdf1sVar :: ClientMetrics -> CdfCounter
cmSlotMap :: ClientMetrics -> IntPSQ Word64 NominalDiffTime
..} LoggingContext
_lc
            (TraceLabelPeer peer
_ (BlockFetch.CompletedBlockFetch Point header
p PeerFetchInFlight header
_ PeerFetchInFlightLimits
_ PeerFetchStatus header
_ NominalDiffTime
forgeDelay Word32
blockSize)) =
    case Point header -> WithOrigin SlotNo
forall block. Point block -> WithOrigin SlotNo
pointSlot Point header
p of
            WithOrigin SlotNo
Origin -> ClientMetrics -> IO ClientMetrics
forall (f :: * -> *) a. Applicative f => a -> f a
pure ClientMetrics
cm {cmTraceIt :: Bool
cmTraceIt = Bool
False}  -- Nothing to do.
            At (SlotNo Word64
slotNo) -> do
               if IntPSQ Word64 NominalDiffTime -> Bool
forall p v. IntPSQ p v -> Bool
Pq.null IntPSQ Word64 NominalDiffTime
cmSlotMap Bool -> Bool -> Bool
&& NominalDiffTime
forgeDelay NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
> NominalDiffTime
20
                  then ClientMetrics -> IO ClientMetrics
forall (f :: * -> *) a. Applicative f => a -> f a
pure ClientMetrics
cm {cmTraceIt :: Bool
cmTraceIt = Bool
False} -- During startup wait until we are in sync
                  else case Int
-> IntPSQ Word64 NominalDiffTime -> Maybe (Word64, NominalDiffTime)
forall p v. Int -> IntPSQ p v -> Maybe (p, v)
Pq.lookup (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
slotNo) IntPSQ Word64 NominalDiffTime
cmSlotMap of
                        Just (Word64, NominalDiffTime)
_ -> ClientMetrics -> IO ClientMetrics
forall (f :: * -> *) a. Applicative f => a -> f a
pure ClientMetrics
cm {cmTraceIt :: Bool
cmTraceIt = Bool
False}  -- dupe, we only track the first
                        Maybe (Word64, NominalDiffTime)
Nothing -> do
                          let slotMap' :: IntPSQ Word64 NominalDiffTime
slotMap' = Int
-> Word64
-> NominalDiffTime
-> IntPSQ Word64 NominalDiffTime
-> IntPSQ Word64 NominalDiffTime
forall p v. Ord p => Int -> p -> v -> IntPSQ p v -> IntPSQ p v
Pq.insert (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
slotNo) Word64
slotNo NominalDiffTime
forgeDelay IntPSQ Word64 NominalDiffTime
cmSlotMap
                          if IntPSQ Word64 NominalDiffTime -> Int
forall p v. IntPSQ p v -> Int
Pq.size IntPSQ Word64 NominalDiffTime
slotMap' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1080 -- TODO k/2, should come from config file
                            then case IntPSQ Word64 NominalDiffTime
-> Maybe
     (Int, Word64, NominalDiffTime, IntPSQ Word64 NominalDiffTime)
forall p v. Ord p => IntPSQ p v -> Maybe (Int, p, v, IntPSQ p v)
Pq.minView IntPSQ Word64 NominalDiffTime
slotMap' of
                                 Maybe (Int, Word64, NominalDiffTime, IntPSQ Word64 NominalDiffTime)
Nothing -> ClientMetrics -> IO ClientMetrics
forall (f :: * -> *) a. Applicative f => a -> f a
pure ClientMetrics
cm {cmTraceIt :: Bool
cmTraceIt = Bool
False} -- Err. We just inserted an element!
                                 Just (Int
_, Word64
minSlotNo, NominalDiffTime
minDelay, IntPSQ Word64 NominalDiffTime
slotMap'') ->
                                   if Word64
minSlotNo Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
slotNo
                                      then ClientMetrics -> IO ClientMetrics
forall (f :: * -> *) a. Applicative f => a -> f a
pure ClientMetrics
cm {cmTraceIt :: Bool
cmTraceIt = Bool
False, cmSlotMap :: IntPSQ Word64 NominalDiffTime
cmSlotMap = IntPSQ Word64 NominalDiffTime
slotMap'}
                                      else let
                                         cdf1sVar :: CdfCounter
cdf1sVar = NominalDiffTime -> CdfCounter -> CdfCounter
forall a. (Ord a, Num a) => a -> CdfCounter -> CdfCounter
decCdf NominalDiffTime
minDelay CdfCounter
cmCdf1sVar
                                         cdf3sVar :: CdfCounter
cdf3sVar = NominalDiffTime -> CdfCounter -> CdfCounter
forall a. (Ord a, Num a) => a -> CdfCounter -> CdfCounter
decCdf NominalDiffTime
minDelay CdfCounter
cmCdf3sVar
                                         cdf5sVar :: CdfCounter
cdf5sVar = NominalDiffTime -> CdfCounter -> CdfCounter
forall a. (Ord a, Num a) => a -> CdfCounter -> CdfCounter
decCdf NominalDiffTime
minDelay CdfCounter
cmCdf5sVar
                                         cdf1sVar' :: CdfCounter
cdf1sVar' = NominalDiffTime -> CdfCounter -> CdfCounter
forall a. (Ord a, Num a) => a -> CdfCounter -> CdfCounter
incCdf NominalDiffTime
forgeDelay CdfCounter
cdf1sVar
                                         cdf3sVar' :: CdfCounter
cdf3sVar' = NominalDiffTime -> CdfCounter -> CdfCounter
forall a. (Ord a, Num a) => a -> CdfCounter -> CdfCounter
incCdf NominalDiffTime
forgeDelay CdfCounter
cdf3sVar
                                         cdf5sVar' :: CdfCounter
cdf5sVar' = NominalDiffTime -> CdfCounter -> CdfCounter
forall a. (Ord a, Num a) => a -> CdfCounter -> CdfCounter
incCdf NominalDiffTime
forgeDelay CdfCounter
cdf5sVar
                                         in ClientMetrics -> IO ClientMetrics
forall (f :: * -> *) a. Applicative f => a -> f a
pure ClientMetrics
cm {
                                              cmCdf1sVar :: CdfCounter
cmCdf1sVar  = CdfCounter
cdf1sVar'
                                            , cmCdf3sVar :: CdfCounter
cmCdf3sVar  = CdfCounter
cdf3sVar'
                                            , cmCdf5sVar :: CdfCounter
cmCdf5sVar  = CdfCounter
cdf5sVar'
                                            , cmDelay :: Double
cmDelay     = NominalDiffTime -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac  NominalDiffTime
forgeDelay
                                            , cmBlockSize :: Word32
cmBlockSize = Word32
blockSize
                                            , cmTraceIt :: Bool
cmTraceIt   = Bool
True
                                            , cmSlotMap :: IntPSQ Word64 NominalDiffTime
cmSlotMap   = IntPSQ Word64 NominalDiffTime
slotMap''}
                            else let
                               cdf1sVar' :: CdfCounter
cdf1sVar' = NominalDiffTime -> CdfCounter -> CdfCounter
forall a. (Ord a, Num a) => a -> CdfCounter -> CdfCounter
incCdf NominalDiffTime
forgeDelay CdfCounter
cmCdf1sVar
                               cdf3sVar' :: CdfCounter
cdf3sVar' = NominalDiffTime -> CdfCounter -> CdfCounter
forall a. (Ord a, Num a) => a -> CdfCounter -> CdfCounter
incCdf NominalDiffTime
forgeDelay CdfCounter
cmCdf3sVar
                               cdf5sVar' :: CdfCounter
cdf5sVar' = NominalDiffTime -> CdfCounter -> CdfCounter
forall a. (Ord a, Num a) => a -> CdfCounter -> CdfCounter
incCdf NominalDiffTime
forgeDelay CdfCounter
cmCdf5sVar
                                -- -- Wait until we have at least 45 samples before we start providing
                                -- -- cdf estimates.
                               in if IntPSQ Word64 NominalDiffTime -> Int
forall p v. IntPSQ p v -> Int
Pq.size IntPSQ Word64 NominalDiffTime
slotMap' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
45
                                    then ClientMetrics -> IO ClientMetrics
forall (f :: * -> *) a. Applicative f => a -> f a
pure ClientMetrics
cm {
                                         cmCdf1sVar :: CdfCounter
cmCdf1sVar  = CdfCounter
cdf1sVar'
                                       , cmCdf3sVar :: CdfCounter
cmCdf3sVar  = CdfCounter
cdf3sVar'
                                       , cmCdf5sVar :: CdfCounter
cmCdf5sVar  = CdfCounter
cdf5sVar'
                                       , cmDelay :: Double
cmDelay     = NominalDiffTime -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac NominalDiffTime
forgeDelay
                                       , cmBlockSize :: Word32
cmBlockSize = Word32
blockSize
                                       , cmTraceIt :: Bool
cmTraceIt   = Bool
True
                                       , cmSlotMap :: IntPSQ Word64 NominalDiffTime
cmSlotMap   = IntPSQ Word64 NominalDiffTime
slotMap'}
                                   else ClientMetrics -> IO ClientMetrics
forall (f :: * -> *) a. Applicative f => a -> f a
pure ClientMetrics
cm {
                                        cmCdf1sVar :: CdfCounter
cmCdf1sVar  = CdfCounter
cdf1sVar'
                                      , cmCdf3sVar :: CdfCounter
cmCdf3sVar  = CdfCounter
cdf3sVar'
                                      , cmCdf5sVar :: CdfCounter
cmCdf5sVar  = CdfCounter
cdf5sVar'
                                      , cmTraceIt :: Bool
cmTraceIt   = Bool
False
                                      , cmSlotMap :: IntPSQ Word64 NominalDiffTime
cmSlotMap   = IntPSQ Word64 NominalDiffTime
slotMap'}

calculateBlockFetchClientMetrics ClientMetrics
cm LoggingContext
_lc TraceLabelPeer peer (TraceFetchClientState header)
_ = ClientMetrics -> IO ClientMetrics
forall (f :: * -> *) a. Applicative f => a -> f a
pure ClientMetrics
cm

severityBlockFetchClient ::
     BlockFetch.TraceLabelPeer peer (BlockFetch.TraceFetchClientState header)
  -> SeverityS
severityBlockFetchClient :: TraceLabelPeer peer (TraceFetchClientState header) -> SeverityS
severityBlockFetchClient (BlockFetch.TraceLabelPeer peer
_p TraceFetchClientState header
bf) = TraceFetchClientState header -> SeverityS
forall header. TraceFetchClientState header -> SeverityS
severityBlockFetchClient' TraceFetchClientState header
bf

severityBlockFetchClient' ::
     BlockFetch.TraceFetchClientState header
  -> SeverityS
severityBlockFetchClient' :: TraceFetchClientState header -> SeverityS
severityBlockFetchClient' BlockFetch.AddedFetchRequest {}        = SeverityS
Info
severityBlockFetchClient' BlockFetch.AcknowledgedFetchRequest {} = SeverityS
Info
severityBlockFetchClient' BlockFetch.SendFetchRequest {}         = SeverityS
Info
severityBlockFetchClient' BlockFetch.StartedFetchBatch {}        = SeverityS
Info
severityBlockFetchClient' BlockFetch.CompletedBlockFetch {}      = SeverityS
Info
severityBlockFetchClient' BlockFetch.CompletedFetchBatch {}      = SeverityS
Info
severityBlockFetchClient' BlockFetch.RejectedFetchBatch {}       = SeverityS
Info
severityBlockFetchClient' BlockFetch.ClientTerminating {}        = SeverityS
Notice

namesForBlockFetchClient ::
    BlockFetch.TraceLabelPeer peer (BlockFetch.TraceFetchClientState header)
  -> [Text]
namesForBlockFetchClient :: TraceLabelPeer peer (TraceFetchClientState header) -> [Text]
namesForBlockFetchClient (BlockFetch.TraceLabelPeer peer
_p TraceFetchClientState header
bf) = TraceFetchClientState header -> [Text]
forall header. TraceFetchClientState header -> [Text]
namesForBlockFetchClient' TraceFetchClientState header
bf

namesForBlockFetchClient' ::
    BlockFetch.TraceFetchClientState header
  -> [Text]
namesForBlockFetchClient' :: TraceFetchClientState header -> [Text]
namesForBlockFetchClient' BlockFetch.AddedFetchRequest {} =
  [Text
"AddedFetchRequest"]
namesForBlockFetchClient' BlockFetch.AcknowledgedFetchRequest {}  =
  [Text
"AcknowledgedFetchRequest"]
namesForBlockFetchClient' BlockFetch.SendFetchRequest {} =
  [Text
"SendFetchRequest"]
namesForBlockFetchClient' BlockFetch.StartedFetchBatch {} =
  [Text
"StartedFetchBatch"]
namesForBlockFetchClient' BlockFetch.CompletedFetchBatch {} =
  [Text
"CompletedFetchBatch"]
namesForBlockFetchClient' BlockFetch.CompletedBlockFetch  {} =
  [Text
"CompletedBlockFetch"]
namesForBlockFetchClient' BlockFetch.RejectedFetchBatch  {} =
  [Text
"RejectedFetchBatch"]
namesForBlockFetchClient' BlockFetch.ClientTerminating {} =
  [Text
"ClientTerminating"]


instance (HasHeader header, ConvertRawHash header) =>
  LogFormatting (BlockFetch.TraceFetchClientState header) where
  forMachine :: DetailLevel -> TraceFetchClientState header -> Object
forMachine DetailLevel
_dtal BlockFetch.AddedFetchRequest {} =
    [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
"AddedFetchRequest" ]
  forMachine DetailLevel
_dtal BlockFetch.AcknowledgedFetchRequest {} =
    [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
"AcknowledgedFetchRequest" ]
  forMachine DetailLevel
_dtal (BlockFetch.SendFetchRequest AnchoredFragment header
af) =
    [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
"SendFetchRequest"
            , Key
"head" Key -> Value -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String ((HeaderHash header -> Text) -> ChainHash header -> Text
forall blk. (HeaderHash blk -> Text) -> ChainHash blk -> Text
renderChainHash
                                 (Proxy header -> HeaderHash header -> Text
forall blk (proxy :: * -> *).
ConvertRawHash blk =>
proxy blk -> HeaderHash blk -> Text
renderHeaderHash (Proxy header
forall k (t :: k). Proxy t
Proxy @header))
                                 (AnchoredFragment header -> ChainHash header
forall block.
HasHeader block =>
AnchoredFragment block -> ChainHash block
AF.headHash AnchoredFragment header
af))
            , Key
"length" Key -> Value -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Int -> Value
forall a. ToJSON a => a -> Value
toJSON (AnchoredFragment header -> Int
fragmentLength AnchoredFragment header
af)]
   where
     -- NOTE: this ignores the Byron era with its EBB complication:
     -- the length would be underestimated by 1, if the AF is anchored
     -- at the epoch boundary.
     fragmentLength :: AF.AnchoredFragment header -> Int
     fragmentLength :: AnchoredFragment header -> Int
fragmentLength AnchoredFragment header
f = Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Int) -> (BlockNo -> Word64) -> BlockNo -> Int
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. BlockNo -> Word64
unBlockNo (BlockNo -> Int) -> BlockNo -> Int
forall a b. (a -> b) -> a -> b
$
        case (AnchoredFragment header
f, AnchoredFragment header
f) of
          (AS.Empty{}, AS.Empty{}) -> BlockNo
0
          (header
firstHdr AS.:< AnchoredFragment header
_, AnchoredFragment header
_ AS.:> header
lastHdr) ->
            header -> BlockNo
forall b. HasHeader b => b -> BlockNo
blockNo header
lastHdr BlockNo -> BlockNo -> BlockNo
forall a. Num a => a -> a -> a
- header -> BlockNo
forall b. HasHeader b => b -> BlockNo
blockNo header
firstHdr BlockNo -> BlockNo -> BlockNo
forall a. Num a => a -> a -> a
+ BlockNo
1
  forMachine DetailLevel
_dtal (BlockFetch.CompletedBlockFetch Point header
pt PeerFetchInFlight header
_ PeerFetchInFlightLimits
_ PeerFetchStatus header
_ NominalDiffTime
delay Word32
blockSize) =
    [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
"CompletedBlockFetch"
            , Key
"delay" Key -> Double -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (NominalDiffTime -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac NominalDiffTime
delay :: Double)
            , Key
"size"  Key -> Word32 -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Word32
blockSize
            , Key
"block" Key -> Value -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String
              (case Point header
pt of
                 Point header
GenesisPoint -> Text
"Genesis"
                 BlockPoint SlotNo
_ HeaderHash header
h -> Proxy header -> HeaderHash header -> Text
forall blk (proxy :: * -> *).
ConvertRawHash blk =>
proxy blk -> HeaderHash blk -> Text
renderHeaderHash (Proxy header
forall k (t :: k). Proxy t
Proxy @header) HeaderHash header
h)
            ]
  forMachine DetailLevel
_dtal BlockFetch.CompletedFetchBatch {} =
    [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
"CompletedFetchBatch" ]
  forMachine DetailLevel
_dtal BlockFetch.StartedFetchBatch {} =
    [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
"StartedFetchBatch" ]
  forMachine DetailLevel
_dtal BlockFetch.RejectedFetchBatch {} =
    [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
"RejectedFetchBatch" ]
  forMachine DetailLevel
_dtal (BlockFetch.ClientTerminating Int
outstanding) =
    [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
"ClientTerminating"
            , Key
"outstanding" Key -> Int -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Int
outstanding
            ]


docBlockFetchClient ::
  Documented (BlockFetch.TraceLabelPeer remotePeer (BlockFetch.TraceFetchClientState (Header blk)))
docBlockFetchClient :: Documented
  (TraceLabelPeer remotePeer (TraceFetchClientState (Header blk)))
docBlockFetchClient = [Text]
-> Documented
     (TraceLabelPeer Any (TraceFetchClientState (Header Any)))
-> Documented
     (TraceLabelPeer remotePeer (TraceFetchClientState (Header blk)))
forall a b. [Text] -> Documented a -> Documented b
addDocumentedNamespace [] Documented
  (TraceLabelPeer Any (TraceFetchClientState (Header Any)))
forall remotePeer blk.
Documented
  (TraceLabelPeer remotePeer (TraceFetchClientState (Header blk)))
docBlockFetchClient'

docBlockFetchClient' ::
  Documented (BlockFetch.TraceLabelPeer remotePeer (BlockFetch.TraceFetchClientState (Header blk)))
docBlockFetchClient' :: Documented
  (TraceLabelPeer remotePeer (TraceFetchClientState (Header blk)))
docBlockFetchClient' = [DocMsg
   (TraceLabelPeer remotePeer (TraceFetchClientState (Header blk)))]
-> Documented
     (TraceLabelPeer remotePeer (TraceFetchClientState (Header blk)))
forall a. [DocMsg a] -> Documented a
Documented [
    [Text]
-> [(Text, Text)]
-> Text
-> DocMsg
     (TraceLabelPeer remotePeer (TraceFetchClientState (Header blk)))
forall a. [Text] -> [(Text, Text)] -> Text -> DocMsg a
DocMsg
      [Text
"AddedFetchRequest"]
      []
      Text
"The block fetch decision thread has added a new fetch instruction\
      \ consisting of one or more individual request ranges."
  ,
    [Text]
-> [(Text, Text)]
-> Text
-> DocMsg
     (TraceLabelPeer remotePeer (TraceFetchClientState (Header blk)))
forall a. [Text] -> [(Text, Text)] -> Text -> DocMsg a
DocMsg
      [Text
"AcknowledgedFetchRequest"]
      []
      Text
"Mark the point when the fetch client picks up the request added\
      \ by the block fetch decision thread. Note that this event can happen\
      \ fewer times than the 'AddedFetchRequest' due to fetch request merging."
  ,
    [Text]
-> [(Text, Text)]
-> Text
-> DocMsg
     (TraceLabelPeer remotePeer (TraceFetchClientState (Header blk)))
forall a. [Text] -> [(Text, Text)] -> Text -> DocMsg a
DocMsg
      [Text
"SendFetchRequest"]
      []
      Text
"Mark the point when fetch request for a fragment is actually sent\
       \ over the wire."
  ,
    [Text]
-> [(Text, Text)]
-> Text
-> DocMsg
     (TraceLabelPeer remotePeer (TraceFetchClientState (Header blk)))
forall a. [Text] -> [(Text, Text)] -> Text -> DocMsg a
DocMsg
      [Text
"StartedFetchBatch"]
      []
      Text
"Mark the start of receiving a streaming batch of blocks. This will\
      \ be followed by one or more 'CompletedBlockFetch' and a final\
      \ 'CompletedFetchBatch'"
  ,
    [Text]
-> [(Text, Text)]
-> Text
-> DocMsg
     (TraceLabelPeer remotePeer (TraceFetchClientState (Header blk)))
forall a. [Text] -> [(Text, Text)] -> Text -> DocMsg a
DocMsg
      [Text
"CompletedFetchBatch"]
      []
      Text
"Mark the successful end of receiving a streaming batch of blocks"
  ,
    [Text]
-> [(Text, Text)]
-> Text
-> DocMsg
     (TraceLabelPeer remotePeer (TraceFetchClientState (Header blk)))
forall a. [Text] -> [(Text, Text)] -> Text -> DocMsg a
DocMsg
      [Text
"CompletedBlockFetch"]
      []
      Text
"Mark the successful end of receiving a streaming batch of blocks."
  ,
    [Text]
-> [(Text, Text)]
-> Text
-> DocMsg
     (TraceLabelPeer remotePeer (TraceFetchClientState (Header blk)))
forall a. [Text] -> [(Text, Text)] -> Text -> DocMsg a
DocMsg
      [Text
"RejectedFetchBatch"]
      []
      Text
"If the other peer rejects our request then we have this event\
      \ instead of 'StartedFetchBatch' and 'CompletedFetchBatch'."
  ,
    [Text]
-> [(Text, Text)]
-> Text
-> DocMsg
     (TraceLabelPeer remotePeer (TraceFetchClientState (Header blk)))
forall a. [Text] -> [(Text, Text)] -> Text -> DocMsg a
DocMsg
      [Text
"ClientTerminating"]
      []
      Text
"The client is terminating.  Log the number of outstanding\
      \ requests."
  ]

--------------------------------------------------------------------------------
-- BlockFetchServer Tracer
--------------------------------------------------------------------------------

severityBlockFetchServer ::
     TraceBlockFetchServerEvent blk
  -> SeverityS
severityBlockFetchServer :: TraceBlockFetchServerEvent blk -> SeverityS
severityBlockFetchServer TraceBlockFetchServerEvent blk
_ = SeverityS
Info

namesForBlockFetchServer ::
     TraceBlockFetchServerEvent blk
  -> [Text]
namesForBlockFetchServer :: TraceBlockFetchServerEvent blk -> [Text]
namesForBlockFetchServer TraceBlockFetchServerSendBlock {} = [Text
"SendBlock"]

instance ConvertRawHash blk => LogFormatting (TraceBlockFetchServerEvent blk) where
  forMachine :: DetailLevel -> TraceBlockFetchServerEvent blk -> Object
forMachine DetailLevel
_dtal (TraceBlockFetchServerSendBlock Point blk
blk) =
    [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
"BlockFetchServer"
             , Key
"block" Key -> Value -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String ((HeaderHash blk -> Text) -> ChainHash blk -> Text
forall blk. (HeaderHash blk -> Text) -> ChainHash blk -> Text
renderChainHash
                                    @blk
                                    (Proxy blk -> HeaderHash blk -> Text
forall blk (proxy :: * -> *).
ConvertRawHash blk =>
proxy blk -> HeaderHash blk -> Text
renderHeaderHash (Proxy blk
forall k (t :: k). Proxy t
Proxy @blk))
                                    (ChainHash blk -> Text) -> ChainHash blk -> Text
forall a b. (a -> b) -> a -> b
$ Point blk -> ChainHash blk
forall block. Point block -> ChainHash block
pointHash Point blk
blk)]
-- TODO JNF
  asMetrics :: TraceBlockFetchServerEvent blk -> [Metric]
asMetrics (TraceBlockFetchServerSendBlock Point blk
_p) =
    [Text -> Maybe Int -> Metric
CounterM Text
"cardano.node.served.block" Maybe Int
forall a. Maybe a
Nothing]


docBlockFetchServer ::
  Documented (TraceBlockFetchServerEvent blk)
docBlockFetchServer :: Documented (TraceBlockFetchServerEvent blk)
docBlockFetchServer = [Text]
-> Documented (TraceBlockFetchServerEvent Any)
-> Documented (TraceBlockFetchServerEvent blk)
forall a b. [Text] -> Documented a -> Documented b
addDocumentedNamespace [] Documented (TraceBlockFetchServerEvent Any)
forall blk. Documented (TraceBlockFetchServerEvent blk)
docBlockFetchServer'


docBlockFetchServer' ::
  Documented (TraceBlockFetchServerEvent blk)
docBlockFetchServer' :: Documented (TraceBlockFetchServerEvent blk)
docBlockFetchServer' = [DocMsg (TraceBlockFetchServerEvent blk)]
-> Documented (TraceBlockFetchServerEvent blk)
forall a. [DocMsg a] -> Documented a
Documented [
    [Text]
-> [(Text, Text)]
-> Text
-> DocMsg (TraceBlockFetchServerEvent blk)
forall a. [Text] -> [(Text, Text)] -> Text -> DocMsg a
DocMsg
      [Text
"SendBlock"]
      [(Text
"cardano.node.served.block", Text
"")]
      Text
"The server sent a block to the peer."
  ]


--------------------------------------------------------------------------------
-- TxInbound Tracer
--------------------------------------------------------------------------------

severityTxInbound ::
    BlockFetch.TraceLabelPeer peer (TraceTxSubmissionInbound (GenTxId blk) (GenTx blk))
  -> SeverityS
severityTxInbound :: TraceLabelPeer
  peer (TraceTxSubmissionInbound (GenTxId blk) (GenTx blk))
-> SeverityS
severityTxInbound (BlockFetch.TraceLabelPeer peer
_p TraceTxSubmissionInbound (GenTxId blk) (GenTx blk)
ti) = TraceTxSubmissionInbound (GenTxId blk) (GenTx blk) -> SeverityS
forall blk.
TraceTxSubmissionInbound (GenTxId blk) (GenTx blk) -> SeverityS
severityTxInbound' TraceTxSubmissionInbound (GenTxId blk) (GenTx blk)
ti

severityTxInbound' ::
    TraceTxSubmissionInbound (GenTxId blk) (GenTx blk)
  -> SeverityS
severityTxInbound' :: TraceTxSubmissionInbound (GenTxId blk) (GenTx blk) -> SeverityS
severityTxInbound' TraceTxSubmissionCollected {}         = SeverityS
Debug
severityTxInbound' TraceTxSubmissionProcessed {}         = SeverityS
Debug
severityTxInbound' TraceTxSubmissionInbound (GenTxId blk) (GenTx blk)
TraceTxInboundTerminated              = SeverityS
Notice
severityTxInbound' TraceTxInboundCannotRequestMoreTxs {} = SeverityS
Debug
severityTxInbound' TraceTxInboundCanRequestMoreTxs {}    = SeverityS
Debug

namesForTxInbound ::
    BlockFetch.TraceLabelPeer peer (TraceTxSubmissionInbound (GenTxId blk) (GenTx blk))
  -> [Text]
namesForTxInbound :: TraceLabelPeer
  peer (TraceTxSubmissionInbound (GenTxId blk) (GenTx blk))
-> [Text]
namesForTxInbound (BlockFetch.TraceLabelPeer peer
_p TraceTxSubmissionInbound (GenTxId blk) (GenTx blk)
ti) = TraceTxSubmissionInbound (GenTxId blk) (GenTx blk) -> [Text]
forall blk.
TraceTxSubmissionInbound (GenTxId blk) (GenTx blk) -> [Text]
namesForTxInbound' TraceTxSubmissionInbound (GenTxId blk) (GenTx blk)
ti

namesForTxInbound' ::
    TraceTxSubmissionInbound (GenTxId blk) (GenTx blk)
  -> [Text]
namesForTxInbound' :: TraceTxSubmissionInbound (GenTxId blk) (GenTx blk) -> [Text]
namesForTxInbound' (TraceTxSubmissionCollected Int
_) =
    [Text
"TxSubmissionCollected"]
namesForTxInbound' (TraceTxSubmissionProcessed ProcessedTxCount
_) =
    [Text
"TxSubmissionProcessed"]
namesForTxInbound' TraceTxSubmissionInbound (GenTxId blk) (GenTx blk)
TraceTxInboundTerminated   =
    [Text
"TxInboundTerminated"]
namesForTxInbound' TraceTxInboundCanRequestMoreTxs {} =
    [Text
"TxInboundCanRequestMoreTxs"]
namesForTxInbound' TraceTxInboundCannotRequestMoreTxs {} =
    [Text
"TxInboundCannotRequestMoreTxs"]

instance LogFormatting (TraceTxSubmissionInbound txid tx) where
  forMachine :: DetailLevel -> TraceTxSubmissionInbound txid tx -> Object
forMachine DetailLevel
_dtal (TraceTxSubmissionCollected Int
count) =
    [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
"TraceTxSubmissionCollected"
      , Key
"count" Key -> Value -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Int -> Value
forall a. ToJSON a => a -> Value
toJSON Int
count
      ]
  forMachine DetailLevel
_dtal (TraceTxSubmissionProcessed ProcessedTxCount
processed) =
    [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
"TraceTxSubmissionProcessed"
      , Key
"accepted" Key -> Value -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Int -> Value
forall a. ToJSON a => a -> Value
toJSON (ProcessedTxCount -> Int
ptxcAccepted ProcessedTxCount
processed)
      , Key
"rejected" Key -> Value -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Int -> Value
forall a. ToJSON a => a -> Value
toJSON (ProcessedTxCount -> Int
ptxcRejected ProcessedTxCount
processed)
      ]
  forMachine DetailLevel
_dtal TraceTxSubmissionInbound txid tx
TraceTxInboundTerminated =
    [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
"TraceTxInboundTerminated"
      ]
  forMachine DetailLevel
_dtal (TraceTxInboundCanRequestMoreTxs Int
count) =
    [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
"TraceTxInboundCanRequestMoreTxs"
      , Key
"count" Key -> Value -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Int -> Value
forall a. ToJSON a => a -> Value
toJSON Int
count
      ]
  forMachine DetailLevel
_dtal (TraceTxInboundCannotRequestMoreTxs Int
count) =
    [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
"TraceTxInboundCannotRequestMoreTxs"
      , Key
"count" Key -> Value -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Int -> Value
forall a. ToJSON a => a -> Value
toJSON Int
count
      ]

  asMetrics :: TraceTxSubmissionInbound txid tx -> [Metric]
asMetrics (TraceTxSubmissionCollected Int
count)=
    [Text -> Maybe Int -> Metric
CounterM Text
"cardano.node.submissions.submitted" (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
count)]
  asMetrics (TraceTxSubmissionProcessed ProcessedTxCount
processed) =
    [ Text -> Maybe Int -> Metric
CounterM Text
"cardano.node.submissions.accepted"
        (Int -> Maybe Int
forall a. a -> Maybe a
Just (ProcessedTxCount -> Int
ptxcAccepted ProcessedTxCount
processed))
    , Text -> Maybe Int -> Metric
CounterM Text
"cardano.node.submissions.rejected"
        (Int -> Maybe Int
forall a. a -> Maybe a
Just (ProcessedTxCount -> Int
ptxcRejected ProcessedTxCount
processed))
    ]
  asMetrics TraceTxSubmissionInbound txid tx
_ = []

docTxInbound ::
  Documented (BlockFetch.TraceLabelPeer remotePeer
    (TraceTxSubmissionInbound txid tx))
docTxInbound :: Documented
  (TraceLabelPeer remotePeer (TraceTxSubmissionInbound txid tx))
docTxInbound = [Text]
-> Documented
     (TraceLabelPeer Any (TraceTxSubmissionInbound Any Any))
-> Documented
     (TraceLabelPeer remotePeer (TraceTxSubmissionInbound txid tx))
forall a b. [Text] -> Documented a -> Documented b
addDocumentedNamespace [] Documented (TraceLabelPeer Any (TraceTxSubmissionInbound Any Any))
forall remotePeer txid tx.
Documented
  (TraceLabelPeer remotePeer (TraceTxSubmissionInbound txid tx))
docTxInbound'

docTxInbound' ::
  Documented (BlockFetch.TraceLabelPeer remotePeer
    (TraceTxSubmissionInbound txid tx))
docTxInbound' :: Documented
  (TraceLabelPeer remotePeer (TraceTxSubmissionInbound txid tx))
docTxInbound' = [DocMsg
   (TraceLabelPeer remotePeer (TraceTxSubmissionInbound txid tx))]
-> Documented
     (TraceLabelPeer remotePeer (TraceTxSubmissionInbound txid tx))
forall a. [DocMsg a] -> Documented a
Documented [
    [Text]
-> [(Text, Text)]
-> Text
-> DocMsg
     (TraceLabelPeer remotePeer (TraceTxSubmissionInbound txid tx))
forall a. [Text] -> [(Text, Text)] -> Text -> DocMsg a
DocMsg
    [Text
"TxSubmissionCollected"]
    [ (Text
"cardano.node.submissions.submitted", Text
"")]
    Text
"Number of transactions just about to be inserted."
  ,
    [Text]
-> [(Text, Text)]
-> Text
-> DocMsg
     (TraceLabelPeer remotePeer (TraceTxSubmissionInbound txid tx))
forall a. [Text] -> [(Text, Text)] -> Text -> DocMsg a
DocMsg
    [Text
"TxSubmissionProcessed"]
    [ (Text
"cardano.node.submissions.accepted", Text
"")
    , (Text
"cardano.node.submissions.rejected", Text
"")
    ]
    Text
"Just processed transaction pass/fail breakdown."
  ,
    [Text]
-> [(Text, Text)]
-> Text
-> DocMsg
     (TraceLabelPeer remotePeer (TraceTxSubmissionInbound txid tx))
forall a. [Text] -> [(Text, Text)] -> Text -> DocMsg a
DocMsg
    [Text
"TxInboundTerminated"]
    []
    Text
"Server received 'MsgDone'."
  ,
    [Text]
-> [(Text, Text)]
-> Text
-> DocMsg
     (TraceLabelPeer remotePeer (TraceTxSubmissionInbound txid tx))
forall a. [Text] -> [(Text, Text)] -> Text -> DocMsg a
DocMsg
    [Text
"TxInboundCanRequestMoreTxs"]
    []
    Text
"There are no replies in flight, but we do know some more txs we\
    \ can ask for, so lets ask for them and more txids."
  ,
    [Text]
-> [(Text, Text)]
-> Text
-> DocMsg
     (TraceLabelPeer remotePeer (TraceTxSubmissionInbound txid tx))
forall a. [Text] -> [(Text, Text)] -> Text -> DocMsg a
DocMsg
    [Text
"TxInboundCannotRequestMoreTxs"]
    []
    Text
"There's no replies in flight, and we have no more txs we can\
    \ ask for so the only remaining thing to do is to ask for more\
    \ txids. Since this is the only thing to do now, we make this a\
    \ blocking call."
  ]


--------------------------------------------------------------------------------
-- TxOutbound Tracer
--------------------------------------------------------------------------------

severityTxOutbound ::
    BlockFetch.TraceLabelPeer peer (TraceTxSubmissionOutbound (GenTxId blk) (GenTx blk))
  -> SeverityS
severityTxOutbound :: TraceLabelPeer
  peer (TraceTxSubmissionOutbound (GenTxId blk) (GenTx blk))
-> SeverityS
severityTxOutbound (BlockFetch.TraceLabelPeer peer
_p TraceTxSubmissionOutbound (GenTxId blk) (GenTx blk)
_ti) = SeverityS
Info

namesForTxOutbound ::
    BlockFetch.TraceLabelPeer peer (TraceTxSubmissionOutbound (GenTxId blk) (GenTx blk))
  -> [Text]
namesForTxOutbound :: TraceLabelPeer
  peer (TraceTxSubmissionOutbound (GenTxId blk) (GenTx blk))
-> [Text]
namesForTxOutbound (BlockFetch.TraceLabelPeer peer
_p TraceTxSubmissionOutbound (GenTxId blk) (GenTx blk)
ti) = TraceTxSubmissionOutbound (GenTxId blk) (GenTx blk) -> [Text]
forall blk.
TraceTxSubmissionOutbound (GenTxId blk) (GenTx blk) -> [Text]
namesForTxOutbound' TraceTxSubmissionOutbound (GenTxId blk) (GenTx blk)
ti

namesForTxOutbound' ::
    TraceTxSubmissionOutbound (GenTxId blk) (GenTx blk)
  -> [Text]
namesForTxOutbound' :: TraceTxSubmissionOutbound (GenTxId blk) (GenTx blk) -> [Text]
namesForTxOutbound' TraceTxSubmissionOutboundRecvMsgRequestTxs {} =
    [Text
"TxSubmissionOutboundRecvMsgRequest"]
namesForTxOutbound' TraceTxSubmissionOutboundSendMsgReplyTxs {} =
    [Text
"TxSubmissionOutboundSendMsgReply"]
namesForTxOutbound' TraceControlMessage {} =
    [Text
"ControlMessage"]

instance (Show txid, Show tx)
      => LogFormatting (TraceTxSubmissionOutbound txid tx) where
  forMachine :: DetailLevel -> TraceTxSubmissionOutbound txid tx -> Object
forMachine DetailLevel
DDetailed (TraceTxSubmissionOutboundRecvMsgRequestTxs [txid]
txids) =
    [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
"TraceTxSubmissionOutboundRecvMsgRequestTxs"
      , Key
"txIds" Key -> Value -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String (String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ [txid] -> String
forall a. Show a => a -> String
show [txid]
txids)
      ]
  forMachine DetailLevel
_dtal (TraceTxSubmissionOutboundRecvMsgRequestTxs [txid]
_txids) =
    [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
"TraceTxSubmissionOutboundRecvMsgRequestTxs"
      ]
  forMachine DetailLevel
DDetailed (TraceTxSubmissionOutboundSendMsgReplyTxs [tx]
txs) =
    [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
"TraceTxSubmissionOutboundSendMsgReplyTxs"
      , Key
"txs" Key -> Value -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String (String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ [tx] -> String
forall a. Show a => a -> String
show [tx]
txs)
      ]
  forMachine DetailLevel
_dtal (TraceTxSubmissionOutboundSendMsgReplyTxs [tx]
_txs) =
    [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
"TraceTxSubmissionOutboundSendMsgReplyTxs"
      ]
  forMachine DetailLevel
_dtal (TraceControlMessage ControlMessage
_msg) =
    [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
"TraceControlMessage"
      ]

docTxOutbound :: forall remotePeer txid tx.
  Documented (BlockFetch.TraceLabelPeer remotePeer
    (TraceTxSubmissionOutbound txid tx))
docTxOutbound :: Documented
  (TraceLabelPeer remotePeer (TraceTxSubmissionOutbound txid tx))
docTxOutbound =  [Text]
-> Documented
     (TraceLabelPeer Any (TraceTxSubmissionOutbound Any Any))
-> Documented
     (TraceLabelPeer remotePeer (TraceTxSubmissionOutbound txid tx))
forall a b. [Text] -> Documented a -> Documented b
addDocumentedNamespace [] Documented (TraceLabelPeer Any (TraceTxSubmissionOutbound Any Any))
forall remotePeer txid tx.
Documented
  (TraceLabelPeer remotePeer (TraceTxSubmissionOutbound txid tx))
docTxOutbound'

docTxOutbound' :: forall remotePeer txid tx.
  Documented (BlockFetch.TraceLabelPeer remotePeer
    (TraceTxSubmissionOutbound txid tx))
docTxOutbound' :: Documented
  (TraceLabelPeer remotePeer (TraceTxSubmissionOutbound txid tx))
docTxOutbound' = [DocMsg
   (TraceLabelPeer remotePeer (TraceTxSubmissionOutbound txid tx))]
-> Documented
     (TraceLabelPeer remotePeer (TraceTxSubmissionOutbound txid tx))
forall a. [DocMsg a] -> Documented a
Documented [
    [Text]
-> [(Text, Text)]
-> Text
-> DocMsg
     (TraceLabelPeer remotePeer (TraceTxSubmissionOutbound txid tx))
forall a. [Text] -> [(Text, Text)] -> Text -> DocMsg a
DocMsg
    [Text
"RecvMsgRequest"]
    []
    Text
"The IDs of the transactions requested."
  ,
    [Text]
-> [(Text, Text)]
-> Text
-> DocMsg
     (TraceLabelPeer remotePeer (TraceTxSubmissionOutbound txid tx))
forall a. [Text] -> [(Text, Text)] -> Text -> DocMsg a
DocMsg
    [Text
"SendMsgReply"]
    []
    Text
"The transactions to be sent in the response."
  ,
    [Text]
-> [(Text, Text)]
-> Text
-> DocMsg
     (TraceLabelPeer remotePeer (TraceTxSubmissionOutbound txid tx))
forall a. [Text] -> [(Text, Text)] -> Text -> DocMsg a
DocMsg
    [Text
"ControlMessage"]
    []
    Text
""
  ]

--------------------------------------------------------------------------------
-- TxSubmissionServer Tracer
--------------------------------------------------------------------------------

severityLocalTxSubmissionServer ::
     TraceLocalTxSubmissionServerEvent blk
  -> SeverityS
severityLocalTxSubmissionServer :: TraceLocalTxSubmissionServerEvent blk -> SeverityS
severityLocalTxSubmissionServer TraceLocalTxSubmissionServerEvent blk
_ = SeverityS
Info

namesForLocalTxSubmissionServer ::
  TraceLocalTxSubmissionServerEvent blk
  -> [Text]
namesForLocalTxSubmissionServer :: TraceLocalTxSubmissionServerEvent blk -> [Text]
namesForLocalTxSubmissionServer TraceReceivedTx {} = [Text
"ReceivedTx"]

instance LogFormatting (TraceLocalTxSubmissionServerEvent blk) where
  forMachine :: DetailLevel -> TraceLocalTxSubmissionServerEvent blk -> Object
forMachine DetailLevel
_dtal (TraceReceivedTx GenTx blk
_gtx) =
    [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
"ReceivedTx" ]

docLocalTxSubmissionServer :: Documented (TraceLocalTxSubmissionServerEvent blk)
docLocalTxSubmissionServer :: Documented (TraceLocalTxSubmissionServerEvent blk)
docLocalTxSubmissionServer =
    [Text]
-> Documented (TraceLocalTxSubmissionServerEvent Any)
-> Documented (TraceLocalTxSubmissionServerEvent blk)
forall a b. [Text] -> Documented a -> Documented b
addDocumentedNamespace [] Documented (TraceLocalTxSubmissionServerEvent Any)
forall blk. Documented (TraceLocalTxSubmissionServerEvent blk)
docLocalTxSubmissionServer'

docLocalTxSubmissionServer' :: Documented (TraceLocalTxSubmissionServerEvent blk)
docLocalTxSubmissionServer' :: Documented (TraceLocalTxSubmissionServerEvent blk)
docLocalTxSubmissionServer' = [DocMsg (TraceLocalTxSubmissionServerEvent blk)]
-> Documented (TraceLocalTxSubmissionServerEvent blk)
forall a. [DocMsg a] -> Documented a
Documented [
    [Text]
-> [(Text, Text)]
-> Text
-> DocMsg (TraceLocalTxSubmissionServerEvent blk)
forall a. [Text] -> [(Text, Text)] -> Text -> DocMsg a
DocMsg
    [Text
"ReceivedTx"]
    []
    Text
"A transaction was received."
  ]

--------------------------------------------------------------------------------
-- Mempool Tracer
--------------------------------------------------------------------------------

severityMempool ::
     TraceEventMempool blk
  -> SeverityS
severityMempool :: TraceEventMempool blk -> SeverityS
severityMempool TraceEventMempool blk
_ = SeverityS
Info

namesForMempool :: TraceEventMempool blk -> [Text]
namesForMempool :: TraceEventMempool blk -> [Text]
namesForMempool TraceMempoolAddedTx {}            = [Text
"AddedTx"]
namesForMempool TraceMempoolRejectedTx {}         = [Text
"RejectedTx"]
namesForMempool TraceMempoolRemoveTxs {}          = [Text
"RemoveTxs"]
namesForMempool TraceMempoolManuallyRemovedTxs {} = [Text
"ManuallyRemovedTxs"]

instance
  ( Show (ApplyTxErr blk)
  , LogFormatting (ApplyTxErr blk)
  , LogFormatting (GenTx blk)
  , ToJSON (GenTxId blk)
  , LedgerSupportsMempool blk
  ) => LogFormatting (TraceEventMempool blk) where
  forMachine :: DetailLevel -> TraceEventMempool blk -> Object
forMachine DetailLevel
dtal (TraceMempoolAddedTx Validated (GenTx blk)
tx MempoolSize
_mpSzBefore MempoolSize
mpSzAfter) =
    [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
"TraceMempoolAddedTx"
      , Key
"tx" Key -> Object -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= DetailLevel -> GenTx blk -> Object
forall a. LogFormatting a => DetailLevel -> a -> Object
forMachine DetailLevel
dtal (Validated (GenTx blk) -> GenTx blk
forall blk.
LedgerSupportsMempool blk =>
Validated (GenTx blk) -> GenTx blk
txForgetValidated Validated (GenTx blk)
tx)
      , Key
"mempoolSize" Key -> Object -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= DetailLevel -> MempoolSize -> Object
forall a. LogFormatting a => DetailLevel -> a -> Object
forMachine DetailLevel
dtal MempoolSize
mpSzAfter
      ]
  forMachine DetailLevel
dtal (TraceMempoolRejectedTx GenTx blk
tx ApplyTxErr blk
txApplyErr MempoolSize
mpSz) =
    [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
"TraceMempoolRejectedTx"
      , Key
"err" Key -> Object -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= DetailLevel -> ApplyTxErr blk -> Object
forall a. LogFormatting a => DetailLevel -> a -> Object
forMachine DetailLevel
dtal ApplyTxErr blk
txApplyErr
      , Key
"tx" Key -> Object -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= DetailLevel -> GenTx blk -> Object
forall a. LogFormatting a => DetailLevel -> a -> Object
forMachine DetailLevel
dtal GenTx blk
tx
      , Key
"mempoolSize" Key -> Object -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= DetailLevel -> MempoolSize -> Object
forall a. LogFormatting a => DetailLevel -> a -> Object
forMachine DetailLevel
dtal MempoolSize
mpSz
      ]
  forMachine DetailLevel
dtal (TraceMempoolRemoveTxs [Validated (GenTx blk)]
txs MempoolSize
mpSz) =
    [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
"TraceMempoolRemoveTxs"
      , Key
"txs" Key -> [Object] -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (Validated (GenTx blk) -> Object)
-> [Validated (GenTx blk)] -> [Object]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (DetailLevel -> GenTx blk -> Object
forall a. LogFormatting a => DetailLevel -> a -> Object
forMachine DetailLevel
dtal (GenTx blk -> Object)
-> (Validated (GenTx blk) -> GenTx blk)
-> Validated (GenTx blk)
-> Object
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Validated (GenTx blk) -> GenTx blk
forall blk.
LedgerSupportsMempool blk =>
Validated (GenTx blk) -> GenTx blk
txForgetValidated) [Validated (GenTx blk)]
txs
      , Key
"mempoolSize" Key -> Object -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= DetailLevel -> MempoolSize -> Object
forall a. LogFormatting a => DetailLevel -> a -> Object
forMachine DetailLevel
dtal MempoolSize
mpSz
      ]
  forMachine DetailLevel
dtal (TraceMempoolManuallyRemovedTxs [GenTxId blk]
txs0 [Validated (GenTx blk)]
txs1 MempoolSize
mpSz) =
    [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
"TraceMempoolManuallyRemovedTxs"
      , Key
"txsRemoved" Key -> [GenTxId blk] -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [GenTxId blk]
txs0
      , Key
"txsInvalidated" Key -> [Object] -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (Validated (GenTx blk) -> Object)
-> [Validated (GenTx blk)] -> [Object]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (DetailLevel -> GenTx blk -> Object
forall a. LogFormatting a => DetailLevel -> a -> Object
forMachine DetailLevel
dtal (GenTx blk -> Object)
-> (Validated (GenTx blk) -> GenTx blk)
-> Validated (GenTx blk)
-> Object
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Validated (GenTx blk) -> GenTx blk
forall blk.
LedgerSupportsMempool blk =>
Validated (GenTx blk) -> GenTx blk
txForgetValidated) [Validated (GenTx blk)]
txs1
      , Key
"mempoolSize" Key -> Object -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= DetailLevel -> MempoolSize -> Object
forall a. LogFormatting a => DetailLevel -> a -> Object
forMachine DetailLevel
dtal MempoolSize
mpSz
      ]

  asMetrics :: TraceEventMempool blk -> [Metric]
asMetrics (TraceMempoolAddedTx Validated (GenTx blk)
_tx MempoolSize
_mpSzBefore MempoolSize
mpSz) =
    [ Text -> Integer -> Metric
IntM Text
"cardano.node.txsInMempool" (Word32 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Integer) -> Word32 -> Integer
forall a b. (a -> b) -> a -> b
$ MempoolSize -> Word32
msNumTxs MempoolSize
mpSz)
    , Text -> Integer -> Metric
IntM Text
"cardano.node.mempoolBytes" (Word32 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Integer) -> Word32 -> Integer
forall a b. (a -> b) -> a -> b
$ MempoolSize -> Word32
msNumBytes MempoolSize
mpSz)
    ]
  asMetrics (TraceMempoolRejectedTx GenTx blk
_tx ApplyTxErr blk
_txApplyErr MempoolSize
mpSz) =
    [ Text -> Integer -> Metric
IntM Text
"cardano.node.txsInMempool" (Word32 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Integer) -> Word32 -> Integer
forall a b. (a -> b) -> a -> b
$ MempoolSize -> Word32
msNumTxs MempoolSize
mpSz)
    , Text -> Integer -> Metric
IntM Text
"cardano.node.mempoolBytes" (Word32 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Integer) -> Word32 -> Integer
forall a b. (a -> b) -> a -> b
$ MempoolSize -> Word32
msNumBytes MempoolSize
mpSz)
    ]
  asMetrics (TraceMempoolRemoveTxs [Validated (GenTx blk)]
_txs MempoolSize
mpSz) =
    [ Text -> Integer -> Metric
IntM Text
"cardano.node.txsInMempool" (Word32 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Integer) -> Word32 -> Integer
forall a b. (a -> b) -> a -> b
$ MempoolSize -> Word32
msNumTxs MempoolSize
mpSz)
    , Text -> Integer -> Metric
IntM Text
"cardano.node.mempoolBytes" (Word32 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Integer) -> Word32 -> Integer
forall a b. (a -> b) -> a -> b
$ MempoolSize -> Word32
msNumBytes MempoolSize
mpSz)
    ]
  asMetrics (TraceMempoolManuallyRemovedTxs [] [Validated (GenTx blk)]
_txs1 MempoolSize
mpSz) =
    [ Text -> Integer -> Metric
IntM Text
"cardano.node.txsInMempool" (Word32 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Integer) -> Word32 -> Integer
forall a b. (a -> b) -> a -> b
$ MempoolSize -> Word32
msNumTxs MempoolSize
mpSz)
    , Text -> Integer -> Metric
IntM Text
"cardano.node.mempoolBytes" (Word32 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Integer) -> Word32 -> Integer
forall a b. (a -> b) -> a -> b
$ MempoolSize -> Word32
msNumBytes MempoolSize
mpSz)
    ]
  asMetrics (TraceMempoolManuallyRemovedTxs [GenTxId blk]
txs [Validated (GenTx blk)]
_txs1 MempoolSize
mpSz) =
    [ Text -> Integer -> Metric
IntM Text
"cardano.node.txsInMempool" (Word32 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Integer) -> Word32 -> Integer
forall a b. (a -> b) -> a -> b
$ MempoolSize -> Word32
msNumTxs MempoolSize
mpSz)
    , Text -> Integer -> Metric
IntM Text
"cardano.node.mempoolBytes" (Word32 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Integer) -> Word32 -> Integer
forall a b. (a -> b) -> a -> b
$ MempoolSize -> Word32
msNumBytes MempoolSize
mpSz)
    , Text -> Maybe Int -> Metric
CounterM Text
"cardano.node.txsProcessedNum" (Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ [GenTxId blk] -> Int
forall a. HasLength a => a -> Int
length [GenTxId blk]
txs))
    ]

instance LogFormatting MempoolSize where
  forMachine :: DetailLevel -> MempoolSize -> Object
forMachine DetailLevel
_dtal MempoolSize{Word32
msNumTxs :: Word32
msNumTxs :: MempoolSize -> Word32
msNumTxs, Word32
msNumBytes :: Word32
msNumBytes :: MempoolSize -> Word32
msNumBytes} =
    [Object] -> Object
forall a. Monoid a => [a] -> a
mconcat
      [ Key
"numTxs" Key -> Word32 -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Word32
msNumTxs
      , Key
"bytes" Key -> Word32 -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Word32
msNumBytes
      ]

docMempool :: forall blk. Documented (TraceEventMempool blk)
docMempool :: Documented (TraceEventMempool blk)
docMempool = [Text]
-> Documented (TraceEventMempool Any)
-> Documented (TraceEventMempool blk)
forall a b. [Text] -> Documented a -> Documented b
addDocumentedNamespace [] Documented (TraceEventMempool Any)
forall blk. Documented (TraceEventMempool blk)
docMempool'

docMempool' :: forall blk. Documented (TraceEventMempool blk)
docMempool' :: Documented (TraceEventMempool blk)
docMempool' = [DocMsg (TraceEventMempool blk)]
-> Documented (TraceEventMempool blk)
forall a. [DocMsg a] -> Documented a
Documented [
    [Text] -> [(Text, Text)] -> Text -> DocMsg (TraceEventMempool blk)
forall a. [Text] -> [(Text, Text)] -> Text -> DocMsg a
DocMsg
      [Text
"AddedTx"]
      [ (Text
"cardano.node.txsInMempool",Text
"Transactions in mempool")
      , (Text
"cardano.node.mempoolBytes", Text
"Byte size of the mempool")
      ]
      Text
"New, valid transaction that was added to the Mempool."
  , [Text] -> [(Text, Text)] -> Text -> DocMsg (TraceEventMempool blk)
forall a. [Text] -> [(Text, Text)] -> Text -> DocMsg a
DocMsg
      [Text
"RejectedTx"]
      [ (Text
"cardano.node.txsInMempool",Text
"Transactions in mempool")
      , (Text
"cardano.node.mempoolBytes", Text
"Byte size of the mempool")
      ]
      Text
"New, invalid transaction thas was rejected and thus not added to\
      \ the Mempool."
  , [Text] -> [(Text, Text)] -> Text -> DocMsg (TraceEventMempool blk)
forall a. [Text] -> [(Text, Text)] -> Text -> DocMsg a
DocMsg
      [Text
"RemoveTxs"]
      [ (Text
"cardano.node.txsInMempool",Text
"Transactions in mempool")
      , (Text
"cardano.node.mempoolBytes", Text
"Byte size of the mempool")
      ]
      Text
"Previously valid transactions that are no longer valid because of\
      \ changes in the ledger state. These transactions have been removed\
      \ from the Mempool."
  , [Text] -> [(Text, Text)] -> Text -> DocMsg (TraceEventMempool blk)
forall a. [Text] -> [(Text, Text)] -> Text -> DocMsg a
DocMsg
      [Text
"ManuallyRemovedTxs"]
      [ (Text
"cardano.node.txsInMempool",Text
"Transactions in mempool")
      , (Text
"cardano.node.mempoolBytes", Text
"Byte size of the mempool")
      , (Text
"cardano.node.txsProcessedNum", Text
"")
      ]
      Text
"Transactions that have been manually removed from the Mempool."
  ]


--------------------------------------------------------------------------------
-- ForgeEvent Tracer
--------------------------------------------------------------------------------

severityForge :: ForgeTracerType blk -> SeverityS
severityForge :: ForgeTracerType blk -> SeverityS
severityForge (Left TraceForgeEvent blk
t)  = TraceForgeEvent blk -> SeverityS
forall blk. TraceForgeEvent blk -> SeverityS
severityForge'' TraceForgeEvent blk
t
severityForge (Right TraceStartLeadershipCheckPlus
t) = TraceStartLeadershipCheckPlus -> SeverityS
severityForge'''' TraceStartLeadershipCheckPlus
t

severityForge'' :: TraceForgeEvent blk -> SeverityS
severityForge'' :: TraceForgeEvent blk -> SeverityS
severityForge'' TraceStartLeadershipCheck {}    = SeverityS
Info
severityForge'' TraceSlotIsImmutable {}         = SeverityS
Error
severityForge'' TraceBlockFromFuture {}         = SeverityS
Error
severityForge'' TraceBlockContext {}            = SeverityS
Debug
severityForge'' TraceNoLedgerState {}           = SeverityS
Error
severityForge'' TraceLedgerState {}             = SeverityS
Debug
severityForge'' TraceNoLedgerView {}            = SeverityS
Error
severityForge'' TraceLedgerView {}              = SeverityS
Debug
severityForge'' TraceForgeStateUpdateError {}   = SeverityS
Error
severityForge'' TraceNodeCannotForge {}         = SeverityS
Error
severityForge'' TraceNodeNotLeader {}           = SeverityS
Info
severityForge'' TraceNodeIsLeader {}            = SeverityS
Info
severityForge'' TraceForgeTickedLedgerState {}  = SeverityS
Debug
severityForge'' TraceForgingMempoolSnapshot {}  = SeverityS
Debug
severityForge'' TraceForgedBlock {}             = SeverityS
Info
severityForge'' TraceDidntAdoptBlock {}         = SeverityS
Error
severityForge'' TraceForgedInvalidBlock {}      = SeverityS
Error
severityForge'' TraceAdoptedBlock {}            = SeverityS
Info

severityForge'''' :: TraceStartLeadershipCheckPlus -> SeverityS
severityForge'''' :: TraceStartLeadershipCheckPlus -> SeverityS
severityForge'''' TraceStartLeadershipCheckPlus
_ = SeverityS
Info

namesForForge :: ForgeTracerType blk -> [Text]
namesForForge :: ForgeTracerType blk -> [Text]
namesForForge (Left TraceForgeEvent blk
t)  = TraceForgeEvent blk -> [Text]
forall blk. TraceForgeEvent blk -> [Text]
namesForForge'' TraceForgeEvent blk
t
namesForForge (Right TraceStartLeadershipCheckPlus
t) = TraceStartLeadershipCheckPlus -> [Text]
namesForForge'''' TraceStartLeadershipCheckPlus
t

namesForForge'' :: TraceForgeEvent blk -> [Text]
namesForForge'' :: TraceForgeEvent blk -> [Text]
namesForForge'' TraceStartLeadershipCheck {}   = [Text
"StartLeadershipCheck"]
namesForForge'' TraceSlotIsImmutable {}        = [Text
"SlotIsImmutable"]
namesForForge'' TraceBlockFromFuture {}        = [Text
"BlockFromFuture"]
namesForForge'' TraceBlockContext {}           = [Text
"BlockContext"]
namesForForge'' TraceNoLedgerState {}          = [Text
"NoLedgerState"]
namesForForge'' TraceLedgerState {}            = [Text
"LedgerState"]
namesForForge'' TraceNoLedgerView {}           = [Text
"NoLedgerView"]
namesForForge'' TraceLedgerView {}             = [Text
"LedgerView"]
namesForForge'' TraceForgeStateUpdateError {}  = [Text
"ForgeStateUpdateError"]
namesForForge'' TraceNodeCannotForge {}        = [Text
"NodeCannotForge"]
namesForForge'' TraceNodeNotLeader {}          = [Text
"NodeNotLeader"]
namesForForge'' TraceNodeIsLeader {}           = [Text
"NodeIsLeader"]
namesForForge'' TraceForgeTickedLedgerState {} = [Text
"ForgeTickedLedgerState"]
namesForForge'' TraceForgingMempoolSnapshot {} = [Text
"ForgingMempoolSnapshot"]
namesForForge'' TraceForgedBlock {}            = [Text
"ForgedBlock"]
namesForForge'' TraceDidntAdoptBlock {}        = [Text
"DidntAdoptBlock"]
namesForForge'' TraceForgedInvalidBlock {}     = [Text
"ForgedInvalidBlock"]
namesForForge'' TraceAdoptedBlock {}           = [Text
"AdoptedBlock"]

namesForForge'''' :: TraceStartLeadershipCheckPlus -> [Text]
namesForForge'''' :: TraceStartLeadershipCheckPlus -> [Text]
namesForForge'''' TraceStartLeadershipCheckPlus{} = [Text
"StartLeadershipCheckPlus"]

instance ( tx ~ GenTx blk
         , ConvertRawHash blk
         , GetHeader blk
         , HasHeader blk
         , HasKESInfo blk
         , HasTxId (GenTx blk)
         , LedgerSupportsProtocol blk
         , LedgerSupportsMempool blk
         , SerialiseNodeToNodeConstraints blk
         , Show (ForgeStateUpdateError blk)
         , Show (CannotForge blk)
         , Show (TxId (GenTx blk))
         , LogFormatting (InvalidBlockReason blk)
         , LogFormatting (CannotForge blk)
         , LogFormatting (ForgeStateUpdateError blk))
      => LogFormatting (TraceForgeEvent blk) where
  forMachine :: DetailLevel -> TraceForgeEvent blk -> Object
forMachine DetailLevel
_dtal (TraceStartLeadershipCheck SlotNo
slotNo) =
    [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
"TraceStartLeadershipCheck"
      , Key
"slot" Key -> Value -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Word64 -> Value
forall a. ToJSON a => a -> Value
toJSON (SlotNo -> Word64
unSlotNo SlotNo
slotNo)
      ]
  forMachine DetailLevel
dtal (TraceSlotIsImmutable SlotNo
slotNo Point blk
tipPoint BlockNo
tipBlkNo) =
    [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
"TraceSlotIsImmutable"
      , Key
"slot" Key -> Value -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Word64 -> Value
forall a. ToJSON a => a -> Value
toJSON (SlotNo -> Word64
unSlotNo SlotNo
slotNo)
      , Key
"tip" Key -> Text -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= DetailLevel -> Point blk -> Text
forall blk. ConvertRawHash blk => DetailLevel -> Point blk -> Text
renderPointForDetails DetailLevel
dtal Point blk
tipPoint
      , Key
"tipBlockNo" Key -> Value -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Word64 -> Value
forall a. ToJSON a => a -> Value
toJSON (BlockNo -> Word64
unBlockNo BlockNo
tipBlkNo)
      ]
  forMachine DetailLevel
_dtal (TraceBlockFromFuture SlotNo
currentSlot SlotNo
tip) =
    [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
"TraceBlockFromFuture"
      , Key
"current slot" Key -> Value -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Word64 -> Value
forall a. ToJSON a => a -> Value
toJSON (SlotNo -> Word64
unSlotNo SlotNo
currentSlot)
      , Key
"tip" Key -> Value -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Word64 -> Value
forall a. ToJSON a => a -> Value
toJSON (SlotNo -> Word64
unSlotNo SlotNo
tip)
      ]
  forMachine DetailLevel
dtal (TraceBlockContext SlotNo
currentSlot BlockNo
tipBlkNo Point blk
tipPoint) =
    [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
"TraceBlockContext"
      , Key
"current slot" Key -> Value -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Word64 -> Value
forall a. ToJSON a => a -> Value
toJSON (SlotNo -> Word64
unSlotNo SlotNo
currentSlot)
      , Key
"tip" Key -> Text -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= DetailLevel -> Point blk -> Text
forall blk. ConvertRawHash blk => DetailLevel -> Point blk -> Text
renderPointForDetails DetailLevel
dtal Point blk
tipPoint
      , Key
"tipBlockNo" Key -> Value -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Word64 -> Value
forall a. ToJSON a => a -> Value
toJSON (BlockNo -> Word64
unBlockNo BlockNo
tipBlkNo)
      ]
  forMachine DetailLevel
_dtal (TraceNoLedgerState SlotNo
slotNo Point blk
_pt) =
    [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
"TraceNoLedgerState"
      , Key
"slot" Key -> Value -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Word64 -> Value
forall a. ToJSON a => a -> Value
toJSON (SlotNo -> Word64
unSlotNo SlotNo
slotNo)
      ]
  forMachine DetailLevel
_dtal (TraceLedgerState SlotNo
slotNo Point blk
_pt) =
    [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
"TraceLedgerState"
      , Key
"slot" Key -> Value -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Word64 -> Value
forall a. ToJSON a => a -> Value
toJSON (SlotNo -> Word64
unSlotNo SlotNo
slotNo)
      ]
  forMachine DetailLevel
_dtal (TraceNoLedgerView SlotNo
slotNo OutsideForecastRange
_) =
    [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
"TraceNoLedgerView"
      , Key
"slot" Key -> Value -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Word64 -> Value
forall a. ToJSON a => a -> Value
toJSON (SlotNo -> Word64
unSlotNo SlotNo
slotNo)
      ]
  forMachine DetailLevel
_dtal (TraceLedgerView SlotNo
slotNo) =
    [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
"TraceLedgerView"
      , Key
"slot" Key -> Value -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Word64 -> Value
forall a. ToJSON a => a -> Value
toJSON (SlotNo -> Word64
unSlotNo SlotNo
slotNo)
      ]
  forMachine DetailLevel
dtal (TraceForgeStateUpdateError SlotNo
slotNo ForgeStateUpdateError blk
reason) =
    [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
"TraceForgeStateUpdateError"
      , Key
"slot" Key -> Value -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Word64 -> Value
forall a. ToJSON a => a -> Value
toJSON (SlotNo -> Word64
unSlotNo SlotNo
slotNo)
      , Key
"reason" Key -> Object -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= DetailLevel -> ForgeStateUpdateError blk -> Object
forall a. LogFormatting a => DetailLevel -> a -> Object
forMachine DetailLevel
dtal ForgeStateUpdateError blk
reason
      ]
  forMachine DetailLevel
dtal (TraceNodeCannotForge SlotNo
slotNo CannotForge blk
reason) =
    [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
"TraceNodeCannotForge"
      , Key
"slot" Key -> Value -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Word64 -> Value
forall a. ToJSON a => a -> Value
toJSON (SlotNo -> Word64
unSlotNo SlotNo
slotNo)
      , Key
"reason" Key -> Object -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= DetailLevel -> CannotForge blk -> Object
forall a. LogFormatting a => DetailLevel -> a -> Object
forMachine DetailLevel
dtal CannotForge blk
reason
      ]
  forMachine DetailLevel
_dtal (TraceNodeNotLeader SlotNo
slotNo) =
    [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
"TraceNodeNotLeader"
      , Key
"slot" Key -> Value -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Word64 -> Value
forall a. ToJSON a => a -> Value
toJSON (SlotNo -> Word64
unSlotNo SlotNo
slotNo)
      ]
  forMachine DetailLevel
_dtal (TraceNodeIsLeader SlotNo
slotNo) =
    [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
"TraceNodeIsLeader"
      , Key
"slot" Key -> Value -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Word64 -> Value
forall a. ToJSON a => a -> Value
toJSON (SlotNo -> Word64
unSlotNo SlotNo
slotNo)
      ]
  forMachine DetailLevel
dtal (TraceForgeTickedLedgerState SlotNo
slotNo Point blk
prevPt) =
    [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
"TraceForgeTickedLedgerState"
      , Key
"slot" Key -> Value -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Word64 -> Value
forall a. ToJSON a => a -> Value
toJSON (SlotNo -> Word64
unSlotNo SlotNo
slotNo)
      , Key
"prev" Key -> Text -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= DetailLevel -> Point blk -> Text
forall blk. ConvertRawHash blk => DetailLevel -> Point blk -> Text
renderPointForDetails DetailLevel
dtal Point blk
prevPt
      ]
  forMachine DetailLevel
dtal (TraceForgingMempoolSnapshot SlotNo
slotNo Point blk
prevPt ChainHash blk
mpHash SlotNo
mpSlot) =
    [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
"TraceForgingMempoolSnapshot"
      , Key
"slot"        Key -> Value -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Word64 -> Value
forall a. ToJSON a => a -> Value
toJSON (SlotNo -> Word64
unSlotNo SlotNo
slotNo)
      , Key
"prev"        Key -> Text -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= DetailLevel -> Point blk -> Text
forall blk. ConvertRawHash blk => DetailLevel -> Point blk -> Text
renderPointForDetails DetailLevel
dtal Point blk
prevPt
      , Key
"mempoolHash" Key -> Value -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String ((HeaderHash blk -> Text) -> ChainHash blk -> Text
forall blk. (HeaderHash blk -> Text) -> ChainHash blk -> Text
renderChainHash @blk (Proxy blk -> HeaderHash blk -> Text
forall blk (proxy :: * -> *).
ConvertRawHash blk =>
proxy blk -> HeaderHash blk -> Text
renderHeaderHash (Proxy blk
forall k (t :: k). Proxy t
Proxy @blk)) ChainHash blk
mpHash)
      , Key
"mempoolSlot" Key -> Value -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Word64 -> Value
forall a. ToJSON a => a -> Value
toJSON (SlotNo -> Word64
unSlotNo SlotNo
mpSlot)
      ]
  forMachine DetailLevel
_dtal (TraceForgedBlock SlotNo
slotNo Point blk
_ blk
blk MempoolSize
_) =
    [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
"TraceForgedBlock"
      , Key
"slot" Key -> Value -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Word64 -> Value
forall a. ToJSON a => a -> Value
toJSON (SlotNo -> Word64
unSlotNo SlotNo
slotNo)
      , Key
"block"     Key -> Value -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String (Proxy blk -> HeaderHash blk -> Text
forall blk (proxy :: * -> *).
ConvertRawHash blk =>
proxy blk -> HeaderHash blk -> Text
renderHeaderHash (Proxy blk
forall k (t :: k). Proxy t
Proxy @blk) (HeaderHash blk -> Text) -> HeaderHash blk -> Text
forall a b. (a -> b) -> a -> b
$ blk -> HeaderHash blk
forall b. HasHeader b => b -> HeaderHash b
blockHash blk
blk)
      , Key
"blockNo"   Key -> Value -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Word64 -> Value
forall a. ToJSON a => a -> Value
toJSON (BlockNo -> Word64
unBlockNo (BlockNo -> Word64) -> BlockNo -> Word64
forall a b. (a -> b) -> a -> b
$ blk -> BlockNo
forall b. HasHeader b => b -> BlockNo
blockNo blk
blk)
      , Key
"blockPrev" Key -> Value -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String ((HeaderHash blk -> Text) -> ChainHash blk -> Text
forall blk. (HeaderHash blk -> Text) -> ChainHash blk -> Text
renderChainHash
                                @blk
                                (Proxy blk -> HeaderHash blk -> Text
forall blk (proxy :: * -> *).
ConvertRawHash blk =>
proxy blk -> HeaderHash blk -> Text
renderHeaderHash (Proxy blk
forall k (t :: k). Proxy t
Proxy @blk))
                                (ChainHash blk -> Text) -> ChainHash blk -> Text
forall a b. (a -> b) -> a -> b
$ blk -> ChainHash blk
forall blk. GetPrevHash blk => blk -> ChainHash blk
blockPrevHash blk
blk)
      ]
  forMachine DetailLevel
_dtal (TraceDidntAdoptBlock SlotNo
slotNo blk
_) =
    [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
"TraceDidntAdoptBlock"
      , Key
"slot" Key -> Value -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Word64 -> Value
forall a. ToJSON a => a -> Value
toJSON (SlotNo -> Word64
unSlotNo SlotNo
slotNo)
      ]
  forMachine DetailLevel
dtal (TraceForgedInvalidBlock SlotNo
slotNo blk
_ InvalidBlockReason blk
reason) =
    [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
"TraceForgedInvalidBlock"
      , Key
"slot" Key -> Value -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Word64 -> Value
forall a. ToJSON a => a -> Value
toJSON (SlotNo -> Word64
unSlotNo SlotNo
slotNo)
      , Key
"reason" Key -> Object -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= DetailLevel -> InvalidBlockReason blk -> Object
forall a. LogFormatting a => DetailLevel -> a -> Object
forMachine DetailLevel
dtal InvalidBlockReason blk
reason
      ]
  forMachine DetailLevel
DDetailed (TraceAdoptedBlock SlotNo
slotNo blk
blk [Validated (GenTx blk)]
txs) =
    [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
"TraceAdoptedBlock"
      , Key
"slot" Key -> Value -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Word64 -> Value
forall a. ToJSON a => a -> Value
toJSON (SlotNo -> Word64
unSlotNo SlotNo
slotNo)
      , Key
"blockHash" Key -> Text -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Proxy blk -> DetailLevel -> HeaderHash blk -> Text
forall blk (proxy :: * -> *).
ConvertRawHash blk =>
proxy blk -> DetailLevel -> HeaderHash blk -> Text
renderHeaderHashForDetails
          (Proxy blk
forall k (t :: k). Proxy t
Proxy @blk)
          DetailLevel
DDetailed
          (blk -> HeaderHash blk
forall b. HasHeader b => b -> HeaderHash b
blockHash blk
blk)
      , Key
"blockSize" Key -> Value -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Word32 -> Value
forall a. ToJSON a => a -> Value
toJSON (Header blk -> Word32
forall blk.
SerialiseNodeToNodeConstraints blk =>
Header blk -> Word32
estimateBlockSize (blk -> Header blk
forall blk. GetHeader blk => blk -> Header blk
getHeader blk
blk))
      , Key
"txIds" Key -> Value -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [String] -> Value
forall a. ToJSON a => a -> Value
toJSON ((Validated (GenTx blk) -> String)
-> [Validated (GenTx blk)] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (TxId (GenTx blk) -> String
forall a. Show a => a -> String
show (TxId (GenTx blk) -> String)
-> (Validated (GenTx blk) -> TxId (GenTx blk))
-> Validated (GenTx blk)
-> String
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. GenTx blk -> TxId (GenTx blk)
forall tx. HasTxId tx => tx -> TxId tx
txId (GenTx blk -> TxId (GenTx blk))
-> (Validated (GenTx blk) -> GenTx blk)
-> Validated (GenTx blk)
-> TxId (GenTx blk)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Validated (GenTx blk) -> GenTx blk
forall blk.
LedgerSupportsMempool blk =>
Validated (GenTx blk) -> GenTx blk
txForgetValidated) [Validated (GenTx blk)]
txs)
      ]
  forMachine DetailLevel
dtal (TraceAdoptedBlock SlotNo
slotNo blk
blk [Validated (GenTx blk)]
_txs) =
    [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
"TraceAdoptedBlock"
      , Key
"slot" Key -> Value -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Word64 -> Value
forall a. ToJSON a => a -> Value
toJSON (SlotNo -> Word64
unSlotNo SlotNo
slotNo)
      , Key
"blockHash" Key -> Text -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Proxy blk -> DetailLevel -> HeaderHash blk -> Text
forall blk (proxy :: * -> *).
ConvertRawHash blk =>
proxy blk -> DetailLevel -> HeaderHash blk -> Text
renderHeaderHashForDetails
          (Proxy blk
forall k (t :: k). Proxy t
Proxy @blk)
          DetailLevel
dtal
          (blk -> HeaderHash blk
forall b. HasHeader b => b -> HeaderHash b
blockHash blk
blk)
      , Key
"blockSize" Key -> Value -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Word32 -> Value
forall a. ToJSON a => a -> Value
toJSON (Header blk -> Word32
forall blk.
SerialiseNodeToNodeConstraints blk =>
Header blk -> Word32
estimateBlockSize (blk -> Header blk
forall blk. GetHeader blk => blk -> Header blk
getHeader blk
blk))
      ]



  forHuman :: TraceForgeEvent blk -> Text
forHuman (TraceStartLeadershipCheck SlotNo
slotNo) =
      Text
"Checking for leadership in slot " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word64 -> Text
forall a. Show a => a -> Text
showT (SlotNo -> Word64
unSlotNo SlotNo
slotNo)
  forHuman (TraceSlotIsImmutable SlotNo
slotNo Point blk
immutableTipPoint BlockNo
immutableTipBlkNo) =
      Text
"Couldn't forge block because current slot is immutable: "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"immutable tip: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Point blk -> Text
forall blk. ConvertRawHash blk => Point blk -> Text
renderPointAsPhrase Point blk
immutableTipPoint
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", immutable tip block no: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word64 -> Text
forall a. Show a => a -> Text
showT (BlockNo -> Word64
unBlockNo BlockNo
immutableTipBlkNo)
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", current slot: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word64 -> Text
forall a. Show a => a -> Text
showT (SlotNo -> Word64
unSlotNo SlotNo
slotNo)
  forHuman (TraceBlockFromFuture SlotNo
currentSlot SlotNo
tipSlot) =
      Text
"Couldn't forge block because current tip is in the future: "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"current tip slot: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word64 -> Text
forall a. Show a => a -> Text
showT (SlotNo -> Word64
unSlotNo SlotNo
tipSlot)
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", current slot: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word64 -> Text
forall a. Show a => a -> Text
showT (SlotNo -> Word64
unSlotNo SlotNo
currentSlot)
  forHuman (TraceBlockContext SlotNo
currentSlot BlockNo
tipBlockNo Point blk
tipPoint) =
      Text
"New block will fit onto: "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"tip: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Point blk -> Text
forall blk. ConvertRawHash blk => Point blk -> Text
renderPointAsPhrase Point blk
tipPoint
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", tip block no: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word64 -> Text
forall a. Show a => a -> Text
showT (BlockNo -> Word64
unBlockNo BlockNo
tipBlockNo)
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", current slot: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word64 -> Text
forall a. Show a => a -> Text
showT (SlotNo -> Word64
unSlotNo SlotNo
currentSlot)
  forHuman (TraceNoLedgerState SlotNo
slotNo Point blk
pt) =
      Text
"Could not obtain ledger state for point "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Point blk -> Text
forall blk. ConvertRawHash blk => Point blk -> Text
renderPointAsPhrase Point blk
pt
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", current slot: "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word64 -> Text
forall a. Show a => a -> Text
showT (SlotNo -> Word64
unSlotNo SlotNo
slotNo)
  forHuman (TraceLedgerState SlotNo
slotNo Point blk
pt) =
      Text
"Obtained a ledger state for point "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Point blk -> Text
forall blk. ConvertRawHash blk => Point blk -> Text
renderPointAsPhrase Point blk
pt
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", current slot: "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word64 -> Text
forall a. Show a => a -> Text
showT (SlotNo -> Word64
unSlotNo SlotNo
slotNo)
  forHuman (TraceNoLedgerView SlotNo
slotNo OutsideForecastRange
_) =
      Text
"Could not obtain ledger view for slot " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word64 -> Text
forall a. Show a => a -> Text
showT (SlotNo -> Word64
unSlotNo SlotNo
slotNo)
  forHuman (TraceLedgerView SlotNo
slotNo) =
      Text
"Obtained a ledger view for slot " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word64 -> Text
forall a. Show a => a -> Text
showT (SlotNo -> Word64
unSlotNo SlotNo
slotNo)
  forHuman (TraceForgeStateUpdateError SlotNo
slotNo ForgeStateUpdateError blk
reason) =
      Text
"Updating the forge state in slot "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word64 -> Text
forall a. Show a => a -> Text
showT (SlotNo -> Word64
unSlotNo SlotNo
slotNo)
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" failed because: "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ForgeStateUpdateError blk -> Text
forall a. Show a => a -> Text
showT ForgeStateUpdateError blk
reason
  forHuman (TraceNodeCannotForge SlotNo
slotNo CannotForge blk
reason) =
      Text
"We are the leader in slot "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word64 -> Text
forall a. Show a => a -> Text
showT (SlotNo -> Word64
unSlotNo SlotNo
slotNo)
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", but we cannot forge because: "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> CannotForge blk -> Text
forall a. Show a => a -> Text
showT CannotForge blk
reason
  forHuman (TraceNodeNotLeader SlotNo
slotNo) =
      Text
"Not leading slot " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word64 -> Text
forall a. Show a => a -> Text
showT (SlotNo -> Word64
unSlotNo SlotNo
slotNo)
  forHuman (TraceNodeIsLeader SlotNo
slotNo) =
      Text
"Leading slot " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word64 -> Text
forall a. Show a => a -> Text
showT (SlotNo -> Word64
unSlotNo SlotNo
slotNo)
  forHuman (TraceForgeTickedLedgerState SlotNo
slotNo Point blk
prevPt) =
      Text
"While forging in slot "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word64 -> Text
forall a. Show a => a -> Text
showT (SlotNo -> Word64
unSlotNo SlotNo
slotNo)
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" we ticked the ledger state ahead from "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Point blk -> Text
forall blk. ConvertRawHash blk => Point blk -> Text
renderPointAsPhrase Point blk
prevPt
  forHuman (TraceForgingMempoolSnapshot SlotNo
slotNo Point blk
prevPt ChainHash blk
mpHash SlotNo
mpSlot) =
      Text
"While forging in slot "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word64 -> Text
forall a. Show a => a -> Text
showT (SlotNo -> Word64
unSlotNo SlotNo
slotNo)
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" we acquired a mempool snapshot valid against "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Point blk -> Text
forall blk. ConvertRawHash blk => Point blk -> Text
renderPointAsPhrase Point blk
prevPt
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" from a mempool that was prepared for "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (HeaderHash blk -> Text) -> ChainHash blk -> Text
forall blk. (HeaderHash blk -> Text) -> ChainHash blk -> Text
renderChainHash @blk (Proxy blk -> HeaderHash blk -> Text
forall blk (proxy :: * -> *).
ConvertRawHash blk =>
proxy blk -> HeaderHash blk -> Text
renderHeaderHash (Proxy blk
forall k (t :: k). Proxy t
Proxy @blk)) ChainHash blk
mpHash
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" ticked to slot "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word64 -> Text
forall a. Show a => a -> Text
showT (SlotNo -> Word64
unSlotNo SlotNo
mpSlot)
  forHuman (TraceForgedBlock SlotNo
slotNo Point blk
_ blk
_ MempoolSize
_) =
      Text
"Forged block in slot " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word64 -> Text
forall a. Show a => a -> Text
showT (SlotNo -> Word64
unSlotNo SlotNo
slotNo)
  forHuman (TraceDidntAdoptBlock SlotNo
slotNo blk
_) =
      Text
"Didn't adopt forged block in slot " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word64 -> Text
forall a. Show a => a -> Text
showT (SlotNo -> Word64
unSlotNo SlotNo
slotNo)
  forHuman (TraceForgedInvalidBlock SlotNo
slotNo blk
_ InvalidBlockReason blk
reason) =
      Text
"Forged invalid block in slot "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word64 -> Text
forall a. Show a => a -> Text
showT (SlotNo -> Word64
unSlotNo SlotNo
slotNo)
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", reason: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> InvalidBlockReason blk -> Text
forall a. Show a => a -> Text
showT InvalidBlockReason blk
reason
  forHuman (TraceAdoptedBlock SlotNo
slotNo blk
blk [Validated (GenTx blk)]
_txs) =
      Text
"Adopted block forged in slot "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word64 -> Text
forall a. Show a => a -> Text
showT (SlotNo -> Word64
unSlotNo SlotNo
slotNo)
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Proxy blk -> HeaderHash blk -> Text
forall blk (proxy :: * -> *).
ConvertRawHash blk =>
proxy blk -> HeaderHash blk -> Text
renderHeaderHash (Proxy blk
forall k (t :: k). Proxy t
Proxy @blk) (blk -> HeaderHash blk
forall b. HasHeader b => b -> HeaderHash b
blockHash blk
blk)

  asMetrics :: TraceForgeEvent blk -> [Metric]
asMetrics (TraceForgeStateUpdateError SlotNo
slot ForgeStateUpdateError blk
reason) =
    Text -> Integer -> Metric
IntM Text
"cardano.node.forgeStateUpdateError" (Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Integer) -> Word64 -> Integer
forall a b. (a -> b) -> a -> b
$ SlotNo -> Word64
unSlotNo SlotNo
slot) Metric -> [Metric] -> [Metric]
forall a. a -> [a] -> [a]
:
      (case Proxy blk -> ForgeStateUpdateError blk -> Maybe KESInfo
forall blk.
HasKESInfo blk =>
Proxy blk -> ForgeStateUpdateError blk -> Maybe KESInfo
getKESInfo (Proxy blk
forall k (t :: k). Proxy t
Proxy @blk) ForgeStateUpdateError blk
reason of
        Maybe KESInfo
Nothing -> []
        Just KESInfo
kesInfo ->
          [ Text -> Integer -> Metric
IntM
              Text
"cardano.node.operationalCertificateStartKESPeriod"
              (Word -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word -> Integer) -> (KESInfo -> Word) -> KESInfo -> Integer
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. KESPeriod -> Word
unKESPeriod (KESPeriod -> Word) -> (KESInfo -> KESPeriod) -> KESInfo -> Word
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. KESInfo -> KESPeriod
HotKey.kesStartPeriod (KESInfo -> Integer) -> KESInfo -> Integer
forall a b. (a -> b) -> a -> b
$ KESInfo
kesInfo)
          , Text -> Integer -> Metric
IntM
              Text
"cardano.node.operationalCertificateExpiryKESPeriod"
              (Word -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word -> Integer) -> (KESInfo -> Word) -> KESInfo -> Integer
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. KESPeriod -> Word
unKESPeriod (KESPeriod -> Word) -> (KESInfo -> KESPeriod) -> KESInfo -> Word
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. KESInfo -> KESPeriod
HotKey.kesEndPeriod (KESInfo -> Integer) -> KESInfo -> Integer
forall a b. (a -> b) -> a -> b
$ KESInfo
kesInfo)
          , Text -> Integer -> Metric
IntM
              Text
"cardano.node.currentKESPeriod"
              Integer
0
          , Text -> Integer -> Metric
IntM
              Text
"cardano.node.remainingKESPeriods"
              Integer
0
          ])

  asMetrics (TraceStartLeadershipCheck SlotNo
slot) =
    [Text -> Integer -> Metric
IntM Text
"cardano.node.aboutToLeadSlotLast" (Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Integer) -> Word64 -> Integer
forall a b. (a -> b) -> a -> b
$ SlotNo -> Word64
unSlotNo SlotNo
slot)]
  asMetrics (TraceSlotIsImmutable SlotNo
slot Point blk
_tipPoint BlockNo
_tipBlkNo) =
    [Text -> Integer -> Metric
IntM Text
"cardano.node.slotIsImmutable" (Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Integer) -> Word64 -> Integer
forall a b. (a -> b) -> a -> b
$ SlotNo -> Word64
unSlotNo SlotNo
slot)]
  asMetrics (TraceBlockFromFuture SlotNo
slot SlotNo
_slotNo) =
    [Text -> Integer -> Metric
IntM Text
"cardano.node.blockFromFuture" (Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Integer) -> Word64 -> Integer
forall a b. (a -> b) -> a -> b
$ SlotNo -> Word64
unSlotNo SlotNo
slot)]
  asMetrics (TraceBlockContext SlotNo
slot BlockNo
_tipBlkNo Point blk
_tipPoint) =
    [Text -> Integer -> Metric
IntM Text
"cardano.node.blockContext" (Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Integer) -> Word64 -> Integer
forall a b. (a -> b) -> a -> b
$ SlotNo -> Word64
unSlotNo SlotNo
slot)]
  asMetrics (TraceNoLedgerState SlotNo
slot Point blk
_) =
    [Text -> Integer -> Metric
IntM Text
"cardano.node.couldNotForgeSlotLast" (Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Integer) -> Word64 -> Integer
forall a b. (a -> b) -> a -> b
$ SlotNo -> Word64
unSlotNo SlotNo
slot)]
  asMetrics (TraceLedgerState SlotNo
slot Point blk
_) =
    [Text -> Integer -> Metric
IntM Text
"cardano.node.ledgerState" (Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Integer) -> Word64 -> Integer
forall a b. (a -> b) -> a -> b
$ SlotNo -> Word64
unSlotNo SlotNo
slot)]
  asMetrics (TraceNoLedgerView SlotNo
slot OutsideForecastRange
_) =
    [Text -> Integer -> Metric
IntM Text
"cardano.node.couldNotForgeSlotLast" (Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Integer) -> Word64 -> Integer
forall a b. (a -> b) -> a -> b
$ SlotNo -> Word64
unSlotNo SlotNo
slot)]
  asMetrics (TraceLedgerView SlotNo
slot) =
    [Text -> Integer -> Metric
IntM Text
"cardano.node.ledgerView" (Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Integer) -> Word64 -> Integer
forall a b. (a -> b) -> a -> b
$ SlotNo -> Word64
unSlotNo SlotNo
slot)]
  -- see above
  asMetrics (TraceNodeCannotForge SlotNo
slot CannotForge blk
_reason) =
    [Text -> Integer -> Metric
IntM Text
"cardano.node.nodeCannotForge" (Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Integer) -> Word64 -> Integer
forall a b. (a -> b) -> a -> b
$ SlotNo -> Word64
unSlotNo SlotNo
slot)]
  asMetrics (TraceNodeNotLeader SlotNo
slot) =
    [Text -> Integer -> Metric
IntM Text
"cardano.node.nodeNotLeader" (Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Integer) -> Word64 -> Integer
forall a b. (a -> b) -> a -> b
$ SlotNo -> Word64
unSlotNo SlotNo
slot)]
  asMetrics (TraceNodeIsLeader SlotNo
slot) =
    [Text -> Integer -> Metric
IntM Text
"cardano.node.nodeIsLeader" (Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Integer) -> Word64 -> Integer
forall a b. (a -> b) -> a -> b
$ SlotNo -> Word64
unSlotNo SlotNo
slot)]
  asMetrics TraceForgeTickedLedgerState {} = []
  asMetrics TraceForgingMempoolSnapshot {} = []
  asMetrics (TraceForgedBlock SlotNo
slot Point blk
_ blk
_ MempoolSize
_) =
    [Text -> Integer -> Metric
IntM Text
"cardano.node.forgedSlotLast" (Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Integer) -> Word64 -> Integer
forall a b. (a -> b) -> a -> b
$ SlotNo -> Word64
unSlotNo SlotNo
slot)]
  asMetrics (TraceDidntAdoptBlock SlotNo
slot blk
_) =
    [Text -> Integer -> Metric
IntM Text
"cardano.node.notAdoptedSlotLast" (Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Integer) -> Word64 -> Integer
forall a b. (a -> b) -> a -> b
$ SlotNo -> Word64
unSlotNo SlotNo
slot)]
  asMetrics (TraceForgedInvalidBlock SlotNo
slot blk
_ InvalidBlockReason blk
_) =
    [Text -> Integer -> Metric
IntM Text
"cardano.node.forgedInvalidSlotLast" (Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Integer) -> Word64 -> Integer
forall a b. (a -> b) -> a -> b
$ SlotNo -> Word64
unSlotNo SlotNo
slot)]
  asMetrics (TraceAdoptedBlock SlotNo
slot blk
_ [Validated (GenTx blk)]
_) =
    [Text -> Integer -> Metric
IntM Text
"cardano.node.adoptedSlotLast" (Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Integer) -> Word64 -> Integer
forall a b. (a -> b) -> a -> b
$ SlotNo -> Word64
unSlotNo SlotNo
slot)]

instance LogFormatting TraceStartLeadershipCheckPlus where
  forMachine :: DetailLevel -> TraceStartLeadershipCheckPlus -> Object
forMachine DetailLevel
_dtal TraceStartLeadershipCheckPlus {Double
Int
SlotNo
tsChainDensity :: TraceStartLeadershipCheckPlus -> Double
tsDelegMapSize :: TraceStartLeadershipCheckPlus -> Int
tsUtxoSize :: TraceStartLeadershipCheckPlus -> Int
tsSlotNo :: TraceStartLeadershipCheckPlus -> SlotNo
tsChainDensity :: Double
tsDelegMapSize :: Int
tsUtxoSize :: Int
tsSlotNo :: SlotNo
..} =
        [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
"TraceStartLeadershipCheck"
                , Key
"slot" Key -> Value -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Word64 -> Value
forall a. ToJSON a => a -> Value
toJSON (SlotNo -> Word64
unSlotNo SlotNo
tsSlotNo)
                , Key
"utxoSize" Key -> Value -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Scientific -> Value
Number (Int -> Scientific
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
tsUtxoSize)
                , Key
"delegMapSize" Key -> Value -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Scientific -> Value
Number (Int -> Scientific
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
tsUtxoSize)
                , Key
"chainDensity" Key -> Value -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Scientific -> Value
Number (Rational -> Scientific
forall a. Fractional a => Rational -> a
fromRational (Double -> Rational
forall a. Real a => a -> Rational
toRational Double
tsChainDensity))
                ]
  forHuman :: TraceStartLeadershipCheckPlus -> Text
forHuman TraceStartLeadershipCheckPlus {Double
Int
SlotNo
tsChainDensity :: Double
tsDelegMapSize :: Int
tsUtxoSize :: Int
tsSlotNo :: SlotNo
tsChainDensity :: TraceStartLeadershipCheckPlus -> Double
tsDelegMapSize :: TraceStartLeadershipCheckPlus -> Int
tsUtxoSize :: TraceStartLeadershipCheckPlus -> Int
tsSlotNo :: TraceStartLeadershipCheckPlus -> SlotNo
..} =
      Text
"Checking for leadership in slot " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word64 -> Text
forall a. Show a => a -> Text
showT (SlotNo -> Word64
unSlotNo SlotNo
tsSlotNo)
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" utxoSize " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
showT Int
tsUtxoSize
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" delegMapSize " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
showT Int
tsDelegMapSize
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" chainDensity " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Double -> Text
forall a. Show a => a -> Text
showT Double
tsChainDensity
  asMetrics :: TraceStartLeadershipCheckPlus -> [Metric]
asMetrics TraceStartLeadershipCheckPlus {Double
Int
SlotNo
tsChainDensity :: Double
tsDelegMapSize :: Int
tsUtxoSize :: Int
tsSlotNo :: SlotNo
tsChainDensity :: TraceStartLeadershipCheckPlus -> Double
tsDelegMapSize :: TraceStartLeadershipCheckPlus -> Int
tsUtxoSize :: TraceStartLeadershipCheckPlus -> Int
tsSlotNo :: TraceStartLeadershipCheckPlus -> SlotNo
..} =
    [Text -> Integer -> Metric
IntM Text
"cardano.node.utxoSize" (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
tsUtxoSize),
     Text -> Integer -> Metric
IntM Text
"cardano.node.delegMapSize" (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
tsDelegMapSize)]

docForge :: Documented (Either (TraceForgeEvent blk)
                               TraceStartLeadershipCheckPlus)
docForge :: Documented
  (Either (TraceForgeEvent blk) TraceStartLeadershipCheckPlus)
docForge = [Text]
-> Documented
     (Either (TraceForgeEvent Any) TraceStartLeadershipCheckPlus)
-> Documented
     (Either (TraceForgeEvent blk) TraceStartLeadershipCheckPlus)
forall a b. [Text] -> Documented a -> Documented b
addDocumentedNamespace [] Documented
  (Either (TraceForgeEvent Any) TraceStartLeadershipCheckPlus)
forall blk.
Documented
  (Either (TraceForgeEvent blk) TraceStartLeadershipCheckPlus)
docForge'

docForge' :: Documented (Either (TraceForgeEvent blk)
                               TraceStartLeadershipCheckPlus)
docForge' :: Documented
  (Either (TraceForgeEvent blk) TraceStartLeadershipCheckPlus)
docForge' = [DocMsg
   (Either (TraceForgeEvent blk) TraceStartLeadershipCheckPlus)]
-> Documented
     (Either (TraceForgeEvent blk) TraceStartLeadershipCheckPlus)
forall a. [DocMsg a] -> Documented a
Documented [
    [Text]
-> [(Text, Text)]
-> Text
-> DocMsg
     (Either (TraceForgeEvent blk) TraceStartLeadershipCheckPlus)
forall a. [Text] -> [(Text, Text)] -> Text -> DocMsg a
DocMsg
      [Text
"StartLeadershipCheck"]
      [(Text
"cardano.node.aboutToLeadSlotLast", Text
"")]
      Text
"Start of the leadership check."
  , [Text]
-> [(Text, Text)]
-> Text
-> DocMsg
     (Either (TraceForgeEvent blk) TraceStartLeadershipCheckPlus)
forall a. [Text] -> [(Text, Text)] -> Text -> DocMsg a
DocMsg
      [Text
"SlotIsImmutable"]
      [(Text
"cardano.node.slotIsImmutable", Text
"")]
      Text
"Leadership check failed: the tip of the ImmutableDB inhabits the\
      \  current slot\
      \ \
      \  This might happen in two cases.\
      \ \
      \   1. the clock moved backwards, on restart we ignored everything from the\
      \      VolatileDB since it's all in the future, and now the tip of the\
      \      ImmutableDB points to a block produced in the same slot we're trying\
      \      to produce a block in\
      \ \
      \   2. k = 0 and we already adopted a block from another leader of the same\
      \      slot.\
      \ \
      \  We record both the current slot number as well as the tip of the\
      \  ImmutableDB.\
      \ \
      \ See also <https://github.com/input-output-hk/ouroboros-network/issues/1462>"
  , [Text]
-> [(Text, Text)]
-> Text
-> DocMsg
     (Either (TraceForgeEvent blk) TraceStartLeadershipCheckPlus)
forall a. [Text] -> [(Text, Text)] -> Text -> DocMsg a
DocMsg
      [Text
"BlockFromFuture"]
      [(Text
"cardano.node.blockFromFuture", Text
"")]
      Text
"Leadership check failed: the current chain contains a block from a slot\
      \  /after/ the current slot\
      \ \
      \  This can only happen if the system is under heavy load.\
      \ \
      \  We record both the current slot number as well as the slot number of the\
      \  block at the tip of the chain.\
      \ \
      \  See also <https://github.com/input-output-hk/ouroboros-network/issues/1462>"
  , [Text]
-> [(Text, Text)]
-> Text
-> DocMsg
     (Either (TraceForgeEvent blk) TraceStartLeadershipCheckPlus)
forall a. [Text] -> [(Text, Text)] -> Text -> DocMsg a
DocMsg
      [Text
"BlockContext"]
      [(Text
"cardano.node.blockContext", Text
"")]
      Text
"We found out to which block we are going to connect the block we are about\
      \  to forge.\
      \ \
      \  We record the current slot number, the block number of the block to\
      \  connect to and its point.\
      \ \
      \  Note that block number of the block we will try to forge is one more than\
      \  the recorded block number."
  , [Text]
-> [(Text, Text)]
-> Text
-> DocMsg
     (Either (TraceForgeEvent blk) TraceStartLeadershipCheckPlus)
forall a. [Text] -> [(Text, Text)] -> Text -> DocMsg a
DocMsg
      [Text
"NoLedgerState"]
      [(Text
"cardano.node.couldNotForgeSlotLast", Text
"")]
      Text
"Leadership check failed: we were unable to get the ledger state for the\
      \  point of the block we want to connect to\
      \ \
      \  This can happen if after choosing which block to connect to the node\
      \  switched to a different fork. We expect this to happen only rather\
      \  rarely, so this certainly merits a warning; if it happens a lot, that\
      \  merits an investigation.\
      \ \
      \  We record both the current slot number as well as the point of the block\
      \  we attempt to connect the new block to (that we requested the ledger\
      \  state for)."
  , [Text]
-> [(Text, Text)]
-> Text
-> DocMsg
     (Either (TraceForgeEvent blk) TraceStartLeadershipCheckPlus)
forall a. [Text] -> [(Text, Text)] -> Text -> DocMsg a
DocMsg
      [Text
"LedgerState"]
      [(Text
"cardano.node.ledgerState", Text
"")]
      Text
"We obtained a ledger state for the point of the block we want to\
      \  connect to\
      \ \
      \  We record both the current slot number as well as the point of the block\
      \  we attempt to connect the new block to (that we requested the ledger\
      \  state for)."
  , [Text]
-> [(Text, Text)]
-> Text
-> DocMsg
     (Either (TraceForgeEvent blk) TraceStartLeadershipCheckPlus)
forall a. [Text] -> [(Text, Text)] -> Text -> DocMsg a
DocMsg
      [Text
"NoLedgerView"]
      [(Text
"cardano.node.couldNotForgeSlotLast", Text
"")]
      Text
"Leadership check failed: we were unable to get the ledger view for the\
      \  current slot number\
      \ \
      \  This will only happen if there are many missing blocks between the tip of\
      \  our chain and the current slot.\
      \ \
      \  We record also the failure returned by 'forecastFor'."
  , [Text]
-> [(Text, Text)]
-> Text
-> DocMsg
     (Either (TraceForgeEvent blk) TraceStartLeadershipCheckPlus)
forall a. [Text] -> [(Text, Text)] -> Text -> DocMsg a
DocMsg
      [Text
"LedgerView"]
      [(Text
"cardano.node.ledgerView", Text
"")]
      Text
"We obtained a ledger view for the current slot number\
      \ \
      \  We record the current slot number."
  , [Text]
-> [(Text, Text)]
-> Text
-> DocMsg
     (Either (TraceForgeEvent blk) TraceStartLeadershipCheckPlus)
forall a. [Text] -> [(Text, Text)] -> Text -> DocMsg a
DocMsg
      [Text
"ForgeStateUpdateError"]
      [ (Text
"cardano.node.operationalCertificateStartKESPeriod", Text
"")
      , (Text
"cardano.node.operationalCertificateExpiryKESPeriod", Text
"")
      , (Text
"cardano.node.currentKESPeriod", Text
"")
      , (Text
"cardano.node.remainingKESPeriods", Text
"")
      ]
      Text
"Updating the forge state failed.\
      \ \
      \  For example, the KES key could not be evolved anymore.\
      \ \
      \  We record the error returned by 'updateForgeState'."
  , [Text]
-> [(Text, Text)]
-> Text
-> DocMsg
     (Either (TraceForgeEvent blk) TraceStartLeadershipCheckPlus)
forall a. [Text] -> [(Text, Text)] -> Text -> DocMsg a
DocMsg
      [Text
"NodeCannotForge"]
      [(Text
"cardano.node.nodeCannotForge", Text
"")]
      Text
"We did the leadership check and concluded that we should lead and forge\
      \  a block, but cannot.\
      \ \
      \  This should only happen rarely and should be logged with warning severity.\
      \ \
      \  Records why we cannot forge a block."
  , [Text]
-> [(Text, Text)]
-> Text
-> DocMsg
     (Either (TraceForgeEvent blk) TraceStartLeadershipCheckPlus)
forall a. [Text] -> [(Text, Text)] -> Text -> DocMsg a
DocMsg
      [Text
"NodeNotLeader"]
      [(Text
"cardano.node.nodeNotLeader", Text
"")]
      Text
"We did the leadership check and concluded we are not the leader\
      \ \
      \  We record the current slot number"
  , [Text]
-> [(Text, Text)]
-> Text
-> DocMsg
     (Either (TraceForgeEvent blk) TraceStartLeadershipCheckPlus)
forall a. [Text] -> [(Text, Text)] -> Text -> DocMsg a
DocMsg
      [Text
"NodeIsLeader"]
      [(Text
"cardano.node.nodeIsLeader", Text
"")]
      Text
"We did the leadership check and concluded we /are/ the leader\
      \\n\
      \  The node will soon forge; it is about to read its transactions from the\
      \  Mempool. This will be followed by ForgedBlock."
  , [Text]
-> [(Text, Text)]
-> Text
-> DocMsg
     (Either (TraceForgeEvent blk) TraceStartLeadershipCheckPlus)
forall a. [Text] -> [(Text, Text)] -> Text -> DocMsg a
DocMsg
      [Text
"ForgedBlock"]
      [(Text
"cardano.node.forgedSlotLast", Text
"")]
      Text
"We forged a block.\
      \\n\
      \  We record the current slot number, the point of the predecessor, the block\
      \  itself, and the total size of the mempool snapshot at the time we produced\
      \  the block (which may be significantly larger than the block, due to\
      \  maximum block size)\
      \\n\
      \  This will be followed by one of three messages:\
      \\n\
      \  * AdoptedBlock (normally)\
      \\n\
      \  * DidntAdoptBlock (rarely)\
      \\n\
      \  * ForgedInvalidBlock (hopefully never -- this would indicate a bug)"
  , [Text]
-> [(Text, Text)]
-> Text
-> DocMsg
     (Either (TraceForgeEvent blk) TraceStartLeadershipCheckPlus)
forall a. [Text] -> [(Text, Text)] -> Text -> DocMsg a
DocMsg
      [Text
"DidntAdoptBlock"]
      [(Text
"cardano.node.notAdoptedSlotLast", Text
"")]
      Text
"We did not adopt the block we produced, but the block was valid. We\
      \  must have adopted a block that another leader of the same slot produced\
      \  before we got the chance of adopting our own block. This is very rare,\
      \  this warrants a warning."
  , [Text]
-> [(Text, Text)]
-> Text
-> DocMsg
     (Either (TraceForgeEvent blk) TraceStartLeadershipCheckPlus)
forall a. [Text] -> [(Text, Text)] -> Text -> DocMsg a
DocMsg
      [Text
"ForgedInvalidBlock"]
      [(Text
"cardano.node.forgedInvalidSlotLast", Text
"")]
      Text
"We forged a block that is invalid according to the ledger in the\
      \  ChainDB. This means there is an inconsistency between the mempool\
      \  validation and the ledger validation. This is a serious error!"
  , [Text]
-> [(Text, Text)]
-> Text
-> DocMsg
     (Either (TraceForgeEvent blk) TraceStartLeadershipCheckPlus)
forall a. [Text] -> [(Text, Text)] -> Text -> DocMsg a
DocMsg
      [Text
"AdoptedBlock"]
      [(Text
"cardano.node.adoptedSlotLast", Text
"")]
      Text
"We adopted the block we produced, we also trace the transactions\
      \  that were adopted."
  , [Text]
-> [(Text, Text)]
-> Text
-> DocMsg
     (Either (TraceForgeEvent blk) TraceStartLeadershipCheckPlus)
forall a. [Text] -> [(Text, Text)] -> Text -> DocMsg a
DocMsg
      [Text
"StartLeadershipCheckPlus"]
      [ (Text
"cardano.node.aboutToLeadSlotLast", Text
"")
      , (Text
"cardano.node.utxoSize", Text
"")
      , (Text
"cardano.node.delegMapSize", Text
"")
      ]
      Text
"We adopted the block we produced, we also trace the transactions\
      \  that were adopted."

  ]

instance ( tx ~ GenTx blk
         , ConvertRawHash blk
         , GetHeader blk
         , HasHeader blk
         , HasKESInfo blk
         , LedgerSupportsProtocol blk
         , LedgerSupportsMempool blk
         , SerialiseNodeToNodeConstraints blk
         , HasTxId (GenTx blk)
         , Show (ForgeStateUpdateError blk)
         , Show (CannotForge blk)
         , LogFormatting (InvalidBlockReason blk)
         , LogFormatting (CannotForge blk)
         , LogFormatting (ForgeStateUpdateError blk))
         => LogFormatting (ForgeTracerType blk) where
  forMachine :: DetailLevel -> ForgeTracerType blk -> Object
forMachine DetailLevel
dtal (Left TraceForgeEvent blk
i)  = DetailLevel -> TraceForgeEvent blk -> Object
forall a. LogFormatting a => DetailLevel -> a -> Object
forMachine DetailLevel
dtal TraceForgeEvent blk
i
  forMachine DetailLevel
dtal (Right TraceStartLeadershipCheckPlus
i) = DetailLevel -> TraceStartLeadershipCheckPlus -> Object
forall a. LogFormatting a => DetailLevel -> a -> Object
forMachine DetailLevel
dtal TraceStartLeadershipCheckPlus
i
  forHuman :: ForgeTracerType blk -> Text
forHuman (Left TraceForgeEvent blk
i)  = TraceForgeEvent blk -> Text
forall a. LogFormatting a => a -> Text
forHuman TraceForgeEvent blk
i
  forHuman (Right TraceStartLeadershipCheckPlus
i) = TraceStartLeadershipCheckPlus -> Text
forall a. LogFormatting a => a -> Text
forHuman TraceStartLeadershipCheckPlus
i
  asMetrics :: ForgeTracerType blk -> [Metric]
asMetrics (Left TraceForgeEvent blk
i)  = TraceForgeEvent blk -> [Metric]
forall a. LogFormatting a => a -> [Metric]
asMetrics TraceForgeEvent blk
i
  asMetrics (Right TraceStartLeadershipCheckPlus
i) = TraceStartLeadershipCheckPlus -> [Metric]
forall a. LogFormatting a => a -> [Metric]
asMetrics TraceStartLeadershipCheckPlus
i

--------------------------------------------------------------------------------
-- BlockchainTimeEvent Tracer
--------------------------------------------------------------------------------

namesForBlockchainTime :: TraceBlockchainTimeEvent t -> [Text]
namesForBlockchainTime :: TraceBlockchainTimeEvent t -> [Text]
namesForBlockchainTime TraceStartTimeInTheFuture {} = [Text
"StartTimeInTheFuture"]
namesForBlockchainTime TraceCurrentSlotUnknown {}   = [Text
"CurrentSlotUnknown"]
namesForBlockchainTime TraceSystemClockMovedBack {} = [Text
"SystemClockMovedBack"]

severityBlockchainTime :: TraceBlockchainTimeEvent t -> SeverityS
severityBlockchainTime :: TraceBlockchainTimeEvent t -> SeverityS
severityBlockchainTime TraceStartTimeInTheFuture {} = SeverityS
Warning
severityBlockchainTime TraceCurrentSlotUnknown {}   = SeverityS
Warning
severityBlockchainTime TraceSystemClockMovedBack {} = SeverityS
Warning

instance Show t => LogFormatting (TraceBlockchainTimeEvent t) where
    forMachine :: DetailLevel -> TraceBlockchainTimeEvent t -> Object
forMachine DetailLevel
_dtal (TraceStartTimeInTheFuture (SystemStart UTCTime
start) NominalDiffTime
toWait) =
        [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
"TStartTimeInTheFuture"
                 , Key
"systemStart" Key -> Value -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String (UTCTime -> Text
forall a. Show a => a -> Text
showT UTCTime
start)
                 , Key
"toWait" Key -> Value -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String (NominalDiffTime -> Text
forall a. Show a => a -> Text
showT NominalDiffTime
toWait)
                 ]
    forMachine DetailLevel
_dtal (TraceCurrentSlotUnknown t
time PastHorizonException
_) =
        [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
"CurrentSlotUnknown"
                 , Key
"time" Key -> Value -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String (t -> Text
forall a. Show a => a -> Text
showT t
time)
                 ]
    forMachine DetailLevel
_dtal (TraceSystemClockMovedBack t
prevTime t
newTime) =
        [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
"SystemClockMovedBack"
                 , Key
"prevTime" Key -> Value -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String (t -> Text
forall a. Show a => a -> Text
showT t
prevTime)
                 , Key
"newTime" Key -> Value -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String (t -> Text
forall a. Show a => a -> Text
showT t
newTime)
                 ]
    forHuman :: TraceBlockchainTimeEvent t -> Text
forHuman (TraceStartTimeInTheFuture (SystemStart UTCTime
start) NominalDiffTime
toWait) =
      Text
"Waiting "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
Text.pack (String -> Text)
-> (NominalDiffTime -> String) -> NominalDiffTime -> Text
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. NominalDiffTime -> String
forall a. Show a => a -> String
show) NominalDiffTime
toWait
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" until genesis start time at "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
Text.pack (String -> Text) -> (UTCTime -> String) -> UTCTime -> Text
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. UTCTime -> String
forall a. Show a => a -> String
show) UTCTime
start
    forHuman (TraceCurrentSlotUnknown t
time PastHorizonException
_) =
      Text
"Too far from the chain tip to determine the current slot number for the time "
       Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
Text.pack (String -> Text) -> (t -> String) -> t -> Text
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. t -> String
forall a. Show a => a -> String
show) t
time
    forHuman (TraceSystemClockMovedBack t
prevTime t
newTime) =
      Text
"The system wall clock time moved backwards, but within our tolerance "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"threshold. Previous 'current' time: "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
Text.pack (String -> Text) -> (t -> String) -> t -> Text
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. t -> String
forall a. Show a => a -> String
show) t
prevTime
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
". New 'current' time: "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
Text.pack (String -> Text) -> (t -> String) -> t -> Text
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. t -> String
forall a. Show a => a -> String
show) t
newTime

docBlockchainTime :: Documented (TraceBlockchainTimeEvent t)
docBlockchainTime :: Documented (TraceBlockchainTimeEvent t)
docBlockchainTime =
    [Text]
-> Documented (TraceBlockchainTimeEvent Any)
-> Documented (TraceBlockchainTimeEvent t)
forall a b. [Text] -> Documented a -> Documented b
addDocumentedNamespace [] Documented (TraceBlockchainTimeEvent Any)
forall t. Documented (TraceBlockchainTimeEvent t)
docBlockchainTime'

docBlockchainTime' :: Documented (TraceBlockchainTimeEvent t)
docBlockchainTime' :: Documented (TraceBlockchainTimeEvent t)
docBlockchainTime' = [DocMsg (TraceBlockchainTimeEvent t)]
-> Documented (TraceBlockchainTimeEvent t)
forall a. [DocMsg a] -> Documented a
Documented [
    [Text]
-> [(Text, Text)] -> Text -> DocMsg (TraceBlockchainTimeEvent t)
forall a. [Text] -> [(Text, Text)] -> Text -> DocMsg a
DocMsg
      [Text
"StartTimeInTheFuture"]
      []
      Text
"The start time of the blockchain time is in the future\
      \\n\
      \ We have to block (for 'NominalDiffTime') until that time comes."
  , [Text]
-> [(Text, Text)] -> Text -> DocMsg (TraceBlockchainTimeEvent t)
forall a. [Text] -> [(Text, Text)] -> Text -> DocMsg a
DocMsg
      [Text
"CurrentSlotUnknown"]
      []
      Text
"Current slot is not yet known\
      \\n\
      \ This happens when the tip of our current chain is so far in the past that\
      \ we cannot translate the current wallclock to a slot number, typically\
      \ during syncing. Until the current slot number is known, we cannot\
      \ produce blocks. Seeing this message during syncing therefore is\
      \ normal and to be expected.\
      \\n\
      \ We record the current time (the time we tried to translate to a 'SlotNo')\
      \ as well as the 'PastHorizonException', which provides detail on the\
      \ bounds between which we /can/ do conversions. The distance between the\
      \ current time and the upper bound should rapidly decrease with consecutive\
      \ 'CurrentSlotUnknown' messages during syncing."
  , [Text]
-> [(Text, Text)] -> Text -> DocMsg (TraceBlockchainTimeEvent t)
forall a. [Text] -> [(Text, Text)] -> Text -> DocMsg a
DocMsg
      [Text
"SystemClockMovedBack"]
      []
      Text
"The system clock moved back an acceptable time span, e.g., because of\
      \ an NTP sync.\
      \\n\
      \ The system clock moved back such that the new current slot would be\
      \ smaller than the previous one. If this is within the configured limit, we\
      \ trace this warning but *do not change the current slot*. The current slot\
      \ never decreases, but the current slot may stay the same longer than\
      \ expected.\
      \\n\
      \ When the system clock moved back more than the configured limit, we shut\
      \ down with a fatal exception."
  ]

--------------------------------------------------------------------------------
-- KeepAliveClient Tracer
--------------------------------------------------------------------------------

namesForKeepAliveClient :: TraceKeepAliveClient peer -> [Text]
namesForKeepAliveClient :: TraceKeepAliveClient peer -> [Text]
namesForKeepAliveClient TraceKeepAliveClient peer
_ = []

severityKeepAliveClient :: TraceKeepAliveClient peer -> SeverityS
severityKeepAliveClient :: TraceKeepAliveClient peer -> SeverityS
severityKeepAliveClient TraceKeepAliveClient peer
_ = SeverityS
Info

instance Show remotePeer => LogFormatting (TraceKeepAliveClient remotePeer) where
    forMachine :: DetailLevel -> TraceKeepAliveClient remotePeer -> Object
forMachine DetailLevel
_dtal (AddSample remotePeer
peer DiffTime
rtt PeerGSV
pgsv) =
        [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
"AddSample"
          , Key
"address" Key -> String -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= remotePeer -> String
forall a. Show a => a -> String
show remotePeer
peer
          , Key
"rtt" Key -> DiffTime -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= DiffTime
rtt
          , Key
"sampleTime" Key -> String -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Double -> String
forall a. Show a => a -> String
show (Time -> Double
dTime (Time -> Double) -> Time -> Double
forall a b. (a -> b) -> a -> b
$ PeerGSV -> Time
sampleTime PeerGSV
pgsv)
          , Key
"outboundG" Key -> Double -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (DiffTime -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac (DiffTime -> Double) -> DiffTime -> Double
forall a b. (a -> b) -> a -> b
$ GSV -> DiffTime
gGSV (PeerGSV -> GSV
outboundGSV PeerGSV
pgsv) :: Double)
          , Key
"inboundG" Key -> Double -> Object
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (DiffTime -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac (DiffTime -> Double) -> DiffTime -> Double
forall a b. (a -> b) -> a -> b
$ GSV -> DiffTime
gGSV (PeerGSV -> GSV
inboundGSV PeerGSV
pgsv) :: Double)
          ]
        where
          gGSV :: GSV -> DiffTime
          gGSV :: GSV -> DiffTime
gGSV (GSV DiffTime
g Word32 -> DiffTime
_ Distribution DiffTime
_) = DiffTime
g

          dTime :: Time -> Double
          dTime :: Time -> Double
dTime (Time DiffTime
d) = DiffTime -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac DiffTime
d

    forHuman :: TraceKeepAliveClient remotePeer -> Text
forHuman = TraceKeepAliveClient remotePeer -> Text
forall a. Show a => a -> Text
showT

docKeepAliveClient :: Documented (TraceKeepAliveClient peer)
docKeepAliveClient :: Documented (TraceKeepAliveClient peer)
docKeepAliveClient = [DocMsg (TraceKeepAliveClient peer)]
-> Documented (TraceKeepAliveClient peer)
forall a. [DocMsg a] -> Documented a
Documented [
    [Text]
-> [(Text, Text)] -> Text -> DocMsg (TraceKeepAliveClient peer)
forall a. [Text] -> [(Text, Text)] -> Text -> DocMsg a
DocMsg
      []
      []
      Text
""
  ]