{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}

{-# OPTIONS_GHC -Wno-orphans  #-}

module Cardano.Tracing.Tracers
  ( Tracers (..)
  , TraceOptions
  , mkTracers
  , nullTracers
  , traceCounter
  ) where

import           Cardano.Prelude hiding (show)
import           Prelude (String, show)

import           GHC.Clock (getMonotonicTimeNSec)

import           Codec.CBOR.Read (DeserialiseFailure)
import           Data.Aeson (ToJSON (..), Value (..))
import qualified Data.HashMap.Strict as Map
import qualified Data.Map.Strict as SMap
import qualified Data.Text as Text
import           Data.Time (UTCTime)
import qualified System.Metrics.Counter as Counter
import qualified System.Metrics.Gauge as Gauge
import qualified System.Metrics.Label as Label
import qualified System.Remote.Monitoring as EKG

import           Network.Mux (MuxTrace, WithMuxBearer)
import qualified Network.Socket as Socket (SockAddr)

import           Control.Tracer
import           Control.Tracer.Transformers

import           Cardano.Slotting.Slot (EpochNo (..), SlotNo (..))

import           Cardano.BM.Data.Aggregated (Measurable (..))
import           Cardano.BM.Data.Tracer (WithSeverity (..), annotateSeverity)
import           Cardano.BM.Data.Transformers
import           Cardano.BM.Internal.ElidingTracer
import           Cardano.BM.Trace (traceNamedObject)
import           Cardano.BM.Tracing

import           Ouroboros.Consensus.Block (BlockConfig, BlockProtocol, CannotForge, ConvertRawHash,
                   ForgeStateInfo, ForgeStateUpdateError, Header, realPointSlot)
import           Ouroboros.Consensus.BlockchainTime (SystemStart (..),
                   TraceBlockchainTimeEvent (..))
import           Ouroboros.Consensus.HeaderValidation (OtherHeaderEnvelopeError)
import           Ouroboros.Consensus.Ledger.Abstract (LedgerErr, LedgerState)
import           Ouroboros.Consensus.Ledger.Extended (ledgerState)
import           Ouroboros.Consensus.Ledger.Inspect (InspectLedger, LedgerEvent)
import           Ouroboros.Consensus.Ledger.Query (Query)
import           Ouroboros.Consensus.Ledger.SupportsMempool (ApplyTxErr, GenTx, GenTxId, HasTxs,
                   LedgerSupportsMempool)
import           Ouroboros.Consensus.Ledger.SupportsProtocol (LedgerSupportsProtocol)
import           Ouroboros.Consensus.Mempool.API (MempoolSize (..), TraceEventMempool (..))
import qualified Ouroboros.Consensus.Network.NodeToClient as NodeToClient
import qualified Ouroboros.Consensus.Network.NodeToNode as NodeToNode
import qualified Ouroboros.Consensus.Node.Run as Consensus (RunNode)
import qualified Ouroboros.Consensus.Node.Tracers as Consensus
import           Ouroboros.Consensus.Protocol.Abstract (ValidationErr)
import qualified Ouroboros.Consensus.Shelley.Protocol.HotKey as HotKey

import qualified Ouroboros.Network.AnchoredFragment as AF
import           Ouroboros.Network.Block (BlockNo (..), HasHeader (..), Point, StandardHash,
                   blockNo, pointSlot, unBlockNo)
import           Ouroboros.Network.BlockFetch.ClientState (TraceLabelPeer (..))
import           Ouroboros.Network.BlockFetch.Decision (FetchDecision, FetchDecline (..))
import qualified Ouroboros.Network.NodeToClient as NtC
import qualified Ouroboros.Network.NodeToNode as NtN
import           Ouroboros.Network.Point (fromWithOrigin, withOrigin)
import           Ouroboros.Network.Protocol.LocalStateQuery.Type (ShowQuery)
import           Ouroboros.Network.Subscription

import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB
import qualified Ouroboros.Consensus.Storage.LedgerDB.OnDisk as LedgerDB

import           Cardano.Tracing.Config
import           Cardano.Tracing.Constraints (TraceConstraints)
import           Cardano.Tracing.ConvertTxId (ConvertTxId)
import           Cardano.Tracing.Kernel
import           Cardano.Tracing.Metrics
import           Cardano.Tracing.Queries

import           Cardano.Node.Configuration.Logging
-- For tracing instances
import           Cardano.Node.Protocol.Byron ()
import           Cardano.Node.Protocol.Shelley ()
import           Ouroboros.Consensus.MiniProtocol.BlockFetch.Server
import           Ouroboros.Consensus.MiniProtocol.ChainSync.Server
import           Ouroboros.Network.TxSubmission.Inbound

import qualified Cardano.Node.STM as STM
import qualified Control.Concurrent.STM as STM
import qualified Ouroboros.Network.Diffusion as ND

import           Shelley.Spec.Ledger.OCert (KESPeriod (..))

{- HLINT ignore "Redundant bracket" -}
{- HLINT ignore "Use record patterns" -}

data Tracers peer localPeer blk = Tracers
  { -- | Trace the ChainDB
    Tracers peer localPeer blk -> Tracer IO (TraceEvent blk)
chainDBTracer :: Tracer IO (ChainDB.TraceEvent blk)
    -- | Consensus-specific tracers.
  , Tracers peer localPeer blk -> Tracers IO peer localPeer blk
consensusTracers :: Consensus.Tracers IO peer localPeer blk
    -- | Tracers for the node-to-node protocols.
  , Tracers peer localPeer blk
-> Tracers IO peer blk DeserialiseFailure
nodeToNodeTracers :: NodeToNode.Tracers IO peer blk DeserialiseFailure
    --, serialisedBlockTracer :: NodeToNode.SerialisedTracer IO peer blk (SerialisedBlockTrace)
    -- | Tracers for the node-to-client protocols
  , Tracers peer localPeer blk
-> Tracers IO localPeer blk DeserialiseFailure
nodeToClientTracers :: NodeToClient.Tracers IO localPeer blk DeserialiseFailure
    -- | Trace the IP subscription manager
  , Tracers peer localPeer blk
-> Tracer IO (WithIPList (SubscriptionTrace SockAddr))
ipSubscriptionTracer :: Tracer IO (WithIPList (SubscriptionTrace Socket.SockAddr))
    -- | Trace the DNS subscription manager
  , Tracers peer localPeer blk
-> Tracer IO (WithDomainName (SubscriptionTrace SockAddr))
dnsSubscriptionTracer :: Tracer IO (WithDomainName (SubscriptionTrace Socket.SockAddr))
    -- | Trace the DNS resolver
  , Tracers peer localPeer blk -> Tracer IO (WithDomainName DnsTrace)
dnsResolverTracer :: Tracer IO (WithDomainName DnsTrace)
    -- | Trace error policy resolution
  , Tracers peer localPeer blk
-> Tracer IO (WithAddr SockAddr ErrorPolicyTrace)
errorPolicyTracer :: Tracer IO (NtN.WithAddr Socket.SockAddr NtN.ErrorPolicyTrace)
    -- | Trace local error policy resolution
  , Tracers peer localPeer blk
-> Tracer IO (WithAddr LocalAddress ErrorPolicyTrace)
localErrorPolicyTracer :: Tracer IO (NtN.WithAddr NtC.LocalAddress NtN.ErrorPolicyTrace)
  , Tracers peer localPeer blk
-> Tracer IO AcceptConnectionsPolicyTrace
acceptPolicyTracer :: Tracer IO NtN.AcceptConnectionsPolicyTrace
    -- | Trace the Mux
  , Tracers peer localPeer blk
-> Tracer IO (WithMuxBearer peer MuxTrace)
muxTracer :: Tracer IO (WithMuxBearer peer MuxTrace)
  , Tracers peer localPeer blk
-> Tracer IO (WithMuxBearer localPeer MuxTrace)
muxLocalTracer :: Tracer IO (WithMuxBearer localPeer MuxTrace)
  , Tracers peer localPeer blk -> Tracer IO HandshakeTr
handshakeTracer :: Tracer IO NtN.HandshakeTr
  , Tracers peer localPeer blk -> Tracer IO HandshakeTr
localHandshakeTracer :: Tracer IO NtC.HandshakeTr
  , Tracers peer localPeer blk
-> Tracer IO DiffusionInitializationTracer
diffusionInitializationTracer :: Tracer IO ND.DiffusionInitializationTracer
  }

data ForgeTracers = ForgeTracers
  { ForgeTracers -> Trace IO Text
ftForged :: Trace IO Text
  , ForgeTracers -> Trace IO Text
ftForgeAboutToLead :: Trace IO Text
  , ForgeTracers -> Trace IO Text
ftCouldNotForge :: Trace IO Text
  , ForgeTracers -> Trace IO Text
ftAdopted :: Trace IO Text
  , ForgeTracers -> Trace IO Text
ftDidntAdoptBlock :: Trace IO Text
  , ForgeTracers -> Trace IO Text
ftForgedInvalid   :: Trace IO Text
  , ForgeTracers -> Trace IO Text
ftTraceNodeNotLeader  :: Trace IO Text
  , ForgeTracers -> Trace IO Text
ftTraceNodeCannotForge :: Trace IO Text
  , ForgeTracers -> Trace IO Text
ftTraceForgeStateUpdateError :: Trace IO Text
  , ForgeTracers -> Trace IO Text
ftTraceBlockFromFuture :: Trace IO Text
  , ForgeTracers -> Trace IO Text
ftTraceSlotIsImmutable :: Trace IO Text
  , ForgeTracers -> Trace IO Text
ftTraceNodeIsLeader :: Trace IO Text
  }

nullTracers :: Tracers peer localPeer blk
nullTracers :: Tracers peer localPeer blk
nullTracers = Tracers :: forall peer localPeer blk.
Tracer IO (TraceEvent blk)
-> Tracers IO peer localPeer blk
-> Tracers IO peer blk DeserialiseFailure
-> Tracers IO localPeer blk DeserialiseFailure
-> Tracer IO (WithIPList (SubscriptionTrace SockAddr))
-> Tracer IO (WithDomainName (SubscriptionTrace SockAddr))
-> Tracer IO (WithDomainName DnsTrace)
-> Tracer IO (WithAddr SockAddr ErrorPolicyTrace)
-> Tracer IO (WithAddr LocalAddress ErrorPolicyTrace)
-> Tracer IO AcceptConnectionsPolicyTrace
-> Tracer IO (WithMuxBearer peer MuxTrace)
-> Tracer IO (WithMuxBearer localPeer MuxTrace)
-> Tracer IO HandshakeTr
-> Tracer IO HandshakeTr
-> Tracer IO DiffusionInitializationTracer
-> Tracers peer localPeer blk
Tracers
  { chainDBTracer :: Tracer IO (TraceEvent blk)
chainDBTracer = Tracer IO (TraceEvent blk)
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
  , consensusTracers :: Tracers IO peer localPeer blk
consensusTracers = Tracers IO peer localPeer blk
forall (m :: * -> *) remotePeer localPeer blk.
Monad m =>
Tracers m remotePeer localPeer blk
Consensus.nullTracers
  , nodeToClientTracers :: Tracers IO localPeer blk DeserialiseFailure
nodeToClientTracers = Tracers IO localPeer blk DeserialiseFailure
forall (m :: * -> *) peer blk e. Monad m => Tracers m peer blk e
NodeToClient.nullTracers
  , nodeToNodeTracers :: Tracers IO peer blk DeserialiseFailure
nodeToNodeTracers = Tracers IO peer blk DeserialiseFailure
forall (m :: * -> *) peer blk e. Monad m => Tracers m peer blk e
NodeToNode.nullTracers
  , ipSubscriptionTracer :: Tracer IO (WithIPList (SubscriptionTrace SockAddr))
ipSubscriptionTracer = Tracer IO (WithIPList (SubscriptionTrace SockAddr))
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
  , dnsSubscriptionTracer :: Tracer IO (WithDomainName (SubscriptionTrace SockAddr))
dnsSubscriptionTracer = Tracer IO (WithDomainName (SubscriptionTrace SockAddr))
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
  , dnsResolverTracer :: Tracer IO (WithDomainName DnsTrace)
dnsResolverTracer = Tracer IO (WithDomainName DnsTrace)
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
  , errorPolicyTracer :: Tracer IO (WithAddr SockAddr ErrorPolicyTrace)
errorPolicyTracer = Tracer IO (WithAddr SockAddr ErrorPolicyTrace)
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
  , localErrorPolicyTracer :: Tracer IO (WithAddr LocalAddress ErrorPolicyTrace)
localErrorPolicyTracer = Tracer IO (WithAddr LocalAddress ErrorPolicyTrace)
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
  , acceptPolicyTracer :: Tracer IO AcceptConnectionsPolicyTrace
acceptPolicyTracer = Tracer IO AcceptConnectionsPolicyTrace
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
  , muxTracer :: Tracer IO (WithMuxBearer peer MuxTrace)
muxTracer = Tracer IO (WithMuxBearer peer MuxTrace)
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
  , muxLocalTracer :: Tracer IO (WithMuxBearer localPeer MuxTrace)
muxLocalTracer = Tracer IO (WithMuxBearer localPeer MuxTrace)
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
  , handshakeTracer :: Tracer IO HandshakeTr
handshakeTracer = Tracer IO HandshakeTr
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
  , localHandshakeTracer :: Tracer IO HandshakeTr
localHandshakeTracer = Tracer IO HandshakeTr
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
  , diffusionInitializationTracer :: Tracer IO DiffusionInitializationTracer
diffusionInitializationTracer = Tracer IO DiffusionInitializationTracer
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
  }


indexGCType :: ChainDB.TraceGCEvent a -> Int
indexGCType :: TraceGCEvent a -> Int
indexGCType ChainDB.ScheduledGC{} = Int
1
indexGCType ChainDB.PerformedGC{} = Int
2

indexReplType :: ChainDB.TraceLedgerReplayEvent a -> Int
indexReplType :: TraceLedgerReplayEvent a -> Int
indexReplType LedgerDB.ReplayFromGenesis{} = Int
1
indexReplType LedgerDB.ReplayFromSnapshot{} = Int
2
indexReplType LedgerDB.ReplayedBlock{} = Int
3

instance ElidingTracer (WithSeverity (ChainDB.TraceEvent blk)) where
  -- equivalent by type and severity
  isEquivalent :: WithSeverity (TraceEvent blk)
-> WithSeverity (TraceEvent blk) -> Bool
isEquivalent (WithSeverity Severity
s1 (ChainDB.TraceLedgerReplayEvent TraceLedgerReplayEvent blk
ev1))
               (WithSeverity Severity
s2 (ChainDB.TraceLedgerReplayEvent TraceLedgerReplayEvent blk
ev2)) =
                  Severity
s1 Severity -> Severity -> Bool
forall a. Eq a => a -> a -> Bool
== Severity
s2 Bool -> Bool -> Bool
&& TraceLedgerReplayEvent blk -> Int
forall a. TraceLedgerReplayEvent a -> Int
indexReplType TraceLedgerReplayEvent blk
ev1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== TraceLedgerReplayEvent blk -> Int
forall a. TraceLedgerReplayEvent a -> Int
indexReplType TraceLedgerReplayEvent blk
ev2
  isEquivalent (WithSeverity Severity
s1 (ChainDB.TraceGCEvent TraceGCEvent blk
ev1))
               (WithSeverity Severity
s2 (ChainDB.TraceGCEvent TraceGCEvent blk
ev2)) =
                  Severity
s1 Severity -> Severity -> Bool
forall a. Eq a => a -> a -> Bool
== Severity
s2 Bool -> Bool -> Bool
&& TraceGCEvent blk -> Int
forall a. TraceGCEvent a -> Int
indexGCType TraceGCEvent blk
ev1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== TraceGCEvent blk -> Int
forall a. TraceGCEvent a -> Int
indexGCType TraceGCEvent blk
ev2
  isEquivalent (WithSeverity Severity
_s1 (ChainDB.TraceAddBlockEvent TraceAddBlockEvent blk
_))
               (WithSeverity Severity
_s2 (ChainDB.TraceAddBlockEvent TraceAddBlockEvent blk
_)) = Bool
True
  isEquivalent (WithSeverity Severity
_s1 (ChainDB.TraceGCEvent TraceGCEvent blk
_ev1))
               (WithSeverity Severity
_s2 (ChainDB.TraceAddBlockEvent TraceAddBlockEvent blk
_)) = Bool
True
  isEquivalent (WithSeverity Severity
_s1 (ChainDB.TraceAddBlockEvent TraceAddBlockEvent blk
_))
               (WithSeverity Severity
_s2 (ChainDB.TraceGCEvent TraceGCEvent blk
_ev2)) = Bool
True
  isEquivalent (WithSeverity Severity
_s1 (ChainDB.TraceGCEvent TraceGCEvent blk
_ev1))
               (WithSeverity Severity
_s2 (ChainDB.TraceCopyToImmutableDBEvent TraceCopyToImmutableDBEvent blk
_)) = Bool
True
  isEquivalent (WithSeverity Severity
_s1 (ChainDB.TraceCopyToImmutableDBEvent TraceCopyToImmutableDBEvent blk
_))
               (WithSeverity Severity
_s2 (ChainDB.TraceGCEvent TraceGCEvent blk
_ev2)) = Bool
True
  isEquivalent (WithSeverity Severity
_s1 (ChainDB.TraceCopyToImmutableDBEvent TraceCopyToImmutableDBEvent blk
_))
               (WithSeverity Severity
_s2 (ChainDB.TraceAddBlockEvent TraceAddBlockEvent blk
_)) = Bool
True
  isEquivalent (WithSeverity Severity
_s1 (ChainDB.TraceAddBlockEvent TraceAddBlockEvent blk
_))
               (WithSeverity Severity
_s2 (ChainDB.TraceCopyToImmutableDBEvent TraceCopyToImmutableDBEvent blk
_)) = Bool
True
  isEquivalent (WithSeverity Severity
_s1 (ChainDB.TraceCopyToImmutableDBEvent TraceCopyToImmutableDBEvent blk
_))
               (WithSeverity Severity
_s2 (ChainDB.TraceCopyToImmutableDBEvent TraceCopyToImmutableDBEvent blk
_)) = Bool
True
  isEquivalent WithSeverity (TraceEvent blk)
_ WithSeverity (TraceEvent blk)
_ = Bool
False
  -- the types to be elided
  doelide :: WithSeverity (TraceEvent blk) -> Bool
doelide (WithSeverity Severity
_ (ChainDB.TraceLedgerReplayEvent TraceLedgerReplayEvent blk
_)) = Bool
True
  doelide (WithSeverity Severity
_ (ChainDB.TraceGCEvent TraceGCEvent blk
_)) = Bool
True
  doelide (WithSeverity Severity
_ (ChainDB.TraceAddBlockEvent (ChainDB.IgnoreBlockOlderThanK RealPoint blk
_))) = Bool
False
  doelide (WithSeverity Severity
_ (ChainDB.TraceAddBlockEvent (ChainDB.IgnoreInvalidBlock RealPoint blk
_ InvalidBlockReason blk
_))) = Bool
False
  doelide (WithSeverity Severity
_ (ChainDB.TraceAddBlockEvent (ChainDB.BlockInTheFuture RealPoint blk
_ SlotNo
_))) = Bool
False
  doelide (WithSeverity Severity
_ (ChainDB.TraceAddBlockEvent (ChainDB.StoreButDontChange RealPoint blk
_))) = Bool
False
  doelide (WithSeverity Severity
_ (ChainDB.TraceAddBlockEvent (ChainDB.TrySwitchToAFork RealPoint blk
_ ChainDiff (HeaderFields blk)
_))) = Bool
False
  doelide (WithSeverity Severity
_ (ChainDB.TraceAddBlockEvent (ChainDB.SwitchedToAFork{}))) = Bool
False
  doelide (WithSeverity Severity
_ (ChainDB.TraceAddBlockEvent (ChainDB.AddBlockValidation (ChainDB.InvalidBlock ExtValidationError blk
_ RealPoint blk
_)))) = Bool
False
  doelide (WithSeverity Severity
_ (ChainDB.TraceAddBlockEvent (ChainDB.AddBlockValidation (ChainDB.InvalidCandidate AnchoredFragment (Header blk)
_)))) = Bool
False
  doelide (WithSeverity Severity
_ (ChainDB.TraceAddBlockEvent (ChainDB.AddBlockValidation ChainDB.CandidateContainsFutureBlocksExceedingClockSkew{}))) = Bool
False
  doelide (WithSeverity Severity
_ (ChainDB.TraceAddBlockEvent (ChainDB.AddedToCurrentChain [LedgerEvent blk]
events NewTipInfo blk
_ AnchoredFragment (Header blk)
_  AnchoredFragment (Header blk)
_))) = [LedgerEvent blk] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LedgerEvent blk]
events
  doelide (WithSeverity Severity
_ (ChainDB.TraceAddBlockEvent TraceAddBlockEvent blk
_)) = Bool
True
  doelide (WithSeverity Severity
_ (ChainDB.TraceCopyToImmutableDBEvent TraceCopyToImmutableDBEvent blk
_)) = Bool
True
  doelide WithSeverity (TraceEvent blk)
_ = Bool
False
  conteliding :: TracingVerbosity
-> Trace IO t
-> WithSeverity (TraceEvent blk)
-> (Maybe (WithSeverity (TraceEvent blk)), Integer)
-> IO (Maybe (WithSeverity (TraceEvent blk)), Integer)
conteliding TracingVerbosity
_tverb Trace IO t
_tr WithSeverity (TraceEvent blk)
_ (Maybe (WithSeverity (TraceEvent blk))
Nothing, Integer
_count) = (Maybe (WithSeverity (TraceEvent blk)), Integer)
-> IO (Maybe (WithSeverity (TraceEvent blk)), Integer)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (WithSeverity (TraceEvent blk))
forall a. Maybe a
Nothing, Integer
0)
  conteliding TracingVerbosity
tverb Trace IO t
tr ev :: WithSeverity (TraceEvent blk)
ev@(WithSeverity Severity
_ (ChainDB.TraceAddBlockEvent ChainDB.AddedToCurrentChain{})) (Maybe (WithSeverity (TraceEvent blk))
_old, Integer
oldt) = do
      Integer
tnow <- Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Integer) -> IO Word64 -> IO Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Word64
getMonotonicTimeNSec
      let deltat :: Integer
deltat = Integer
tnow Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
oldt
      if Integer
deltat Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
1250000000 -- report at most every 1250 ms
        then do
          Tracer IO (WithSeverity (TraceEvent blk))
-> WithSeverity (TraceEvent blk) -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith (TracingVerbosity
-> Trace IO t -> Tracer IO (WithSeverity (TraceEvent blk))
forall (m :: * -> *) a b.
(ToLogObject m, ToObject a, Transformable a m b) =>
TracingVerbosity -> Trace m a -> Tracer m b
toLogObject' TracingVerbosity
tverb Trace IO t
tr) WithSeverity (TraceEvent blk)
ev
          (Maybe (WithSeverity (TraceEvent blk)), Integer)
-> IO (Maybe (WithSeverity (TraceEvent blk)), Integer)
forall (m :: * -> *) a. Monad m => a -> m a
return (WithSeverity (TraceEvent blk)
-> Maybe (WithSeverity (TraceEvent blk))
forall a. a -> Maybe a
Just WithSeverity (TraceEvent blk)
ev, Integer
tnow)
        else (Maybe (WithSeverity (TraceEvent blk)), Integer)
-> IO (Maybe (WithSeverity (TraceEvent blk)), Integer)
forall (m :: * -> *) a. Monad m => a -> m a
return (WithSeverity (TraceEvent blk)
-> Maybe (WithSeverity (TraceEvent blk))
forall a. a -> Maybe a
Just WithSeverity (TraceEvent blk)
ev, Integer
oldt)
  conteliding TracingVerbosity
_tverb Trace IO t
_tr ev :: WithSeverity (TraceEvent blk)
ev@(WithSeverity Severity
_ (ChainDB.TraceAddBlockEvent TraceAddBlockEvent blk
_)) (Maybe (WithSeverity (TraceEvent blk))
_old, Integer
count) =
      (Maybe (WithSeverity (TraceEvent blk)), Integer)
-> IO (Maybe (WithSeverity (TraceEvent blk)), Integer)
forall (m :: * -> *) a. Monad m => a -> m a
return (WithSeverity (TraceEvent blk)
-> Maybe (WithSeverity (TraceEvent blk))
forall a. a -> Maybe a
Just WithSeverity (TraceEvent blk)
ev, Integer
count)
  conteliding TracingVerbosity
_tverb Trace IO t
_tr ev :: WithSeverity (TraceEvent blk)
ev@(WithSeverity Severity
_ (ChainDB.TraceCopyToImmutableDBEvent TraceCopyToImmutableDBEvent blk
_)) (Maybe (WithSeverity (TraceEvent blk))
_old, Integer
count) =
      (Maybe (WithSeverity (TraceEvent blk)), Integer)
-> IO (Maybe (WithSeverity (TraceEvent blk)), Integer)
forall (m :: * -> *) a. Monad m => a -> m a
return (WithSeverity (TraceEvent blk)
-> Maybe (WithSeverity (TraceEvent blk))
forall a. a -> Maybe a
Just WithSeverity (TraceEvent blk)
ev, Integer
count)
  conteliding TracingVerbosity
_tverb Trace IO t
_tr ev :: WithSeverity (TraceEvent blk)
ev@(WithSeverity Severity
_ (ChainDB.TraceGCEvent TraceGCEvent blk
_)) (Maybe (WithSeverity (TraceEvent blk))
_old, Integer
count) =
      (Maybe (WithSeverity (TraceEvent blk)), Integer)
-> IO (Maybe (WithSeverity (TraceEvent blk)), Integer)
forall (m :: * -> *) a. Monad m => a -> m a
return (WithSeverity (TraceEvent blk)
-> Maybe (WithSeverity (TraceEvent blk))
forall a. a -> Maybe a
Just WithSeverity (TraceEvent blk)
ev, Integer
count)
  conteliding TracingVerbosity
_tverb Trace IO t
tr ev :: WithSeverity (TraceEvent blk)
ev@(WithSeverity Severity
_ (ChainDB.TraceLedgerReplayEvent (LedgerDB.ReplayedBlock RealPoint blk
pt [] Point blk
replayTo))) (Maybe (WithSeverity (TraceEvent blk))
_old, Integer
count) = do
      let slotno :: Integer
slotno = Word64 -> Integer
forall a. Integral a => a -> Integer
toInteger (Word64 -> Integer) -> Word64 -> Integer
forall a b. (a -> b) -> a -> b
$ SlotNo -> Word64
unSlotNo (RealPoint blk -> SlotNo
forall blk. RealPoint blk -> SlotNo
realPointSlot RealPoint blk
pt)
          endslot :: Integer
endslot = Word64 -> Integer
forall a. Integral a => a -> Integer
toInteger (Word64 -> Integer) -> Word64 -> Integer
forall a b. (a -> b) -> a -> b
$ Word64 -> (SlotNo -> Word64) -> WithOrigin SlotNo -> Word64
forall b t. b -> (t -> b) -> WithOrigin t -> b
withOrigin Word64
0 SlotNo -> Word64
unSlotNo (Point blk -> WithOrigin SlotNo
forall block. Point block -> WithOrigin SlotNo
pointSlot Point blk
replayTo)
          startslot :: Integer
startslot = if Integer
count Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0 then Integer
slotno else Integer -> Integer
forall a. Integral a => a -> Integer
toInteger Integer
count
          Double
progress :: Double = (Integer -> Double
forall a. Num a => Integer -> a
fromInteger Integer
slotno Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
100.0) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Integer -> Double
forall a. Num a => Integer -> a
fromInteger (Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
max Integer
slotno Integer
endslot)
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Integer
count Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
0 Bool -> Bool -> Bool
&& (Integer
slotno Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
startslot) Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`mod` Integer
1000 Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do  -- report every 1000th slot
          LOMeta
meta <- Severity -> PrivacyAnnotation -> IO LOMeta
forall (m :: * -> *).
MonadIO m =>
Severity -> PrivacyAnnotation -> m LOMeta
mkLOMeta (WithSeverity (TraceEvent blk) -> Severity
forall a. HasSeverityAnnotation a => a -> Severity
getSeverityAnnotation WithSeverity (TraceEvent blk)
ev) (WithSeverity (TraceEvent blk) -> PrivacyAnnotation
forall a. HasPrivacyAnnotation a => a -> PrivacyAnnotation
getPrivacyAnnotation WithSeverity (TraceEvent blk)
ev)
          Trace IO t -> (LOMeta, LOContent t) -> IO ()
forall (m :: * -> *) a.
MonadIO m =>
Trace m a -> (LOMeta, LOContent a) -> m ()
traceNamedObject Trace IO t
tr (LOMeta
meta, Text -> Measurable -> LOContent t
forall a. Text -> Measurable -> LOContent a
LogValue Text
"block replay progress (%)" (Double -> Measurable
PureD (Integer -> Double
forall a. Num a => Integer -> a
fromInteger (Double -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
round (Double
progress Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
10.0)) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
10.0)))
      (Maybe (WithSeverity (TraceEvent blk)), Integer)
-> IO (Maybe (WithSeverity (TraceEvent blk)), Integer)
forall (m :: * -> *) a. Monad m => a -> m a
return (WithSeverity (TraceEvent blk)
-> Maybe (WithSeverity (TraceEvent blk))
forall a. a -> Maybe a
Just WithSeverity (TraceEvent blk)
ev, Integer -> Integer
forall a. Num a => Integer -> a
fromInteger Integer
startslot)
  conteliding TracingVerbosity
_ Trace IO t
_ WithSeverity (TraceEvent blk)
_ (Maybe (WithSeverity (TraceEvent blk)), Integer)
_ = (Maybe (WithSeverity (TraceEvent blk)), Integer)
-> IO (Maybe (WithSeverity (TraceEvent blk)), Integer)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (WithSeverity (TraceEvent blk))
forall a. Maybe a
Nothing, Integer
0)

instance (StandardHash header, Eq peer) => ElidingTracer
  (WithSeverity [TraceLabelPeer peer (FetchDecision [Point header])]) where
  -- equivalent by type and severity
  isEquivalent :: WithSeverity [TraceLabelPeer peer (FetchDecision [Point header])]
-> WithSeverity
     [TraceLabelPeer peer (FetchDecision [Point header])]
-> Bool
isEquivalent (WithSeverity Severity
s1 [TraceLabelPeer peer (FetchDecision [Point header])]
_peers1)
               (WithSeverity Severity
s2 [TraceLabelPeer peer (FetchDecision [Point header])]
_peers2) = Severity
s1 Severity -> Severity -> Bool
forall a. Eq a => a -> a -> Bool
== Severity
s2
  -- the types to be elided
  doelide :: WithSeverity [TraceLabelPeer peer (FetchDecision [Point header])]
-> Bool
doelide (WithSeverity Severity
_ [TraceLabelPeer peer (FetchDecision [Point header])]
peers) =
    let checkDecision :: TraceLabelPeer peer (Either FetchDecline result) -> Bool
        checkDecision :: TraceLabelPeer peer (Either FetchDecline result) -> Bool
checkDecision (TraceLabelPeer peer
_peer (Left FetchDecline
FetchDeclineChainNotPlausible)) = Bool
True
        checkDecision (TraceLabelPeer peer
_peer (Left (FetchDeclineConcurrencyLimit FetchMode
_ Word
_))) = Bool
True
        checkDecision (TraceLabelPeer peer
_peer (Left (FetchDeclinePeerBusy SizeInBytes
_ SizeInBytes
_ SizeInBytes
_))) = Bool
True
        checkDecision TraceLabelPeer peer (Either FetchDecline result)
_ = Bool
False
    in (TraceLabelPeer peer (FetchDecision [Point header]) -> Bool)
-> [TraceLabelPeer peer (FetchDecision [Point header])] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any TraceLabelPeer peer (FetchDecision [Point header]) -> Bool
forall result.
TraceLabelPeer peer (Either FetchDecline result) -> Bool
checkDecision [TraceLabelPeer peer (FetchDecision [Point header])]
peers
  conteliding :: TracingVerbosity
-> Trace IO t
-> WithSeverity
     [TraceLabelPeer peer (FetchDecision [Point header])]
-> (Maybe
      (WithSeverity
         [TraceLabelPeer peer (FetchDecision [Point header])]),
    Integer)
-> IO
     (Maybe
        (WithSeverity
           [TraceLabelPeer peer (FetchDecision [Point header])]),
      Integer)
conteliding TracingVerbosity
_tverb Trace IO t
_tr WithSeverity [TraceLabelPeer peer (FetchDecision [Point header])]
_ (Maybe
  (WithSeverity [TraceLabelPeer peer (FetchDecision [Point header])])
Nothing, Integer
_count) = (Maybe
   (WithSeverity
      [TraceLabelPeer peer (FetchDecision [Point header])]),
 Integer)
-> IO
     (Maybe
        (WithSeverity
           [TraceLabelPeer peer (FetchDecision [Point header])]),
      Integer)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe
  (WithSeverity [TraceLabelPeer peer (FetchDecision [Point header])])
forall a. Maybe a
Nothing, Integer
0)
  conteliding TracingVerbosity
tverb Trace IO t
tr WithSeverity [TraceLabelPeer peer (FetchDecision [Point header])]
ev (Maybe
  (WithSeverity [TraceLabelPeer peer (FetchDecision [Point header])])
_old, Integer
count) = do
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Integer
count Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
0 Bool -> Bool -> Bool
&& Integer
count Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`mod` Integer
1000 Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$  -- report every 1000th message
          Tracer
  IO
  (WithSeverity [TraceLabelPeer peer (FetchDecision [Point header])])
-> WithSeverity
     [TraceLabelPeer peer (FetchDecision [Point header])]
-> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith (TracingVerbosity
-> Trace IO t
-> Tracer
     IO
     (WithSeverity [TraceLabelPeer peer (FetchDecision [Point header])])
forall (m :: * -> *) a b.
(ToLogObject m, ToObject a, Transformable a m b) =>
TracingVerbosity -> Trace m a -> Tracer m b
toLogObject' TracingVerbosity
tverb Trace IO t
tr) WithSeverity [TraceLabelPeer peer (FetchDecision [Point header])]
ev
      (Maybe
   (WithSeverity
      [TraceLabelPeer peer (FetchDecision [Point header])]),
 Integer)
-> IO
     (Maybe
        (WithSeverity
           [TraceLabelPeer peer (FetchDecision [Point header])]),
      Integer)
forall (m :: * -> *) a. Monad m => a -> m a
return (WithSeverity [TraceLabelPeer peer (FetchDecision [Point header])]
-> Maybe
     (WithSeverity [TraceLabelPeer peer (FetchDecision [Point header])])
forall a. a -> Maybe a
Just WithSeverity [TraceLabelPeer peer (FetchDecision [Point header])]
ev, Integer
count Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1)

-- | Tracers for all system components.
--
mkTracers
  :: forall peer localPeer blk.
     ( Consensus.RunNode blk
     , HasKESMetricsData blk
     , HasKESInfo blk
     , TraceConstraints blk
     , Show peer, Eq peer, ToObject peer
     , Show localPeer, ToObject localPeer
     )
  => BlockConfig blk
  -> TraceOptions
  -> Trace IO Text
  -> NodeKernelData blk
  -> Maybe EKGDirect
  -> IO (Tracers peer localPeer blk)
mkTracers :: BlockConfig blk
-> TraceOptions
-> Trace IO Text
-> NodeKernelData blk
-> Maybe EKGDirect
-> IO (Tracers peer localPeer blk)
mkTracers BlockConfig blk
blockConfig tOpts :: TraceOptions
tOpts@(TracingOn TraceSelection
trSel) Trace IO Text
tr NodeKernelData blk
nodeKern Maybe EKGDirect
ekgDirect = do
  ForgingStats
fStats <- IO ForgingStats
mkForgingStats
  Tracers' peer localPeer blk (Tracer IO)
consensusTracers <- Maybe EKGDirect
-> TraceSelection
-> TracingVerbosity
-> Trace IO Text
-> NodeKernelData blk
-> ForgingStats
-> IO (Tracers' peer localPeer blk (Tracer IO))
forall blk peer localPeer.
(Show peer, Eq peer, LedgerQueries blk, ToJSON (GenTxId blk),
 ToObject (ApplyTxErr blk), ToObject (CannotForge blk),
 ToObject (GenTx blk), ToObject (LedgerErr (LedgerState blk)),
 ToObject (OtherHeaderEnvelopeError blk),
 ToObject (ValidationErr (BlockProtocol blk)),
 ToObject (ForgeStateUpdateError blk), ToObject peer, RunNode blk,
 HasKESMetricsData blk, HasKESInfo blk, Show (Header blk)) =>
Maybe EKGDirect
-> TraceSelection
-> TracingVerbosity
-> Trace IO Text
-> NodeKernelData blk
-> ForgingStats
-> IO (Tracers' peer localPeer blk (Tracer IO))
mkConsensusTracers Maybe EKGDirect
ekgDirect TraceSelection
trSel TracingVerbosity
verb Trace IO Text
tr NodeKernelData blk
nodeKern ForgingStats
fStats
  MVar (Maybe (WithSeverity (TraceEvent blk)), Integer)
elidedChainDB <- IO (MVar (Maybe (WithSeverity (TraceEvent blk)), Integer))
forall a. ElidingTracer a => IO (MVar (Maybe a, Integer))
newstate  -- for eliding messages in ChainDB tracer

  Tracers peer localPeer blk -> IO (Tracers peer localPeer blk)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Tracers :: forall peer localPeer blk.
Tracer IO (TraceEvent blk)
-> Tracers IO peer localPeer blk
-> Tracers IO peer blk DeserialiseFailure
-> Tracers IO localPeer blk DeserialiseFailure
-> Tracer IO (WithIPList (SubscriptionTrace SockAddr))
-> Tracer IO (WithDomainName (SubscriptionTrace SockAddr))
-> Tracer IO (WithDomainName DnsTrace)
-> Tracer IO (WithAddr SockAddr ErrorPolicyTrace)
-> Tracer IO (WithAddr LocalAddress ErrorPolicyTrace)
-> Tracer IO AcceptConnectionsPolicyTrace
-> Tracer IO (WithMuxBearer peer MuxTrace)
-> Tracer IO (WithMuxBearer localPeer MuxTrace)
-> Tracer IO HandshakeTr
-> Tracer IO HandshakeTr
-> Tracer IO DiffusionInitializationTracer
-> Tracers peer localPeer blk
Tracers
    { chainDBTracer :: Tracer IO (TraceEvent blk)
chainDBTracer = OnOff TraceChainDB
-> Tracer IO (TraceEvent blk) -> Tracer IO (TraceEvent blk)
forall (b :: Symbol) a. OnOff b -> Tracer IO a -> Tracer IO a
tracerOnOff' (TraceSelection -> OnOff TraceChainDB
traceChainDB TraceSelection
trSel) (Tracer IO (TraceEvent blk) -> Tracer IO (TraceEvent blk))
-> Tracer IO (TraceEvent blk) -> Tracer IO (TraceEvent blk)
forall a b. (a -> b) -> a -> b
$
        Tracer IO (WithSeverity (TraceEvent blk))
-> Tracer IO (TraceEvent blk)
forall a (m :: * -> *).
HasSeverityAnnotation a =>
Tracer m (WithSeverity a) -> Tracer m a
annotateSeverity (Tracer IO (WithSeverity (TraceEvent blk))
 -> Tracer IO (TraceEvent blk))
-> Tracer IO (WithSeverity (TraceEvent blk))
-> Tracer IO (TraceEvent blk)
forall a b. (a -> b) -> a -> b
$ BlockConfig blk
-> ForgingStats
-> TraceOptions
-> MVar (Maybe (WithSeverity (TraceEvent blk)), Integer)
-> Maybe EKGDirect
-> Trace IO Text
-> Trace IO Text
-> Tracer IO (WithSeverity (TraceEvent blk))
forall blk.
(ConvertRawHash blk, LedgerSupportsProtocol blk, InspectLedger blk,
 ToObject (Header blk), ToObject (LedgerEvent blk)) =>
BlockConfig blk
-> ForgingStats
-> TraceOptions
-> MVar (Maybe (WithSeverity (TraceEvent blk)), Integer)
-> Maybe EKGDirect
-> Trace IO Text
-> Trace IO Text
-> Tracer IO (WithSeverity (TraceEvent blk))
teeTraceChainTip
                             BlockConfig blk
blockConfig
                             ForgingStats
fStats
                             TraceOptions
tOpts MVar (Maybe (WithSeverity (TraceEvent blk)), Integer)
elidedChainDB
                             Maybe EKGDirect
ekgDirect
                             (Text -> Trace IO Text -> Trace IO Text
forall (m :: * -> *) a. Text -> Trace m a -> Trace m a
appendName Text
"ChainDB" Trace IO Text
tr)
                             (Text -> Trace IO Text -> Trace IO Text
forall (m :: * -> *) a. Text -> Trace m a -> Trace m a
appendName Text
"metrics" Trace IO Text
tr)
    , consensusTracers :: Tracers' peer localPeer blk (Tracer IO)
consensusTracers = Tracers' peer localPeer blk (Tracer IO)
consensusTracers
    , nodeToClientTracers :: Tracers IO localPeer blk DeserialiseFailure
nodeToClientTracers = TraceSelection
-> TracingVerbosity
-> Trace IO Text
-> Tracers IO localPeer blk DeserialiseFailure
forall blk localPeer.
(StandardHash blk, Show (ApplyTxErr blk), Show (GenTx blk),
 Show localPeer, ToObject localPeer, ShowQuery (Query blk)) =>
TraceSelection
-> TracingVerbosity
-> Trace IO Text
-> Tracers' localPeer blk DeserialiseFailure (Tracer IO)
nodeToClientTracers' TraceSelection
trSel TracingVerbosity
verb Trace IO Text
tr
    , nodeToNodeTracers :: Tracers IO peer blk DeserialiseFailure
nodeToNodeTracers = TraceSelection
-> TracingVerbosity
-> Trace IO Text
-> Tracers IO peer blk DeserialiseFailure
forall blk peer.
(RunNode blk, ConvertTxId blk, HasTxs blk, Show blk,
 Show (Header blk), Show peer, ToObject peer) =>
TraceSelection
-> TracingVerbosity
-> Trace IO Text
-> Tracers' peer blk DeserialiseFailure (Tracer IO)
nodeToNodeTracers' TraceSelection
trSel TracingVerbosity
verb Trace IO Text
tr
    , ipSubscriptionTracer :: Tracer IO (WithIPList (SubscriptionTrace SockAddr))
ipSubscriptionTracer = OnOff TraceIpSubscription
-> TracingVerbosity
-> Text
-> Trace IO Text
-> Tracer IO (WithIPList (SubscriptionTrace SockAddr))
forall a (b :: Symbol).
Transformable Text IO a =>
OnOff b -> TracingVerbosity -> Text -> Trace IO Text -> Tracer IO a
tracerOnOff (TraceSelection -> OnOff TraceIpSubscription
traceIpSubscription TraceSelection
trSel) TracingVerbosity
verb Text
"IpSubscription" Trace IO Text
tr
    , dnsSubscriptionTracer :: Tracer IO (WithDomainName (SubscriptionTrace SockAddr))
dnsSubscriptionTracer =  OnOff TraceDnsSubscription
-> TracingVerbosity
-> Text
-> Trace IO Text
-> Tracer IO (WithDomainName (SubscriptionTrace SockAddr))
forall a (b :: Symbol).
Transformable Text IO a =>
OnOff b -> TracingVerbosity -> Text -> Trace IO Text -> Tracer IO a
tracerOnOff (TraceSelection -> OnOff TraceDnsSubscription
traceDnsSubscription TraceSelection
trSel) TracingVerbosity
verb Text
"DnsSubscription" Trace IO Text
tr
    , dnsResolverTracer :: Tracer IO (WithDomainName DnsTrace)
dnsResolverTracer = OnOff TraceDnsResolver
-> TracingVerbosity
-> Text
-> Trace IO Text
-> Tracer IO (WithDomainName DnsTrace)
forall a (b :: Symbol).
Transformable Text IO a =>
OnOff b -> TracingVerbosity -> Text -> Trace IO Text -> Tracer IO a
tracerOnOff (TraceSelection -> OnOff TraceDnsResolver
traceDnsResolver TraceSelection
trSel) TracingVerbosity
verb Text
"DnsResolver" Trace IO Text
tr
    , errorPolicyTracer :: Tracer IO (WithAddr SockAddr ErrorPolicyTrace)
errorPolicyTracer = OnOff TraceErrorPolicy
-> TracingVerbosity
-> Text
-> Trace IO Text
-> Tracer IO (WithAddr SockAddr ErrorPolicyTrace)
forall a (b :: Symbol).
Transformable Text IO a =>
OnOff b -> TracingVerbosity -> Text -> Trace IO Text -> Tracer IO a
tracerOnOff (TraceSelection -> OnOff TraceErrorPolicy
traceErrorPolicy TraceSelection
trSel) TracingVerbosity
verb Text
"ErrorPolicy" Trace IO Text
tr
    , localErrorPolicyTracer :: Tracer IO (WithAddr LocalAddress ErrorPolicyTrace)
localErrorPolicyTracer = OnOff TraceLocalErrorPolicy
-> TracingVerbosity
-> Text
-> Trace IO Text
-> Tracer IO (WithAddr LocalAddress ErrorPolicyTrace)
forall a (b :: Symbol).
Transformable Text IO a =>
OnOff b -> TracingVerbosity -> Text -> Trace IO Text -> Tracer IO a
tracerOnOff (TraceSelection -> OnOff TraceLocalErrorPolicy
traceLocalErrorPolicy TraceSelection
trSel) TracingVerbosity
verb Text
"LocalErrorPolicy" Trace IO Text
tr
    , acceptPolicyTracer :: Tracer IO AcceptConnectionsPolicyTrace
acceptPolicyTracer = OnOff TraceAcceptPolicy
-> TracingVerbosity
-> Text
-> Trace IO Text
-> Tracer IO AcceptConnectionsPolicyTrace
forall a (b :: Symbol).
Transformable Text IO a =>
OnOff b -> TracingVerbosity -> Text -> Trace IO Text -> Tracer IO a
tracerOnOff (TraceSelection -> OnOff TraceAcceptPolicy
traceAcceptPolicy TraceSelection
trSel) TracingVerbosity
verb Text
"AcceptPolicy" Trace IO Text
tr
    , muxTracer :: Tracer IO (WithMuxBearer peer MuxTrace)
muxTracer = OnOff TraceMux
-> TracingVerbosity
-> Text
-> Trace IO Text
-> Tracer IO (WithMuxBearer peer MuxTrace)
forall a (b :: Symbol).
Transformable Text IO a =>
OnOff b -> TracingVerbosity -> Text -> Trace IO Text -> Tracer IO a
tracerOnOff (TraceSelection -> OnOff TraceMux
traceMux TraceSelection
trSel) TracingVerbosity
verb Text
"Mux" Trace IO Text
tr
    , muxLocalTracer :: Tracer IO (WithMuxBearer localPeer MuxTrace)
muxLocalTracer = OnOff TraceLocalMux
-> TracingVerbosity
-> Text
-> Trace IO Text
-> Tracer IO (WithMuxBearer localPeer MuxTrace)
forall a (b :: Symbol).
Transformable Text IO a =>
OnOff b -> TracingVerbosity -> Text -> Trace IO Text -> Tracer IO a
tracerOnOff (TraceSelection -> OnOff TraceLocalMux
traceLocalMux TraceSelection
trSel) TracingVerbosity
verb Text
"MuxLocal" Trace IO Text
tr
    , handshakeTracer :: Tracer IO HandshakeTr
handshakeTracer = OnOff TraceHandshake
-> TracingVerbosity
-> Text
-> Trace IO Text
-> Tracer IO HandshakeTr
forall a (b :: Symbol).
Transformable Text IO a =>
OnOff b -> TracingVerbosity -> Text -> Trace IO Text -> Tracer IO a
tracerOnOff (TraceSelection -> OnOff TraceHandshake
traceHandshake TraceSelection
trSel) TracingVerbosity
verb Text
"Handshake" Trace IO Text
tr
    , localHandshakeTracer :: Tracer IO HandshakeTr
localHandshakeTracer = OnOff TraceLocalHandshake
-> TracingVerbosity
-> Text
-> Trace IO Text
-> Tracer IO HandshakeTr
forall a (b :: Symbol).
Transformable Text IO a =>
OnOff b -> TracingVerbosity -> Text -> Trace IO Text -> Tracer IO a
tracerOnOff (TraceSelection -> OnOff TraceLocalHandshake
traceLocalHandshake TraceSelection
trSel) TracingVerbosity
verb Text
"LocalHandshake" Trace IO Text
tr
    , diffusionInitializationTracer :: Tracer IO DiffusionInitializationTracer
diffusionInitializationTracer = OnOff TraceDiffusionInitialization
-> TracingVerbosity
-> Text
-> Trace IO Text
-> Tracer IO DiffusionInitializationTracer
forall a (b :: Symbol).
Transformable Text IO a =>
OnOff b -> TracingVerbosity -> Text -> Trace IO Text -> Tracer IO a
tracerOnOff (TraceSelection -> OnOff TraceDiffusionInitialization
traceDiffusionInitialization TraceSelection
trSel) TracingVerbosity
verb Text
"DiffusionInitializationTracer" Trace IO Text
tr
    }
 where
   verb :: TracingVerbosity
   verb :: TracingVerbosity
verb = TraceSelection -> TracingVerbosity
traceVerbosity TraceSelection
trSel

mkTracers BlockConfig blk
_ TraceOptions
TracingOff Trace IO Text
_ NodeKernelData blk
_ Maybe EKGDirect
_ =
  Tracers peer localPeer blk -> IO (Tracers peer localPeer blk)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Tracers :: forall peer localPeer blk.
Tracer IO (TraceEvent blk)
-> Tracers IO peer localPeer blk
-> Tracers IO peer blk DeserialiseFailure
-> Tracers IO localPeer blk DeserialiseFailure
-> Tracer IO (WithIPList (SubscriptionTrace SockAddr))
-> Tracer IO (WithDomainName (SubscriptionTrace SockAddr))
-> Tracer IO (WithDomainName DnsTrace)
-> Tracer IO (WithAddr SockAddr ErrorPolicyTrace)
-> Tracer IO (WithAddr LocalAddress ErrorPolicyTrace)
-> Tracer IO AcceptConnectionsPolicyTrace
-> Tracer IO (WithMuxBearer peer MuxTrace)
-> Tracer IO (WithMuxBearer localPeer MuxTrace)
-> Tracer IO HandshakeTr
-> Tracer IO HandshakeTr
-> Tracer IO DiffusionInitializationTracer
-> Tracers peer localPeer blk
Tracers
    { chainDBTracer :: Tracer IO (TraceEvent blk)
chainDBTracer = Tracer IO (TraceEvent blk)
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
    , consensusTracers :: Tracers' peer localPeer blk (Tracer IO)
consensusTracers = Tracers :: forall remotePeer localPeer blk (f :: * -> *).
f (TraceLabelPeer remotePeer (TraceChainSyncClientEvent blk))
-> f (TraceChainSyncServerEvent blk)
-> f (TraceChainSyncServerEvent blk)
-> f [TraceLabelPeer
        remotePeer (FetchDecision [Point (Header blk)])]
-> f (TraceLabelPeer
        remotePeer (TraceFetchClientState (Header blk)))
-> f (TraceBlockFetchServerEvent blk)
-> f (TraceLabelPeer
        remotePeer (TraceTxSubmissionInbound (GenTxId blk) (GenTx blk)))
-> f (TraceLabelPeer
        remotePeer (TraceTxSubmissionOutbound (GenTxId blk) (GenTx blk)))
-> f (TraceLocalTxSubmissionServerEvent blk)
-> f (TraceEventMempool blk)
-> f (TraceLabelCreds (TraceForgeEvent blk))
-> f (TraceBlockchainTimeEvent UTCTime)
-> f (TraceLabelCreds (ForgeStateInfo blk))
-> f (TraceKeepAliveClient remotePeer)
-> Tracers' remotePeer localPeer blk f
Consensus.Tracers
      { chainSyncClientTracer :: Tracer IO (TraceLabelPeer peer (TraceChainSyncClientEvent blk))
Consensus.chainSyncClientTracer = Tracer IO (TraceLabelPeer peer (TraceChainSyncClientEvent blk))
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
      , chainSyncServerHeaderTracer :: Tracer IO (TraceChainSyncServerEvent blk)
Consensus.chainSyncServerHeaderTracer = Tracer IO (TraceChainSyncServerEvent blk)
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
      , chainSyncServerBlockTracer :: Tracer IO (TraceChainSyncServerEvent blk)
Consensus.chainSyncServerBlockTracer = Tracer IO (TraceChainSyncServerEvent blk)
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
      , blockFetchDecisionTracer :: Tracer
  IO [TraceLabelPeer peer (FetchDecision [Point (Header blk)])]
Consensus.blockFetchDecisionTracer = Tracer
  IO [TraceLabelPeer peer (FetchDecision [Point (Header blk)])]
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
      , blockFetchClientTracer :: Tracer
  IO (TraceLabelPeer peer (TraceFetchClientState (Header blk)))
Consensus.blockFetchClientTracer = Tracer
  IO (TraceLabelPeer peer (TraceFetchClientState (Header blk)))
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
      , blockFetchServerTracer :: Tracer IO (TraceBlockFetchServerEvent blk)
Consensus.blockFetchServerTracer = Tracer IO (TraceBlockFetchServerEvent blk)
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
      , forgeStateInfoTracer :: Tracer IO (TraceLabelCreds (ForgeStateInfo blk))
Consensus.forgeStateInfoTracer = Tracer IO (TraceLabelCreds (ForgeStateInfo blk))
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
      , txInboundTracer :: Tracer
  IO
  (TraceLabelPeer
     peer (TraceTxSubmissionInbound (GenTxId blk) (GenTx blk)))
Consensus.txInboundTracer = Tracer
  IO
  (TraceLabelPeer
     peer (TraceTxSubmissionInbound (GenTxId blk) (GenTx blk)))
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
      , txOutboundTracer :: Tracer
  IO
  (TraceLabelPeer
     peer (TraceTxSubmissionOutbound (GenTxId blk) (GenTx blk)))
Consensus.txOutboundTracer = Tracer
  IO
  (TraceLabelPeer
     peer (TraceTxSubmissionOutbound (GenTxId blk) (GenTx blk)))
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
      , localTxSubmissionServerTracer :: Tracer IO (TraceLocalTxSubmissionServerEvent blk)
Consensus.localTxSubmissionServerTracer = Tracer IO (TraceLocalTxSubmissionServerEvent blk)
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
      , mempoolTracer :: Tracer IO (TraceEventMempool blk)
Consensus.mempoolTracer = Tracer IO (TraceEventMempool blk)
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
      , forgeTracer :: Tracer IO (TraceLabelCreds (TraceForgeEvent blk))
Consensus.forgeTracer = Tracer IO (TraceLabelCreds (TraceForgeEvent blk))
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
      , blockchainTimeTracer :: Tracer IO (TraceBlockchainTimeEvent UTCTime)
Consensus.blockchainTimeTracer = Tracer IO (TraceBlockchainTimeEvent UTCTime)
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
      , keepAliveClientTracer :: Tracer IO (TraceKeepAliveClient peer)
Consensus.keepAliveClientTracer = Tracer IO (TraceKeepAliveClient peer)
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
      }
    , nodeToClientTracers :: Tracers IO localPeer blk DeserialiseFailure
nodeToClientTracers = Tracers :: forall peer blk e (f :: * -> *).
f (TraceLabelPeer
     peer
     (TraceSendRecv (ChainSync (Serialised blk) (Point blk) (Tip blk))))
-> f (TraceLabelPeer
        peer
        (TraceSendRecv (LocalTxSubmission (GenTx blk) (ApplyTxErr blk))))
-> f (TraceLabelPeer
        peer (TraceSendRecv (LocalStateQuery blk (Point blk) (Query blk))))
-> Tracers' peer blk e f
NodeToClient.Tracers
      { tChainSyncTracer :: Tracer
  IO
  (TraceLabelPeer
     localPeer
     (TraceSendRecv (ChainSync (Serialised blk) (Point blk) (Tip blk))))
NodeToClient.tChainSyncTracer = Tracer
  IO
  (TraceLabelPeer
     localPeer
     (TraceSendRecv (ChainSync (Serialised blk) (Point blk) (Tip blk))))
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
      , tTxSubmissionTracer :: Tracer
  IO
  (TraceLabelPeer
     localPeer
     (TraceSendRecv (LocalTxSubmission (GenTx blk) (ApplyTxErr blk))))
NodeToClient.tTxSubmissionTracer = Tracer
  IO
  (TraceLabelPeer
     localPeer
     (TraceSendRecv (LocalTxSubmission (GenTx blk) (ApplyTxErr blk))))
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
      , tStateQueryTracer :: Tracer
  IO
  (TraceLabelPeer
     localPeer
     (TraceSendRecv (LocalStateQuery blk (Point blk) (Query blk))))
NodeToClient.tStateQueryTracer = Tracer
  IO
  (TraceLabelPeer
     localPeer
     (TraceSendRecv (LocalStateQuery blk (Point blk) (Query blk))))
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
      }
    , nodeToNodeTracers :: Tracers IO peer blk DeserialiseFailure
nodeToNodeTracers = Tracers :: forall peer blk e (f :: * -> *).
f (TraceLabelPeer
     peer
     (TraceSendRecv (ChainSync (Header blk) (Point blk) (Tip blk))))
-> f (TraceLabelPeer
        peer
        (TraceSendRecv
           (ChainSync (SerialisedHeader blk) (Point blk) (Tip blk))))
-> f (TraceLabelPeer
        peer (TraceSendRecv (BlockFetch blk (Point blk))))
-> f (TraceLabelPeer
        peer (TraceSendRecv (BlockFetch (Serialised blk) (Point blk))))
-> f (TraceLabelPeer
        peer (TraceSendRecv (TxSubmission (GenTxId blk) (GenTx blk))))
-> f (TraceLabelPeer
        peer (TraceSendRecv (TxSubmission2 (GenTxId blk) (GenTx blk))))
-> Tracers' peer blk e f
NodeToNode.Tracers
      { tChainSyncTracer :: Tracer
  IO
  (TraceLabelPeer
     peer
     (TraceSendRecv (ChainSync (Header blk) (Point blk) (Tip blk))))
NodeToNode.tChainSyncTracer = Tracer
  IO
  (TraceLabelPeer
     peer
     (TraceSendRecv (ChainSync (Header blk) (Point blk) (Tip blk))))
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
      , tChainSyncSerialisedTracer :: Tracer
  IO
  (TraceLabelPeer
     peer
     (TraceSendRecv
        (ChainSync (SerialisedHeader blk) (Point blk) (Tip blk))))
NodeToNode.tChainSyncSerialisedTracer = Tracer
  IO
  (TraceLabelPeer
     peer
     (TraceSendRecv
        (ChainSync (SerialisedHeader blk) (Point blk) (Tip blk))))
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
      , tBlockFetchTracer :: Tracer
  IO
  (TraceLabelPeer peer (TraceSendRecv (BlockFetch blk (Point blk))))
NodeToNode.tBlockFetchTracer = Tracer
  IO
  (TraceLabelPeer peer (TraceSendRecv (BlockFetch blk (Point blk))))
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
      , tBlockFetchSerialisedTracer :: Tracer
  IO
  (TraceLabelPeer
     peer (TraceSendRecv (BlockFetch (Serialised blk) (Point blk))))
NodeToNode.tBlockFetchSerialisedTracer = Tracer
  IO
  (TraceLabelPeer
     peer (TraceSendRecv (BlockFetch (Serialised blk) (Point blk))))
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
      , tTxSubmissionTracer :: Tracer
  IO
  (TraceLabelPeer
     peer (TraceSendRecv (TxSubmission (GenTxId blk) (GenTx blk))))
NodeToNode.tTxSubmissionTracer = Tracer
  IO
  (TraceLabelPeer
     peer (TraceSendRecv (TxSubmission (GenTxId blk) (GenTx blk))))
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
      , tTxSubmission2Tracer :: Tracer
  IO
  (TraceLabelPeer
     peer (TraceSendRecv (TxSubmission2 (GenTxId blk) (GenTx blk))))
NodeToNode.tTxSubmission2Tracer = Tracer
  IO
  (TraceLabelPeer
     peer (TraceSendRecv (TxSubmission2 (GenTxId blk) (GenTx blk))))
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
      }
    , ipSubscriptionTracer :: Tracer IO (WithIPList (SubscriptionTrace SockAddr))
ipSubscriptionTracer = Tracer IO (WithIPList (SubscriptionTrace SockAddr))
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
    , dnsSubscriptionTracer :: Tracer IO (WithDomainName (SubscriptionTrace SockAddr))
dnsSubscriptionTracer= Tracer IO (WithDomainName (SubscriptionTrace SockAddr))
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
    , dnsResolverTracer :: Tracer IO (WithDomainName DnsTrace)
dnsResolverTracer = Tracer IO (WithDomainName DnsTrace)
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
    , errorPolicyTracer :: Tracer IO (WithAddr SockAddr ErrorPolicyTrace)
errorPolicyTracer = Tracer IO (WithAddr SockAddr ErrorPolicyTrace)
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
    , localErrorPolicyTracer :: Tracer IO (WithAddr LocalAddress ErrorPolicyTrace)
localErrorPolicyTracer = Tracer IO (WithAddr LocalAddress ErrorPolicyTrace)
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
    , acceptPolicyTracer :: Tracer IO AcceptConnectionsPolicyTrace
acceptPolicyTracer = Tracer IO AcceptConnectionsPolicyTrace
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
    , muxTracer :: Tracer IO (WithMuxBearer peer MuxTrace)
muxTracer = Tracer IO (WithMuxBearer peer MuxTrace)
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
    , muxLocalTracer :: Tracer IO (WithMuxBearer localPeer MuxTrace)
muxLocalTracer = Tracer IO (WithMuxBearer localPeer MuxTrace)
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
    , handshakeTracer :: Tracer IO HandshakeTr
handshakeTracer = Tracer IO HandshakeTr
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
    , localHandshakeTracer :: Tracer IO HandshakeTr
localHandshakeTracer = Tracer IO HandshakeTr
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
    , diffusionInitializationTracer :: Tracer IO DiffusionInitializationTracer
diffusionInitializationTracer = Tracer IO DiffusionInitializationTracer
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
    }

--------------------------------------------------------------------------------
-- Chain DB Tracers
--------------------------------------------------------------------------------

teeTraceChainTip
  :: ( ConvertRawHash blk
     , LedgerSupportsProtocol blk
     , InspectLedger blk
     , ToObject (Header blk)
     , ToObject (LedgerEvent blk)
     )
  => BlockConfig blk
  -> ForgingStats
  -> TraceOptions
  -> MVar (Maybe (WithSeverity (ChainDB.TraceEvent blk)), Integer)
  -> Maybe EKGDirect
  -> Trace IO Text
  -> Trace IO Text
  -> Tracer IO (WithSeverity (ChainDB.TraceEvent blk))
teeTraceChainTip :: BlockConfig blk
-> ForgingStats
-> TraceOptions
-> MVar (Maybe (WithSeverity (TraceEvent blk)), Integer)
-> Maybe EKGDirect
-> Trace IO Text
-> Trace IO Text
-> Tracer IO (WithSeverity (TraceEvent blk))
teeTraceChainTip BlockConfig blk
_ ForgingStats
_ TraceOptions
TracingOff MVar (Maybe (WithSeverity (TraceEvent blk)), Integer)
_ Maybe EKGDirect
_ Trace IO Text
_ Trace IO Text
_ = Tracer IO (WithSeverity (TraceEvent blk))
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
teeTraceChainTip BlockConfig blk
blockConfig ForgingStats
fStats (TracingOn TraceSelection
trSel) MVar (Maybe (WithSeverity (TraceEvent blk)), Integer)
elided Maybe EKGDirect
ekgDirect Trace IO Text
trTrc Trace IO Text
trMet =
  (WithSeverity (TraceEvent blk) -> IO ())
-> Tracer IO (WithSeverity (TraceEvent blk))
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer ((WithSeverity (TraceEvent blk) -> IO ())
 -> Tracer IO (WithSeverity (TraceEvent blk)))
-> (WithSeverity (TraceEvent blk) -> IO ())
-> Tracer IO (WithSeverity (TraceEvent blk))
forall a b. (a -> b) -> a -> b
$ \WithSeverity (TraceEvent blk)
ev -> do
    Tracer IO (WithSeverity (TraceEvent blk))
-> WithSeverity (TraceEvent blk) -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith (TracingVerbosity
-> MVar (Maybe (WithSeverity (TraceEvent blk)), Integer)
-> Trace IO Text
-> Tracer IO (WithSeverity (TraceEvent blk))
forall blk.
(ConvertRawHash blk, LedgerSupportsProtocol blk, InspectLedger blk,
 ToObject (Header blk), ToObject (LedgerEvent blk)) =>
TracingVerbosity
-> MVar (Maybe (WithSeverity (TraceEvent blk)), Integer)
-> Trace IO Text
-> Tracer IO (WithSeverity (TraceEvent blk))
teeTraceChainTipElide (TraceSelection -> TracingVerbosity
traceVerbosity TraceSelection
trSel) MVar (Maybe (WithSeverity (TraceEvent blk)), Integer)
elided Trace IO Text
trTrc) WithSeverity (TraceEvent blk)
ev
    Tracer IO (WithSeverity (TraceEvent blk))
-> WithSeverity (TraceEvent blk) -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith (Tracer IO (TraceEvent blk)
-> Tracer IO (WithSeverity (TraceEvent blk))
forall a. Tracer IO a -> Tracer IO (WithSeverity a)
ignoringSeverity (Maybe EKGDirect
-> BlockConfig blk
-> ForgingStats
-> Trace IO Text
-> Tracer IO (TraceEvent blk)
forall blk.
HasHeader (Header blk) =>
Maybe EKGDirect
-> BlockConfig blk
-> ForgingStats
-> Trace IO Text
-> Tracer IO (TraceEvent blk)
traceChainMetrics Maybe EKGDirect
ekgDirect BlockConfig blk
blockConfig ForgingStats
fStats Trace IO Text
trMet)) WithSeverity (TraceEvent blk)
ev

teeTraceChainTipElide
  :: ( ConvertRawHash blk
     , LedgerSupportsProtocol blk
     , InspectLedger blk
     , ToObject (Header blk)
     , ToObject (LedgerEvent blk)
     )
  => TracingVerbosity
  -> MVar (Maybe (WithSeverity (ChainDB.TraceEvent blk)), Integer)
  -> Trace IO Text
  -> Tracer IO (WithSeverity (ChainDB.TraceEvent blk))
teeTraceChainTipElide :: TracingVerbosity
-> MVar (Maybe (WithSeverity (TraceEvent blk)), Integer)
-> Trace IO Text
-> Tracer IO (WithSeverity (TraceEvent blk))
teeTraceChainTipElide = TracingVerbosity
-> MVar (Maybe (WithSeverity (TraceEvent blk)), Integer)
-> Trace IO Text
-> Tracer IO (WithSeverity (TraceEvent blk))
forall a t.
(ElidingTracer a, ToObject t, Transformable t IO a) =>
TracingVerbosity
-> MVar (Maybe a, Integer) -> Trace IO t -> Tracer IO a
elideToLogObject
{-# INLINE teeTraceChainTipElide #-}

ignoringSeverity :: Tracer IO a -> Tracer IO (WithSeverity a)
ignoringSeverity :: Tracer IO a -> Tracer IO (WithSeverity a)
ignoringSeverity Tracer IO a
tr = (WithSeverity a -> IO ()) -> Tracer IO (WithSeverity a)
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer ((WithSeverity a -> IO ()) -> Tracer IO (WithSeverity a))
-> (WithSeverity a -> IO ()) -> Tracer IO (WithSeverity a)
forall a b. (a -> b) -> a -> b
$ \(WithSeverity Severity
_ a
ev) -> Tracer IO a -> a -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO a
tr a
ev
{-# INLINE ignoringSeverity #-}

traceChainMetrics
  :: forall blk. ()
  => HasHeader (Header blk)
  => Maybe EKGDirect
  -> BlockConfig blk
  -> ForgingStats
  -> Trace IO Text
  -> Tracer IO (ChainDB.TraceEvent blk)
traceChainMetrics :: Maybe EKGDirect
-> BlockConfig blk
-> ForgingStats
-> Trace IO Text
-> Tracer IO (TraceEvent blk)
traceChainMetrics Maybe EKGDirect
Nothing BlockConfig blk
_ ForgingStats
_ Trace IO Text
_ = Tracer IO (TraceEvent blk)
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
traceChainMetrics (Just EKGDirect
_ekgDirect) BlockConfig blk
_blockConfig ForgingStats
_fStats Trace IO Text
tr = do
  (TraceEvent blk -> IO ()) -> Tracer IO (TraceEvent blk)
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer ((TraceEvent blk -> IO ()) -> Tracer IO (TraceEvent blk))
-> (TraceEvent blk -> IO ()) -> Tracer IO (TraceEvent blk)
forall a b. (a -> b) -> a -> b
$ \TraceEvent blk
ev ->
    IO () -> Maybe (IO ()) -> IO ()
forall a. a -> Maybe a -> a
fromMaybe (() -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (Maybe (IO ()) -> IO ()) -> Maybe (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ ChainInformation -> IO ()
doTrace (ChainInformation -> IO ())
-> Maybe ChainInformation -> Maybe (IO ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TraceEvent blk -> Maybe ChainInformation
chainTipInformation TraceEvent blk
ev
  where
    chainTipInformation :: ChainDB.TraceEvent blk -> Maybe ChainInformation
    chainTipInformation :: TraceEvent blk -> Maybe ChainInformation
chainTipInformation = \case
      ChainDB.TraceAddBlockEvent TraceAddBlockEvent blk
ev -> case TraceAddBlockEvent blk
ev of
        ChainDB.SwitchedToAFork [LedgerEvent blk]
_warnings NewTipInfo blk
newTipInfo AnchoredFragment (Header blk)
_oldChain AnchoredFragment (Header blk)
newChain ->
          ChainInformation -> Maybe ChainInformation
forall a. a -> Maybe a
Just (ChainInformation -> Maybe ChainInformation)
-> ChainInformation -> Maybe ChainInformation
forall a b. (a -> b) -> a -> b
$ NewTipInfo blk
-> AnchoredFragment (Header blk) -> Int64 -> ChainInformation
forall blk.
HasHeader (Header blk) =>
NewTipInfo blk
-> AnchoredFragment (Header blk) -> Int64 -> ChainInformation
chainInformation NewTipInfo blk
newTipInfo AnchoredFragment (Header blk)
newChain Int64
0
        ChainDB.AddedToCurrentChain [LedgerEvent blk]
_warnings NewTipInfo blk
newTipInfo AnchoredFragment (Header blk)
_oldChain AnchoredFragment (Header blk)
newChain ->
          ChainInformation -> Maybe ChainInformation
forall a. a -> Maybe a
Just (ChainInformation -> Maybe ChainInformation)
-> ChainInformation -> Maybe ChainInformation
forall a b. (a -> b) -> a -> b
$ NewTipInfo blk
-> AnchoredFragment (Header blk) -> Int64 -> ChainInformation
forall blk.
HasHeader (Header blk) =>
NewTipInfo blk
-> AnchoredFragment (Header blk) -> Int64 -> ChainInformation
chainInformation NewTipInfo blk
newTipInfo AnchoredFragment (Header blk)
newChain Int64
0
        TraceAddBlockEvent blk
_ -> Maybe ChainInformation
forall a. Maybe a
Nothing
      TraceEvent blk
_ -> Maybe ChainInformation
forall a. Maybe a
Nothing
    doTrace :: ChainInformation -> IO ()

    doTrace :: ChainInformation -> IO ()
doTrace
        ChainInformation { Word64
slots :: ChainInformation -> Word64
slots :: Word64
slots, Word64
blocks :: ChainInformation -> Word64
blocks :: Word64
blocks, Rational
density :: ChainInformation -> Rational
density :: Rational
density, EpochNo
epoch :: ChainInformation -> EpochNo
epoch :: EpochNo
epoch, Word64
slotInEpoch :: ChainInformation -> Word64
slotInEpoch :: Word64
slotInEpoch } = do
      -- TODO this is executed each time the newFhain changes. How cheap is it?
      LOMeta
meta <- Severity -> PrivacyAnnotation -> IO LOMeta
forall (m :: * -> *).
MonadIO m =>
Severity -> PrivacyAnnotation -> m LOMeta
mkLOMeta Severity
Critical PrivacyAnnotation
Public

      Trace IO Text -> LOMeta -> Text -> Double -> IO ()
forall a. Trace IO a -> LOMeta -> Text -> Double -> IO ()
traceD Trace IO Text
tr LOMeta
meta Text
"density"     (Rational -> Double
forall a. Fractional a => Rational -> a
fromRational Rational
density)
      Trace IO Text -> LOMeta -> Text -> Word64 -> IO ()
forall i a.
Integral i =>
Trace IO a -> LOMeta -> Text -> i -> IO ()
traceI Trace IO Text
tr LOMeta
meta Text
"slotNum"     Word64
slots
      Trace IO Text -> LOMeta -> Text -> Word64 -> IO ()
forall i a.
Integral i =>
Trace IO a -> LOMeta -> Text -> i -> IO ()
traceI Trace IO Text
tr LOMeta
meta Text
"blockNum"    Word64
blocks
      Trace IO Text -> LOMeta -> Text -> Word64 -> IO ()
forall i a.
Integral i =>
Trace IO a -> LOMeta -> Text -> i -> IO ()
traceI Trace IO Text
tr LOMeta
meta Text
"slotInEpoch" Word64
slotInEpoch
      Trace IO Text -> LOMeta -> Text -> Word64 -> IO ()
forall i a.
Integral i =>
Trace IO a -> LOMeta -> Text -> i -> IO ()
traceI Trace IO Text
tr LOMeta
meta Text
"epoch"       (EpochNo -> Word64
unEpochNo EpochNo
epoch)

traceD :: Trace IO a -> LOMeta -> Text -> Double -> IO ()
traceD :: Trace IO a -> LOMeta -> Text -> Double -> IO ()
traceD Trace IO a
tr LOMeta
meta Text
msg Double
d = Trace IO a -> (LOMeta, LOContent a) -> IO ()
forall (m :: * -> *) a.
MonadIO m =>
Trace m a -> (LOMeta, LOContent a) -> m ()
traceNamedObject Trace IO a
tr (LOMeta
meta, Text -> Measurable -> LOContent a
forall a. Text -> Measurable -> LOContent a
LogValue Text
msg (Double -> Measurable
PureD Double
d))

traceI :: Integral i => Trace IO a -> LOMeta -> Text -> i -> IO ()
traceI :: Trace IO a -> LOMeta -> Text -> i -> IO ()
traceI Trace IO a
tr LOMeta
meta Text
msg i
i = Trace IO a -> (LOMeta, LOContent a) -> IO ()
forall (m :: * -> *) a.
MonadIO m =>
Trace m a -> (LOMeta, LOContent a) -> m ()
traceNamedObject Trace IO a
tr (LOMeta
meta, Text -> Measurable -> LOContent a
forall a. Text -> Measurable -> LOContent a
LogValue Text
msg (Integer -> Measurable
PureI (i -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral i
i)))

sendEKGDirectCounter :: EKGDirect -> Text -> IO ()
sendEKGDirectCounter :: EKGDirect -> Text -> IO ()
sendEKGDirectCounter EKGDirect
ekgDirect Text
name = do
  MVar (Map Text Counter)
-> (Map Text Counter -> IO (Map Text Counter)) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ (EKGDirect -> MVar (Map Text Counter)
ekgCounters EKGDirect
ekgDirect) ((Map Text Counter -> IO (Map Text Counter)) -> IO ())
-> (Map Text Counter -> IO (Map Text Counter)) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Map Text Counter
registeredMap -> do
    case Text -> Map Text Counter -> Maybe Counter
forall k a. Ord k => k -> Map k a -> Maybe a
SMap.lookup Text
name Map Text Counter
registeredMap of
      Just Counter
counter -> do
        Counter -> IO ()
Counter.inc Counter
counter
        Map Text Counter -> IO (Map Text Counter)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map Text Counter
registeredMap
      Maybe Counter
Nothing -> do
        Counter
counter <- Text -> Server -> IO Counter
EKG.getCounter Text
name (EKGDirect -> Server
ekgServer EKGDirect
ekgDirect)
        Counter -> IO ()
Counter.inc Counter
counter
        Map Text Counter -> IO (Map Text Counter)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map Text Counter -> IO (Map Text Counter))
-> Map Text Counter -> IO (Map Text Counter)
forall a b. (a -> b) -> a -> b
$ Text -> Counter -> Map Text Counter -> Map Text Counter
forall k a. Ord k => k -> a -> Map k a -> Map k a
SMap.insert Text
name Counter
counter Map Text Counter
registeredMap

_sendEKGDirectInt :: Integral a => EKGDirect -> Text -> a -> IO ()
_sendEKGDirectInt :: EKGDirect -> Text -> a -> IO ()
_sendEKGDirectInt EKGDirect
ekgDirect Text
name a
val = do
  MVar (Map Text Gauge)
-> (Map Text Gauge -> IO (Map Text Gauge)) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ (EKGDirect -> MVar (Map Text Gauge)
ekgGauges EKGDirect
ekgDirect) ((Map Text Gauge -> IO (Map Text Gauge)) -> IO ())
-> (Map Text Gauge -> IO (Map Text Gauge)) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Map Text Gauge
registeredMap -> do
    case Text -> Map Text Gauge -> Maybe Gauge
forall k a. Ord k => k -> Map k a -> Maybe a
SMap.lookup Text
name Map Text Gauge
registeredMap of
      Just Gauge
gauge -> do
        Gauge -> Int64 -> IO ()
Gauge.set Gauge
gauge (a -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
val)
        Map Text Gauge -> IO (Map Text Gauge)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map Text Gauge
registeredMap
      Maybe Gauge
Nothing -> do
        Gauge
gauge <- Text -> Server -> IO Gauge
EKG.getGauge Text
name (EKGDirect -> Server
ekgServer EKGDirect
ekgDirect)
        Gauge -> Int64 -> IO ()
Gauge.set Gauge
gauge (a -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
val)
        Map Text Gauge -> IO (Map Text Gauge)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map Text Gauge -> IO (Map Text Gauge))
-> Map Text Gauge -> IO (Map Text Gauge)
forall a b. (a -> b) -> a -> b
$ Text -> Gauge -> Map Text Gauge -> Map Text Gauge
forall k a. Ord k => k -> a -> Map k a -> Map k a
SMap.insert Text
name Gauge
gauge Map Text Gauge
registeredMap

_sendEKGDirectDouble :: EKGDirect -> Text -> Double -> IO ()
_sendEKGDirectDouble :: EKGDirect -> Text -> Double -> IO ()
_sendEKGDirectDouble EKGDirect
ekgDirect Text
name Double
val = do
  MVar (Map Text Label)
-> (Map Text Label -> IO (Map Text Label)) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ (EKGDirect -> MVar (Map Text Label)
ekgLabels EKGDirect
ekgDirect) ((Map Text Label -> IO (Map Text Label)) -> IO ())
-> (Map Text Label -> IO (Map Text Label)) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Map Text Label
registeredMap -> do
    case Text -> Map Text Label -> Maybe Label
forall k a. Ord k => k -> Map k a -> Maybe a
SMap.lookup Text
name Map Text Label
registeredMap of
      Just Label
label -> do
        Label -> Text -> IO ()
Label.set Label
label (String -> Text
Text.pack (Double -> String
forall a. Show a => a -> String
show Double
val))
        Map Text Label -> IO (Map Text Label)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map Text Label
registeredMap
      Maybe Label
Nothing -> do
        Label
label <- Text -> Server -> IO Label
EKG.getLabel Text
name (EKGDirect -> Server
ekgServer EKGDirect
ekgDirect)
        Label -> Text -> IO ()
Label.set Label
label (String -> Text
Text.pack (Double -> String
forall a. Show a => a -> String
show Double
val))
        Map Text Label -> IO (Map Text Label)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map Text Label -> IO (Map Text Label))
-> Map Text Label -> IO (Map Text Label)
forall a b. (a -> b) -> a -> b
$ Text -> Label -> Map Text Label -> Map Text Label
forall k a. Ord k => k -> a -> Map k a -> Map k a
SMap.insert Text
name Label
label Map Text Label
registeredMap

--------------------------------------------------------------------------------
-- Consensus Tracers
--------------------------------------------------------------------------------

isRollForward :: TraceChainSyncServerEvent blk -> Bool
isRollForward :: TraceChainSyncServerEvent blk -> Bool
isRollForward (TraceChainSyncRollForward Point blk
_) = Bool
True
isRollForward TraceChainSyncServerEvent blk
_ = Bool
False

isTraceBlockFetchServerBlockCount :: TraceBlockFetchServerEvent blk -> Bool
isTraceBlockFetchServerBlockCount :: TraceBlockFetchServerEvent blk -> Bool
isTraceBlockFetchServerBlockCount (TraceBlockFetchServerSendBlock Point blk
_) = Bool
True

mkConsensusTracers
  :: forall blk peer localPeer.
     ( Show peer
     , Eq peer
     , LedgerQueries blk
     , ToJSON (GenTxId blk)
     , ToObject (ApplyTxErr blk)
     , ToObject (CannotForge blk)
     , ToObject (GenTx blk)
     , ToObject (LedgerErr (LedgerState blk))
     , ToObject (OtherHeaderEnvelopeError blk)
     , ToObject (ValidationErr (BlockProtocol blk))
     , ToObject (ForgeStateUpdateError blk)
     , ToObject peer
     , Consensus.RunNode blk
     , HasKESMetricsData blk
     , HasKESInfo blk
     , Show (Header blk)
     )
  => Maybe EKGDirect
  -> TraceSelection
  -> TracingVerbosity
  -> Trace IO Text
  -> NodeKernelData blk
  -> ForgingStats
  -> IO (Consensus.Tracers' peer localPeer blk (Tracer IO))
mkConsensusTracers :: Maybe EKGDirect
-> TraceSelection
-> TracingVerbosity
-> Trace IO Text
-> NodeKernelData blk
-> ForgingStats
-> IO (Tracers' peer localPeer blk (Tracer IO))
mkConsensusTracers Maybe EKGDirect
mbEKGDirect TraceSelection
trSel TracingVerbosity
verb Trace IO Text
tr NodeKernelData blk
nodeKern ForgingStats
fStats = do
  let trmet :: Trace IO Text
trmet = Text -> Trace IO Text -> Trace IO Text
forall (m :: * -> *) a. Text -> Trace m a -> Trace m a
appendName Text
"metrics" Trace IO Text
tr

  MVar
  (Maybe
     (WithSeverity
        [TraceLabelPeer peer (FetchDecision [Point (Header blk)])]),
   Integer)
elidedFetchDecision <- IO
  (MVar
     (Maybe
        (WithSeverity
           [TraceLabelPeer peer (FetchDecision [Point (Header blk)])]),
      Integer))
forall a. ElidingTracer a => IO (MVar (Maybe a, Integer))
newstate  -- for eliding messages in FetchDecision tr
  ForgeTracers
forgeTracers <- IO ForgeTracers
mkForgeTracers
  LOMeta
meta <- Severity -> PrivacyAnnotation -> IO LOMeta
forall (m :: * -> *).
MonadIO m =>
Severity -> PrivacyAnnotation -> m LOMeta
mkLOMeta Severity
Critical PrivacyAnnotation
Public

  TVar Int
tBlocksServed <- Int -> IO (TVar Int)
forall a. a -> IO (TVar a)
STM.newTVarIO @Int Int
0
  TVar Int
tSubmissionsCollected <- Int -> IO (TVar Int)
forall a. a -> IO (TVar a)
STM.newTVarIO Int
0
  TVar Int
tSubmissionsAccepted <- Int -> IO (TVar Int)
forall a. a -> IO (TVar a)
STM.newTVarIO Int
0
  TVar Int
tSubmissionsRejected <- Int -> IO (TVar Int)
forall a. a -> IO (TVar a)
STM.newTVarIO Int
0

  Tracers' peer localPeer blk (Tracer IO)
-> IO (Tracers' peer localPeer blk (Tracer IO))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Tracers :: forall remotePeer localPeer blk (f :: * -> *).
f (TraceLabelPeer remotePeer (TraceChainSyncClientEvent blk))
-> f (TraceChainSyncServerEvent blk)
-> f (TraceChainSyncServerEvent blk)
-> f [TraceLabelPeer
        remotePeer (FetchDecision [Point (Header blk)])]
-> f (TraceLabelPeer
        remotePeer (TraceFetchClientState (Header blk)))
-> f (TraceBlockFetchServerEvent blk)
-> f (TraceLabelPeer
        remotePeer (TraceTxSubmissionInbound (GenTxId blk) (GenTx blk)))
-> f (TraceLabelPeer
        remotePeer (TraceTxSubmissionOutbound (GenTxId blk) (GenTx blk)))
-> f (TraceLocalTxSubmissionServerEvent blk)
-> f (TraceEventMempool blk)
-> f (TraceLabelCreds (TraceForgeEvent blk))
-> f (TraceBlockchainTimeEvent UTCTime)
-> f (TraceLabelCreds (ForgeStateInfo blk))
-> f (TraceKeepAliveClient remotePeer)
-> Tracers' remotePeer localPeer blk f
Consensus.Tracers
    { chainSyncClientTracer :: Tracer IO (TraceLabelPeer peer (TraceChainSyncClientEvent blk))
Consensus.chainSyncClientTracer = OnOff TraceChainSyncClient
-> TracingVerbosity
-> Text
-> Trace IO Text
-> Tracer IO (TraceLabelPeer peer (TraceChainSyncClientEvent blk))
forall a (b :: Symbol).
Transformable Text IO a =>
OnOff b -> TracingVerbosity -> Text -> Trace IO Text -> Tracer IO a
tracerOnOff (TraceSelection -> OnOff TraceChainSyncClient
traceChainSyncClient TraceSelection
trSel) TracingVerbosity
verb Text
"ChainSyncClient" Trace IO Text
tr
    , chainSyncServerHeaderTracer :: Tracer IO (TraceChainSyncServerEvent blk)
Consensus.chainSyncServerHeaderTracer =
      (TraceChainSyncServerEvent blk -> IO ())
-> Tracer IO (TraceChainSyncServerEvent blk)
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer ((TraceChainSyncServerEvent blk -> IO ())
 -> Tracer IO (TraceChainSyncServerEvent blk))
-> (TraceChainSyncServerEvent blk -> IO ())
-> Tracer IO (TraceChainSyncServerEvent blk)
forall a b. (a -> b) -> a -> b
$ \TraceChainSyncServerEvent blk
ev -> do
        Tracer IO (TraceChainSyncServerEvent blk)
-> TraceChainSyncServerEvent blk -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith (Tracer IO (WithSeverity (TraceChainSyncServerEvent blk))
-> Tracer IO (TraceChainSyncServerEvent blk)
forall a (m :: * -> *).
HasSeverityAnnotation a =>
Tracer m (WithSeverity a) -> Tracer m a
annotateSeverity (Tracer IO (WithSeverity (TraceChainSyncServerEvent blk))
 -> Tracer IO (TraceChainSyncServerEvent blk))
-> (Trace IO Text
    -> Tracer IO (WithSeverity (TraceChainSyncServerEvent blk)))
-> Trace IO Text
-> Tracer IO (TraceChainSyncServerEvent blk)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. TracingVerbosity
-> Trace IO Text
-> Tracer IO (WithSeverity (TraceChainSyncServerEvent blk))
forall (m :: * -> *) a b.
(ToLogObject m, ToObject a, Transformable a m b) =>
TracingVerbosity -> Trace m a -> Tracer m b
toLogObject' TracingVerbosity
verb (Trace IO Text -> Tracer IO (TraceChainSyncServerEvent blk))
-> Trace IO Text -> Tracer IO (TraceChainSyncServerEvent blk)
forall a b. (a -> b) -> a -> b
$ Text -> Trace IO Text -> Trace IO Text
forall (m :: * -> *) a. Text -> Trace m a -> Trace m a
appendName Text
"ChainSyncHeaderServer" Trace IO Text
tr) TraceChainSyncServerEvent blk
ev
        Maybe EKGDirect -> TraceChainSyncServerEvent blk -> IO ()
traceServedCount Maybe EKGDirect
mbEKGDirect TraceChainSyncServerEvent blk
ev
    , chainSyncServerBlockTracer :: Tracer IO (TraceChainSyncServerEvent blk)
Consensus.chainSyncServerBlockTracer = OnOff TraceChainSyncBlockServer
-> TracingVerbosity
-> Text
-> Trace IO Text
-> Tracer IO (TraceChainSyncServerEvent blk)
forall a (b :: Symbol).
Transformable Text IO a =>
OnOff b -> TracingVerbosity -> Text -> Trace IO Text -> Tracer IO a
tracerOnOff (TraceSelection -> OnOff TraceChainSyncBlockServer
traceChainSyncBlockServer TraceSelection
trSel) TracingVerbosity
verb Text
"ChainSyncBlockServer" Trace IO Text
tr
    , blockFetchDecisionTracer :: Tracer
  IO [TraceLabelPeer peer (FetchDecision [Point (Header blk)])]
Consensus.blockFetchDecisionTracer = OnOff TraceBlockFetchDecisions
-> Tracer
     IO [TraceLabelPeer peer (FetchDecision [Point (Header blk)])]
-> Tracer
     IO [TraceLabelPeer peer (FetchDecision [Point (Header blk)])]
forall (b :: Symbol) a. OnOff b -> Tracer IO a -> Tracer IO a
tracerOnOff' (TraceSelection -> OnOff TraceBlockFetchDecisions
traceBlockFetchDecisions TraceSelection
trSel) (Tracer
   IO [TraceLabelPeer peer (FetchDecision [Point (Header blk)])]
 -> Tracer
      IO [TraceLabelPeer peer (FetchDecision [Point (Header blk)])])
-> Tracer
     IO [TraceLabelPeer peer (FetchDecision [Point (Header blk)])]
-> Tracer
     IO [TraceLabelPeer peer (FetchDecision [Point (Header blk)])]
forall a b. (a -> b) -> a -> b
$
        Tracer
  IO
  (WithSeverity
     [TraceLabelPeer peer (FetchDecision [Point (Header blk)])])
-> Tracer
     IO [TraceLabelPeer peer (FetchDecision [Point (Header blk)])]
forall a (m :: * -> *).
HasSeverityAnnotation a =>
Tracer m (WithSeverity a) -> Tracer m a
annotateSeverity (Tracer
   IO
   (WithSeverity
      [TraceLabelPeer peer (FetchDecision [Point (Header blk)])])
 -> Tracer
      IO [TraceLabelPeer peer (FetchDecision [Point (Header blk)])])
-> Tracer
     IO
     (WithSeverity
        [TraceLabelPeer peer (FetchDecision [Point (Header blk)])])
-> Tracer
     IO [TraceLabelPeer peer (FetchDecision [Point (Header blk)])]
forall a b. (a -> b) -> a -> b
$ TracingVerbosity
-> MVar
     (Maybe
        (WithSeverity
           [TraceLabelPeer peer (FetchDecision [Point (Header blk)])]),
      Integer)
-> Trace IO Text
-> Tracer
     IO
     (WithSeverity
        [TraceLabelPeer peer (FetchDecision [Point (Header blk)])])
forall peer blk.
(Eq peer, HasHeader blk, Show peer, ToObject peer) =>
TracingVerbosity
-> MVar
     (Maybe
        (WithSeverity
           [TraceLabelPeer peer (FetchDecision [Point (Header blk)])]),
      Integer)
-> Trace IO Text
-> Tracer
     IO
     (WithSeverity
        [TraceLabelPeer peer (FetchDecision [Point (Header blk)])])
teeTraceBlockFetchDecision TracingVerbosity
verb MVar
  (Maybe
     (WithSeverity
        [TraceLabelPeer peer (FetchDecision [Point (Header blk)])]),
   Integer)
elidedFetchDecision Trace IO Text
tr
    , blockFetchClientTracer :: Tracer
  IO (TraceLabelPeer peer (TraceFetchClientState (Header blk)))
Consensus.blockFetchClientTracer = OnOff TraceBlockFetchClient
-> TracingVerbosity
-> Text
-> Trace IO Text
-> Tracer
     IO (TraceLabelPeer peer (TraceFetchClientState (Header blk)))
forall a (b :: Symbol).
Transformable Text IO a =>
OnOff b -> TracingVerbosity -> Text -> Trace IO Text -> Tracer IO a
tracerOnOff (TraceSelection -> OnOff TraceBlockFetchClient
traceBlockFetchClient TraceSelection
trSel) TracingVerbosity
verb Text
"BlockFetchClient" Trace IO Text
tr
    , blockFetchServerTracer :: Tracer IO (TraceBlockFetchServerEvent blk)
Consensus.blockFetchServerTracer = OnOff TraceBlockFetchServer
-> Tracer IO (TraceBlockFetchServerEvent blk)
-> Tracer IO (TraceBlockFetchServerEvent blk)
forall (b :: Symbol) a. OnOff b -> Tracer IO a -> Tracer IO a
tracerOnOff' (TraceSelection -> OnOff TraceBlockFetchServer
traceBlockFetchServer TraceSelection
trSel) (Tracer IO (TraceBlockFetchServerEvent blk)
 -> Tracer IO (TraceBlockFetchServerEvent blk))
-> Tracer IO (TraceBlockFetchServerEvent blk)
-> Tracer IO (TraceBlockFetchServerEvent blk)
forall a b. (a -> b) -> a -> b
$
        (TraceBlockFetchServerEvent blk -> IO ())
-> Tracer IO (TraceBlockFetchServerEvent blk)
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer ((TraceBlockFetchServerEvent blk -> IO ())
 -> Tracer IO (TraceBlockFetchServerEvent blk))
-> (TraceBlockFetchServerEvent blk -> IO ())
-> Tracer IO (TraceBlockFetchServerEvent blk)
forall a b. (a -> b) -> a -> b
$ \TraceBlockFetchServerEvent blk
ev -> do
          Tracer IO (TraceBlockFetchServerEvent blk)
-> TraceBlockFetchServerEvent blk -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith (Tracer IO (WithSeverity (TraceBlockFetchServerEvent blk))
-> Tracer IO (TraceBlockFetchServerEvent blk)
forall a (m :: * -> *).
HasSeverityAnnotation a =>
Tracer m (WithSeverity a) -> Tracer m a
annotateSeverity (Tracer IO (WithSeverity (TraceBlockFetchServerEvent blk))
 -> Tracer IO (TraceBlockFetchServerEvent blk))
-> (Trace IO Text
    -> Tracer IO (WithSeverity (TraceBlockFetchServerEvent blk)))
-> Trace IO Text
-> Tracer IO (TraceBlockFetchServerEvent blk)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. TracingVerbosity
-> Trace IO Text
-> Tracer IO (WithSeverity (TraceBlockFetchServerEvent blk))
forall (m :: * -> *) a b.
(ToLogObject m, ToObject a, Transformable a m b) =>
TracingVerbosity -> Trace m a -> Tracer m b
toLogObject' TracingVerbosity
verb (Trace IO Text -> Tracer IO (TraceBlockFetchServerEvent blk))
-> Trace IO Text -> Tracer IO (TraceBlockFetchServerEvent blk)
forall a b. (a -> b) -> a -> b
$ Text -> Trace IO Text -> Trace IO Text
forall (m :: * -> *) a. Text -> Trace m a -> Trace m a
appendName Text
"BlockFetchServer" Trace IO Text
tr) TraceBlockFetchServerEvent blk
ev
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TraceBlockFetchServerEvent blk -> Bool
forall blk. TraceBlockFetchServerEvent blk -> Bool
isTraceBlockFetchServerBlockCount TraceBlockFetchServerEvent blk
ev) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            Trace IO Text -> LOMeta -> Text -> Int -> IO ()
forall i a.
Integral i =>
Trace IO a -> LOMeta -> Text -> i -> IO ()
traceI Trace IO Text
trmet LOMeta
meta Text
"served.block.count" (Int -> IO ()) -> IO Int -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
              TVar Int -> (Int -> Int) -> IO Int
forall a. TVar a -> (a -> a) -> IO a
STM.modifyReadTVarIO TVar Int
tBlocksServed (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
    , forgeStateInfoTracer :: Tracer IO (TraceLabelCreds (ForgeStateInfo blk))
Consensus.forgeStateInfoTracer = OnOff TraceForgeStateInfo
-> Tracer IO (TraceLabelCreds (ForgeStateInfo blk))
-> Tracer IO (TraceLabelCreds (ForgeStateInfo blk))
forall (b :: Symbol) a. OnOff b -> Tracer IO a -> Tracer IO a
tracerOnOff' (TraceSelection -> OnOff TraceForgeStateInfo
traceForgeStateInfo TraceSelection
trSel) (Tracer IO (TraceLabelCreds (ForgeStateInfo blk))
 -> Tracer IO (TraceLabelCreds (ForgeStateInfo blk)))
-> Tracer IO (TraceLabelCreds (ForgeStateInfo blk))
-> Tracer IO (TraceLabelCreds (ForgeStateInfo blk))
forall a b. (a -> b) -> a -> b
$
        Proxy blk
-> TraceSelection
-> Trace IO Text
-> Tracer IO (TraceLabelCreds (ForgeStateInfo blk))
forall blk.
(HasKESMetricsData blk, Show (ForgeStateInfo blk)) =>
Proxy blk
-> TraceSelection
-> Trace IO Text
-> Tracer IO (TraceLabelCreds (ForgeStateInfo blk))
forgeStateInfoTracer (Proxy blk
forall k (t :: k). Proxy t
Proxy @ blk) TraceSelection
trSel Trace IO Text
tr
    , txInboundTracer :: Tracer
  IO
  (TraceLabelPeer
     peer (TraceTxSubmissionInbound (GenTxId blk) (GenTx blk)))
Consensus.txInboundTracer = OnOff TraceTxInbound
-> Tracer
     IO
     (TraceLabelPeer
        peer (TraceTxSubmissionInbound (GenTxId blk) (GenTx blk)))
-> Tracer
     IO
     (TraceLabelPeer
        peer (TraceTxSubmissionInbound (GenTxId blk) (GenTx blk)))
forall (b :: Symbol) a. OnOff b -> Tracer IO a -> Tracer IO a
tracerOnOff' (TraceSelection -> OnOff TraceTxInbound
traceTxInbound TraceSelection
trSel) (Tracer
   IO
   (TraceLabelPeer
      peer (TraceTxSubmissionInbound (GenTxId blk) (GenTx blk)))
 -> Tracer
      IO
      (TraceLabelPeer
         peer (TraceTxSubmissionInbound (GenTxId blk) (GenTx blk))))
-> Tracer
     IO
     (TraceLabelPeer
        peer (TraceTxSubmissionInbound (GenTxId blk) (GenTx blk)))
-> Tracer
     IO
     (TraceLabelPeer
        peer (TraceTxSubmissionInbound (GenTxId blk) (GenTx blk)))
forall a b. (a -> b) -> a -> b
$
        (TraceLabelPeer
   peer (TraceTxSubmissionInbound (GenTxId blk) (GenTx blk))
 -> IO ())
-> Tracer
     IO
     (TraceLabelPeer
        peer (TraceTxSubmissionInbound (GenTxId blk) (GenTx blk)))
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer ((TraceLabelPeer
    peer (TraceTxSubmissionInbound (GenTxId blk) (GenTx blk))
  -> IO ())
 -> Tracer
      IO
      (TraceLabelPeer
         peer (TraceTxSubmissionInbound (GenTxId blk) (GenTx blk))))
-> (TraceLabelPeer
      peer (TraceTxSubmissionInbound (GenTxId blk) (GenTx blk))
    -> IO ())
-> Tracer
     IO
     (TraceLabelPeer
        peer (TraceTxSubmissionInbound (GenTxId blk) (GenTx blk)))
forall a b. (a -> b) -> a -> b
$ \TraceLabelPeer
  peer (TraceTxSubmissionInbound (GenTxId blk) (GenTx blk))
ev -> do
          Tracer
  IO
  (TraceLabelPeer
     peer (TraceTxSubmissionInbound (GenTxId blk) (GenTx blk)))
-> TraceLabelPeer
     peer (TraceTxSubmissionInbound (GenTxId blk) (GenTx blk))
-> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith (Tracer
  IO
  (WithSeverity
     (TraceLabelPeer
        peer (TraceTxSubmissionInbound (GenTxId blk) (GenTx blk))))
-> Tracer
     IO
     (TraceLabelPeer
        peer (TraceTxSubmissionInbound (GenTxId blk) (GenTx blk)))
forall a (m :: * -> *).
HasSeverityAnnotation a =>
Tracer m (WithSeverity a) -> Tracer m a
annotateSeverity (Tracer
   IO
   (WithSeverity
      (TraceLabelPeer
         peer (TraceTxSubmissionInbound (GenTxId blk) (GenTx blk))))
 -> Tracer
      IO
      (TraceLabelPeer
         peer (TraceTxSubmissionInbound (GenTxId blk) (GenTx blk))))
-> (Trace IO Text
    -> Tracer
         IO
         (WithSeverity
            (TraceLabelPeer
               peer (TraceTxSubmissionInbound (GenTxId blk) (GenTx blk)))))
-> Trace IO Text
-> Tracer
     IO
     (TraceLabelPeer
        peer (TraceTxSubmissionInbound (GenTxId blk) (GenTx blk)))
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. TracingVerbosity
-> Trace IO Text
-> Tracer
     IO
     (WithSeverity
        (TraceLabelPeer
           peer (TraceTxSubmissionInbound (GenTxId blk) (GenTx blk))))
forall (m :: * -> *) a b.
(ToLogObject m, ToObject a, Transformable a m b) =>
TracingVerbosity -> Trace m a -> Tracer m b
toLogObject' TracingVerbosity
verb (Trace IO Text
 -> Tracer
      IO
      (TraceLabelPeer
         peer (TraceTxSubmissionInbound (GenTxId blk) (GenTx blk))))
-> Trace IO Text
-> Tracer
     IO
     (TraceLabelPeer
        peer (TraceTxSubmissionInbound (GenTxId blk) (GenTx blk)))
forall a b. (a -> b) -> a -> b
$ Text -> Trace IO Text -> Trace IO Text
forall (m :: * -> *) a. Text -> Trace m a -> Trace m a
appendName Text
"TxInbound" Trace IO Text
tr) TraceLabelPeer
  peer (TraceTxSubmissionInbound (GenTxId blk) (GenTx blk))
ev
          case TraceLabelPeer
  peer (TraceTxSubmissionInbound (GenTxId blk) (GenTx blk))
ev of
            TraceLabelPeer peer
_ (TraceTxSubmissionCollected Int
collected) ->
              Trace IO Text -> LOMeta -> Text -> Int -> IO ()
forall i a.
Integral i =>
Trace IO a -> LOMeta -> Text -> i -> IO ()
traceI Trace IO Text
trmet LOMeta
meta Text
"submissions.submitted.count" (Int -> IO ()) -> IO Int -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
                TVar Int -> (Int -> Int) -> IO Int
forall a. TVar a -> (a -> a) -> IO a
STM.modifyReadTVarIO TVar Int
tSubmissionsCollected (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
collected)

            TraceLabelPeer peer
_ (TraceTxSubmissionProcessed ProcessedTxCount
processed) -> do
              Trace IO Text -> LOMeta -> Text -> Int -> IO ()
forall i a.
Integral i =>
Trace IO a -> LOMeta -> Text -> i -> IO ()
traceI Trace IO Text
trmet LOMeta
meta Text
"submissions.accepted.count" (Int -> IO ()) -> IO Int -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
                TVar Int -> (Int -> Int) -> IO Int
forall a. TVar a -> (a -> a) -> IO a
STM.modifyReadTVarIO TVar Int
tSubmissionsAccepted (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ProcessedTxCount -> Int
ptxcAccepted ProcessedTxCount
processed)
              Trace IO Text -> LOMeta -> Text -> Int -> IO ()
forall i a.
Integral i =>
Trace IO a -> LOMeta -> Text -> i -> IO ()
traceI Trace IO Text
trmet LOMeta
meta Text
"submissions.rejected.count" (Int -> IO ()) -> IO Int -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
                TVar Int -> (Int -> Int) -> IO Int
forall a. TVar a -> (a -> a) -> IO a
STM.modifyReadTVarIO TVar Int
tSubmissionsRejected (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ProcessedTxCount -> Int
ptxcRejected ProcessedTxCount
processed)

            TraceLabelPeer peer
_ TraceTxSubmissionInbound (GenTxId blk) (GenTx blk)
TraceTxInboundTerminated -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            TraceLabelPeer peer
_ (TraceTxInboundCanRequestMoreTxs Int
_) -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            TraceLabelPeer peer
_ (TraceTxInboundCannotRequestMoreTxs Int
_) -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    , txOutboundTracer :: Tracer
  IO
  (TraceLabelPeer
     peer (TraceTxSubmissionOutbound (GenTxId blk) (GenTx blk)))
Consensus.txOutboundTracer = OnOff TraceTxOutbound
-> TracingVerbosity
-> Text
-> Trace IO Text
-> Tracer
     IO
     (TraceLabelPeer
        peer (TraceTxSubmissionOutbound (GenTxId blk) (GenTx blk)))
forall a (b :: Symbol).
Transformable Text IO a =>
OnOff b -> TracingVerbosity -> Text -> Trace IO Text -> Tracer IO a
tracerOnOff (TraceSelection -> OnOff TraceTxOutbound
traceTxOutbound TraceSelection
trSel) TracingVerbosity
verb Text
"TxOutbound" Trace IO Text
tr
    , localTxSubmissionServerTracer :: Tracer IO (TraceLocalTxSubmissionServerEvent blk)
Consensus.localTxSubmissionServerTracer = OnOff TraceLocalTxSubmissionServer
-> TracingVerbosity
-> Text
-> Trace IO Text
-> Tracer IO (TraceLocalTxSubmissionServerEvent blk)
forall a (b :: Symbol).
Transformable Text IO a =>
OnOff b -> TracingVerbosity -> Text -> Trace IO Text -> Tracer IO a
tracerOnOff (TraceSelection -> OnOff TraceLocalTxSubmissionServer
traceLocalTxSubmissionServer TraceSelection
trSel) TracingVerbosity
verb Text
"LocalTxSubmissionServer" Trace IO Text
tr
    , mempoolTracer :: Tracer IO (TraceEventMempool blk)
Consensus.mempoolTracer = OnOff TraceMempool
-> Tracer IO (TraceEventMempool blk)
-> Tracer IO (TraceEventMempool blk)
forall (b :: Symbol) a. OnOff b -> Tracer IO a -> Tracer IO a
tracerOnOff' (TraceSelection -> OnOff TraceMempool
traceMempool TraceSelection
trSel) (Tracer IO (TraceEventMempool blk)
 -> Tracer IO (TraceEventMempool blk))
-> Tracer IO (TraceEventMempool blk)
-> Tracer IO (TraceEventMempool blk)
forall a b. (a -> b) -> a -> b
$ TraceSelection
-> Trace IO Text
-> ForgingStats
-> Tracer IO (TraceEventMempool blk)
forall blk.
(ToJSON (GenTxId blk), ToObject (ApplyTxErr blk),
 ToObject (GenTx blk), LedgerSupportsMempool blk) =>
TraceSelection
-> Trace IO Text
-> ForgingStats
-> Tracer IO (TraceEventMempool blk)
mempoolTracer TraceSelection
trSel Trace IO Text
tr ForgingStats
fStats
    , forgeTracer :: Tracer IO (TraceLabelCreds (TraceForgeEvent blk))
Consensus.forgeTracer = OnOff TraceForge
-> Tracer IO (TraceLabelCreds (TraceForgeEvent blk))
-> Tracer IO (TraceLabelCreds (TraceForgeEvent blk))
forall (b :: Symbol) a. OnOff b -> Tracer IO a -> Tracer IO a
tracerOnOff' (TraceSelection -> OnOff TraceForge
traceForge TraceSelection
trSel) (Tracer IO (TraceLabelCreds (TraceForgeEvent blk))
 -> Tracer IO (TraceLabelCreds (TraceForgeEvent blk)))
-> Tracer IO (TraceLabelCreds (TraceForgeEvent blk))
-> Tracer IO (TraceLabelCreds (TraceForgeEvent blk))
forall a b. (a -> b) -> a -> b
$
        (TraceLabelCreds (TraceForgeEvent blk) -> IO ())
-> Tracer IO (TraceLabelCreds (TraceForgeEvent blk))
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer ((TraceLabelCreds (TraceForgeEvent blk) -> IO ())
 -> Tracer IO (TraceLabelCreds (TraceForgeEvent blk)))
-> (TraceLabelCreds (TraceForgeEvent blk) -> IO ())
-> Tracer IO (TraceLabelCreds (TraceForgeEvent blk))
forall a b. (a -> b) -> a -> b
$ \tlcev :: TraceLabelCreds (TraceForgeEvent blk)
tlcev@Consensus.TraceLabelCreds{} -> do
          Tracer IO (TraceLabelCreds (TraceForgeEvent blk))
-> TraceLabelCreds (TraceForgeEvent blk) -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith (Tracer IO (WithSeverity (TraceLabelCreds (TraceForgeEvent blk)))
-> Tracer IO (TraceLabelCreds (TraceForgeEvent blk))
forall a (m :: * -> *).
HasSeverityAnnotation a =>
Tracer m (WithSeverity a) -> Tracer m a
annotateSeverity
                     (Tracer IO (WithSeverity (TraceLabelCreds (TraceForgeEvent blk)))
 -> Tracer IO (TraceLabelCreds (TraceForgeEvent blk)))
-> Tracer IO (WithSeverity (TraceLabelCreds (TraceForgeEvent blk)))
-> Tracer IO (TraceLabelCreds (TraceForgeEvent blk))
forall a b. (a -> b) -> a -> b
$ ForgeTracers
-> NodeKernelData blk
-> TracingVerbosity
-> Trace IO Text
-> Tracer IO (WithSeverity (TraceLabelCreds (TraceForgeEvent blk)))
forall blk.
(RunNode blk, LedgerQueries blk) =>
ForgeTracers
-> NodeKernelData blk
-> TracingVerbosity
-> Trace IO Text
-> Tracer IO (WithSeverity (TraceLabelCreds (TraceForgeEvent blk)))
traceLeadershipChecks ForgeTracers
forgeTracers NodeKernelData blk
nodeKern TracingVerbosity
verb Trace IO Text
tr) TraceLabelCreds (TraceForgeEvent blk)
tlcev
          Tracer IO (TraceLabelCreds (TraceForgeEvent blk))
-> TraceLabelCreds (TraceForgeEvent blk) -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith (TracingVerbosity
-> Trace IO Text
-> ForgeTracers
-> ForgingStats
-> Tracer IO (TraceLabelCreds (TraceForgeEvent blk))
forall blk.
(RunNode blk, ToObject (CannotForge blk),
 ToObject (LedgerErr (LedgerState blk)),
 ToObject (OtherHeaderEnvelopeError blk),
 ToObject (ValidationErr (BlockProtocol blk)),
 ToObject (ForgeStateUpdateError blk), HasKESInfo blk) =>
TracingVerbosity
-> Trace IO Text
-> ForgeTracers
-> ForgingStats
-> Tracer IO (TraceLabelCreds (TraceForgeEvent blk))
forgeTracer TracingVerbosity
verb Trace IO Text
tr ForgeTracers
forgeTracers ForgingStats
fStats) TraceLabelCreds (TraceForgeEvent blk)
tlcev

    , blockchainTimeTracer :: Tracer IO (TraceBlockchainTimeEvent UTCTime)
Consensus.blockchainTimeTracer = OnOff TraceBlockchainTime
-> Tracer IO (TraceBlockchainTimeEvent UTCTime)
-> Tracer IO (TraceBlockchainTimeEvent UTCTime)
forall (b :: Symbol) a. OnOff b -> Tracer IO a -> Tracer IO a
tracerOnOff' (TraceSelection -> OnOff TraceBlockchainTime
traceBlockchainTime TraceSelection
trSel) (Tracer IO (TraceBlockchainTimeEvent UTCTime)
 -> Tracer IO (TraceBlockchainTimeEvent UTCTime))
-> Tracer IO (TraceBlockchainTimeEvent UTCTime)
-> Tracer IO (TraceBlockchainTimeEvent UTCTime)
forall a b. (a -> b) -> a -> b
$
        (TraceBlockchainTimeEvent UTCTime -> IO ())
-> Tracer IO (TraceBlockchainTimeEvent UTCTime)
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer ((TraceBlockchainTimeEvent UTCTime -> IO ())
 -> Tracer IO (TraceBlockchainTimeEvent UTCTime))
-> (TraceBlockchainTimeEvent UTCTime -> IO ())
-> Tracer IO (TraceBlockchainTimeEvent UTCTime)
forall a b. (a -> b) -> a -> b
$ \TraceBlockchainTimeEvent UTCTime
ev ->
          Tracer IO Text -> Text -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith (Trace IO Text -> Tracer IO Text
forall (m :: * -> *) a b.
(ToLogObject m, ToObject a, Transformable a m b) =>
Trace m a -> Tracer m b
toLogObject Trace IO Text
tr) (TraceBlockchainTimeEvent UTCTime -> Text
readableTraceBlockchainTimeEvent TraceBlockchainTimeEvent UTCTime
ev)
    , keepAliveClientTracer :: Tracer IO (TraceKeepAliveClient peer)
Consensus.keepAliveClientTracer = OnOff TraceKeepAliveClient
-> TracingVerbosity
-> Text
-> Trace IO Text
-> Tracer IO (TraceKeepAliveClient peer)
forall a (b :: Symbol).
Transformable Text IO a =>
OnOff b -> TracingVerbosity -> Text -> Trace IO Text -> Tracer IO a
tracerOnOff (TraceSelection -> OnOff TraceKeepAliveClient
traceKeepAliveClient TraceSelection
trSel) TracingVerbosity
verb Text
"KeepAliveClient" Trace IO Text
tr
    }
 where
   mkForgeTracers :: IO ForgeTracers
   mkForgeTracers :: IO ForgeTracers
mkForgeTracers = do
     -- We probably don't want to pay the extra IO cost per-counter-increment. -- sk
     LOMeta
staticMeta <- Severity -> PrivacyAnnotation -> IO LOMeta
forall (m :: * -> *).
MonadIO m =>
Severity -> PrivacyAnnotation -> m LOMeta
mkLOMeta Severity
Critical PrivacyAnnotation
Confidential
     let Text
name :: LoggerName = Text
"metrics.Forge"
     Trace IO Text
-> Trace IO Text
-> Trace IO Text
-> Trace IO Text
-> Trace IO Text
-> Trace IO Text
-> Trace IO Text
-> Trace IO Text
-> Trace IO Text
-> Trace IO Text
-> Trace IO Text
-> Trace IO Text
-> ForgeTracers
ForgeTracers
       (Trace IO Text
 -> Trace IO Text
 -> Trace IO Text
 -> Trace IO Text
 -> Trace IO Text
 -> Trace IO Text
 -> Trace IO Text
 -> Trace IO Text
 -> Trace IO Text
 -> Trace IO Text
 -> Trace IO Text
 -> Trace IO Text
 -> ForgeTracers)
-> IO (Trace IO Text)
-> IO
     (Trace IO Text
      -> Trace IO Text
      -> Trace IO Text
      -> Trace IO Text
      -> Trace IO Text
      -> Trace IO Text
      -> Trace IO Text
      -> Trace IO Text
      -> Trace IO Text
      -> Trace IO Text
      -> Trace IO Text
      -> ForgeTracers)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Tracer IO (Counting (Text, LogObject Text)) -> IO (Trace IO Text)
forall (m :: * -> *) a.
MonadIO m =>
Tracer m (Counting a) -> m (Tracer m a)
counting (LOMeta
-> Text
-> Text
-> Trace IO Text
-> Tracer IO (Counting (Text, LogObject Text))
forall (m :: * -> *) a.
LOMeta
-> Text
-> Text
-> Trace m a
-> Tracer m (Counting (Text, LogObject a))
liftCounting LOMeta
staticMeta Text
name Text
"forged" Trace IO Text
tr)
       IO
  (Trace IO Text
   -> Trace IO Text
   -> Trace IO Text
   -> Trace IO Text
   -> Trace IO Text
   -> Trace IO Text
   -> Trace IO Text
   -> Trace IO Text
   -> Trace IO Text
   -> Trace IO Text
   -> Trace IO Text
   -> ForgeTracers)
-> IO (Trace IO Text)
-> IO
     (Trace IO Text
      -> Trace IO Text
      -> Trace IO Text
      -> Trace IO Text
      -> Trace IO Text
      -> Trace IO Text
      -> Trace IO Text
      -> Trace IO Text
      -> Trace IO Text
      -> Trace IO Text
      -> ForgeTracers)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Tracer IO (Counting (Text, LogObject Text)) -> IO (Trace IO Text)
forall (m :: * -> *) a.
MonadIO m =>
Tracer m (Counting a) -> m (Tracer m a)
counting (LOMeta
-> Text
-> Text
-> Trace IO Text
-> Tracer IO (Counting (Text, LogObject Text))
forall (m :: * -> *) a.
LOMeta
-> Text
-> Text
-> Trace m a
-> Tracer m (Counting (Text, LogObject a))
liftCounting LOMeta
staticMeta Text
name Text
"forge-about-to-lead" Trace IO Text
tr)
       IO
  (Trace IO Text
   -> Trace IO Text
   -> Trace IO Text
   -> Trace IO Text
   -> Trace IO Text
   -> Trace IO Text
   -> Trace IO Text
   -> Trace IO Text
   -> Trace IO Text
   -> Trace IO Text
   -> ForgeTracers)
-> IO (Trace IO Text)
-> IO
     (Trace IO Text
      -> Trace IO Text
      -> Trace IO Text
      -> Trace IO Text
      -> Trace IO Text
      -> Trace IO Text
      -> Trace IO Text
      -> Trace IO Text
      -> Trace IO Text
      -> ForgeTracers)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Tracer IO (Counting (Text, LogObject Text)) -> IO (Trace IO Text)
forall (m :: * -> *) a.
MonadIO m =>
Tracer m (Counting a) -> m (Tracer m a)
counting (LOMeta
-> Text
-> Text
-> Trace IO Text
-> Tracer IO (Counting (Text, LogObject Text))
forall (m :: * -> *) a.
LOMeta
-> Text
-> Text
-> Trace m a
-> Tracer m (Counting (Text, LogObject a))
liftCounting LOMeta
staticMeta Text
name Text
"could-not-forge" Trace IO Text
tr)
       IO
  (Trace IO Text
   -> Trace IO Text
   -> Trace IO Text
   -> Trace IO Text
   -> Trace IO Text
   -> Trace IO Text
   -> Trace IO Text
   -> Trace IO Text
   -> Trace IO Text
   -> ForgeTracers)
-> IO (Trace IO Text)
-> IO
     (Trace IO Text
      -> Trace IO Text
      -> Trace IO Text
      -> Trace IO Text
      -> Trace IO Text
      -> Trace IO Text
      -> Trace IO Text
      -> Trace IO Text
      -> ForgeTracers)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Tracer IO (Counting (Text, LogObject Text)) -> IO (Trace IO Text)
forall (m :: * -> *) a.
MonadIO m =>
Tracer m (Counting a) -> m (Tracer m a)
counting (LOMeta
-> Text
-> Text
-> Trace IO Text
-> Tracer IO (Counting (Text, LogObject Text))
forall (m :: * -> *) a.
LOMeta
-> Text
-> Text
-> Trace m a
-> Tracer m (Counting (Text, LogObject a))
liftCounting LOMeta
staticMeta Text
name Text
"adopted" Trace IO Text
tr)
       IO
  (Trace IO Text
   -> Trace IO Text
   -> Trace IO Text
   -> Trace IO Text
   -> Trace IO Text
   -> Trace IO Text
   -> Trace IO Text
   -> Trace IO Text
   -> ForgeTracers)
-> IO (Trace IO Text)
-> IO
     (Trace IO Text
      -> Trace IO Text
      -> Trace IO Text
      -> Trace IO Text
      -> Trace IO Text
      -> Trace IO Text
      -> Trace IO Text
      -> ForgeTracers)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Tracer IO (Counting (Text, LogObject Text)) -> IO (Trace IO Text)
forall (m :: * -> *) a.
MonadIO m =>
Tracer m (Counting a) -> m (Tracer m a)
counting (LOMeta
-> Text
-> Text
-> Trace IO Text
-> Tracer IO (Counting (Text, LogObject Text))
forall (m :: * -> *) a.
LOMeta
-> Text
-> Text
-> Trace m a
-> Tracer m (Counting (Text, LogObject a))
liftCounting LOMeta
staticMeta Text
name Text
"didnt-adopt" Trace IO Text
tr)
       IO
  (Trace IO Text
   -> Trace IO Text
   -> Trace IO Text
   -> Trace IO Text
   -> Trace IO Text
   -> Trace IO Text
   -> Trace IO Text
   -> ForgeTracers)
-> IO (Trace IO Text)
-> IO
     (Trace IO Text
      -> Trace IO Text
      -> Trace IO Text
      -> Trace IO Text
      -> Trace IO Text
      -> Trace IO Text
      -> ForgeTracers)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Tracer IO (Counting (Text, LogObject Text)) -> IO (Trace IO Text)
forall (m :: * -> *) a.
MonadIO m =>
Tracer m (Counting a) -> m (Tracer m a)
counting (LOMeta
-> Text
-> Text
-> Trace IO Text
-> Tracer IO (Counting (Text, LogObject Text))
forall (m :: * -> *) a.
LOMeta
-> Text
-> Text
-> Trace m a
-> Tracer m (Counting (Text, LogObject a))
liftCounting LOMeta
staticMeta Text
name Text
"forged-invalid" Trace IO Text
tr)
       IO
  (Trace IO Text
   -> Trace IO Text
   -> Trace IO Text
   -> Trace IO Text
   -> Trace IO Text
   -> Trace IO Text
   -> ForgeTracers)
-> IO (Trace IO Text)
-> IO
     (Trace IO Text
      -> Trace IO Text
      -> Trace IO Text
      -> Trace IO Text
      -> Trace IO Text
      -> ForgeTracers)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Tracer IO (Counting (Text, LogObject Text)) -> IO (Trace IO Text)
forall (m :: * -> *) a.
MonadIO m =>
Tracer m (Counting a) -> m (Tracer m a)
counting (LOMeta
-> Text
-> Text
-> Trace IO Text
-> Tracer IO (Counting (Text, LogObject Text))
forall (m :: * -> *) a.
LOMeta
-> Text
-> Text
-> Trace m a
-> Tracer m (Counting (Text, LogObject a))
liftCounting LOMeta
staticMeta Text
name Text
"node-not-leader" Trace IO Text
tr)
       IO
  (Trace IO Text
   -> Trace IO Text
   -> Trace IO Text
   -> Trace IO Text
   -> Trace IO Text
   -> ForgeTracers)
-> IO (Trace IO Text)
-> IO
     (Trace IO Text
      -> Trace IO Text -> Trace IO Text -> Trace IO Text -> ForgeTracers)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Tracer IO (Counting (Text, LogObject Text)) -> IO (Trace IO Text)
forall (m :: * -> *) a.
MonadIO m =>
Tracer m (Counting a) -> m (Tracer m a)
counting (LOMeta
-> Text
-> Text
-> Trace IO Text
-> Tracer IO (Counting (Text, LogObject Text))
forall (m :: * -> *) a.
LOMeta
-> Text
-> Text
-> Trace m a
-> Tracer m (Counting (Text, LogObject a))
liftCounting LOMeta
staticMeta Text
name Text
"cannot-forge" Trace IO Text
tr)
       IO
  (Trace IO Text
   -> Trace IO Text -> Trace IO Text -> Trace IO Text -> ForgeTracers)
-> IO (Trace IO Text)
-> IO
     (Trace IO Text -> Trace IO Text -> Trace IO Text -> ForgeTracers)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Tracer IO (Counting (Text, LogObject Text)) -> IO (Trace IO Text)
forall (m :: * -> *) a.
MonadIO m =>
Tracer m (Counting a) -> m (Tracer m a)
counting (LOMeta
-> Text
-> Text
-> Trace IO Text
-> Tracer IO (Counting (Text, LogObject Text))
forall (m :: * -> *) a.
LOMeta
-> Text
-> Text
-> Trace m a
-> Tracer m (Counting (Text, LogObject a))
liftCounting LOMeta
staticMeta Text
name Text
"forge-state-update-error" Trace IO Text
tr)
       IO
  (Trace IO Text -> Trace IO Text -> Trace IO Text -> ForgeTracers)
-> IO (Trace IO Text)
-> IO (Trace IO Text -> Trace IO Text -> ForgeTracers)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Tracer IO (Counting (Text, LogObject Text)) -> IO (Trace IO Text)
forall (m :: * -> *) a.
MonadIO m =>
Tracer m (Counting a) -> m (Tracer m a)
counting (LOMeta
-> Text
-> Text
-> Trace IO Text
-> Tracer IO (Counting (Text, LogObject Text))
forall (m :: * -> *) a.
LOMeta
-> Text
-> Text
-> Trace m a
-> Tracer m (Counting (Text, LogObject a))
liftCounting LOMeta
staticMeta Text
name Text
"block-from-future" Trace IO Text
tr)
       IO (Trace IO Text -> Trace IO Text -> ForgeTracers)
-> IO (Trace IO Text) -> IO (Trace IO Text -> ForgeTracers)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Tracer IO (Counting (Text, LogObject Text)) -> IO (Trace IO Text)
forall (m :: * -> *) a.
MonadIO m =>
Tracer m (Counting a) -> m (Tracer m a)
counting (LOMeta
-> Text
-> Text
-> Trace IO Text
-> Tracer IO (Counting (Text, LogObject Text))
forall (m :: * -> *) a.
LOMeta
-> Text
-> Text
-> Trace m a
-> Tracer m (Counting (Text, LogObject a))
liftCounting LOMeta
staticMeta Text
name Text
"slot-is-immutable" Trace IO Text
tr)
       IO (Trace IO Text -> ForgeTracers)
-> IO (Trace IO Text) -> IO ForgeTracers
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Tracer IO (Counting (Text, LogObject Text)) -> IO (Trace IO Text)
forall (m :: * -> *) a.
MonadIO m =>
Tracer m (Counting a) -> m (Tracer m a)
counting (LOMeta
-> Text
-> Text
-> Trace IO Text
-> Tracer IO (Counting (Text, LogObject Text))
forall (m :: * -> *) a.
LOMeta
-> Text
-> Text
-> Trace m a
-> Tracer m (Counting (Text, LogObject a))
liftCounting LOMeta
staticMeta Text
name Text
"node-is-leader" Trace IO Text
tr)

   traceServedCount :: Maybe EKGDirect -> TraceChainSyncServerEvent blk -> IO ()
   traceServedCount :: Maybe EKGDirect -> TraceChainSyncServerEvent blk -> IO ()
traceServedCount Maybe EKGDirect
Nothing TraceChainSyncServerEvent blk
_ = () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
   traceServedCount (Just EKGDirect
ekgDirect) TraceChainSyncServerEvent blk
ev =
     Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TraceChainSyncServerEvent blk -> Bool
forall blk. TraceChainSyncServerEvent blk -> Bool
isRollForward TraceChainSyncServerEvent blk
ev) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
       EKGDirect -> Text -> IO ()
sendEKGDirectCounter EKGDirect
ekgDirect Text
"cardano.node.metrics.served.header.counter.int"

traceLeadershipChecks ::
  forall blk
  . ( Consensus.RunNode blk
     , LedgerQueries blk
     )
  => ForgeTracers
  -> NodeKernelData blk
  -> TracingVerbosity
  -> Trace IO Text
  -> Tracer IO (WithSeverity (Consensus.TraceLabelCreds (Consensus.TraceForgeEvent blk)))
traceLeadershipChecks :: ForgeTracers
-> NodeKernelData blk
-> TracingVerbosity
-> Trace IO Text
-> Tracer IO (WithSeverity (TraceLabelCreds (TraceForgeEvent blk)))
traceLeadershipChecks ForgeTracers
_ft NodeKernelData blk
nodeKern TracingVerbosity
_tverb Trace IO Text
tr = (WithSeverity (TraceLabelCreds (TraceForgeEvent blk)) -> IO ())
-> Tracer IO (WithSeverity (TraceLabelCreds (TraceForgeEvent blk)))
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer ((WithSeverity (TraceLabelCreds (TraceForgeEvent blk)) -> IO ())
 -> Tracer
      IO (WithSeverity (TraceLabelCreds (TraceForgeEvent blk))))
-> (WithSeverity (TraceLabelCreds (TraceForgeEvent blk)) -> IO ())
-> Tracer IO (WithSeverity (TraceLabelCreds (TraceForgeEvent blk)))
forall a b. (a -> b) -> a -> b
$
  \(WithSeverity Severity
sev (Consensus.TraceLabelCreds Text
creds TraceForgeEvent blk
event)) ->
    case TraceForgeEvent blk
event of
      Consensus.TraceStartLeadershipCheck SlotNo
slot -> do
        !StrictMaybe (Int, Int, Rational)
query <- (NodeKernel IO RemoteConnectionId LocalConnectionId blk
 -> IO (Int, Int, Rational))
-> NodeKernelData blk -> IO (StrictMaybe (Int, Int, Rational))
forall blk a.
(NodeKernel IO RemoteConnectionId LocalConnectionId blk -> IO a)
-> NodeKernelData blk -> IO (StrictMaybe a)
mapNodeKernelDataIO
                    (\NodeKernel IO RemoteConnectionId LocalConnectionId blk
nk ->
                       (,,)
                         (Int -> Int -> Rational -> (Int, Int, Rational))
-> IO Int -> IO (Int -> Rational -> (Int, Int, Rational))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ExtLedgerState blk -> Int)
-> NodeKernel IO RemoteConnectionId LocalConnectionId blk -> IO Int
forall blk a.
IsLedger (LedgerState blk) =>
(ExtLedgerState blk -> a)
-> NodeKernel IO RemoteConnectionId LocalConnectionId blk -> IO a
nkQueryLedger (LedgerState blk -> Int
forall blk. LedgerQueries blk => LedgerState blk -> Int
ledgerUtxoSize (LedgerState blk -> Int)
-> (ExtLedgerState blk -> LedgerState blk)
-> ExtLedgerState blk
-> Int
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ExtLedgerState blk -> LedgerState blk
forall blk. ExtLedgerState blk -> LedgerState blk
ledgerState) NodeKernel IO RemoteConnectionId LocalConnectionId blk
nk
                         IO (Int -> Rational -> (Int, Int, Rational))
-> IO Int -> IO (Rational -> (Int, Int, Rational))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (ExtLedgerState blk -> Int)
-> NodeKernel IO RemoteConnectionId LocalConnectionId blk -> IO Int
forall blk a.
IsLedger (LedgerState blk) =>
(ExtLedgerState blk -> a)
-> NodeKernel IO RemoteConnectionId LocalConnectionId blk -> IO a
nkQueryLedger (LedgerState blk -> Int
forall blk. LedgerQueries blk => LedgerState blk -> Int
ledgerDelegMapSize (LedgerState blk -> Int)
-> (ExtLedgerState blk -> LedgerState blk)
-> ExtLedgerState blk
-> Int
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ExtLedgerState blk -> LedgerState blk
forall blk. ExtLedgerState blk -> LedgerState blk
ledgerState) NodeKernel IO RemoteConnectionId LocalConnectionId blk
nk
                         IO (Rational -> (Int, Int, Rational))
-> IO Rational -> IO (Int, Int, Rational)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (AnchoredFragment (Header blk) -> Rational)
-> NodeKernel IO RemoteConnectionId LocalConnectionId blk
-> IO Rational
forall blk a.
(AnchoredFragment (Header blk) -> a)
-> NodeKernel IO RemoteConnectionId LocalConnectionId blk -> IO a
nkQueryChain AnchoredFragment (Header blk) -> Rational
forall blk.
HasHeader (Header blk) =>
AnchoredFragment (Header blk) -> Rational
fragmentChainDensity NodeKernel IO RemoteConnectionId LocalConnectionId blk
nk)
                    NodeKernelData blk
nodeKern
        LOMeta
meta <- Severity -> PrivacyAnnotation -> IO LOMeta
forall (m :: * -> *).
MonadIO m =>
Severity -> PrivacyAnnotation -> m LOMeta
mkLOMeta Severity
sev PrivacyAnnotation
Public
        IO () -> StrictMaybe (IO ()) -> IO ()
forall a. a -> StrictMaybe a -> a
fromSMaybe (() -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (StrictMaybe (IO ()) -> IO ()) -> StrictMaybe (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
          StrictMaybe (Int, Int, Rational)
query StrictMaybe (Int, Int, Rational)
-> ((Int, Int, Rational) -> IO ()) -> StrictMaybe (IO ())
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&>
            \(Int
utxoSize, Int
delegMapSize, Rational
_) -> do
                Text -> Trace IO Text -> Int -> IO ()
traceCounter Text
"utxoSize"     Trace IO Text
tr Int
utxoSize
                Text -> Trace IO Text -> Int -> IO ()
traceCounter Text
"delegMapSize" Trace IO Text
tr Int
delegMapSize
        Trace IO Text -> (LOMeta, LOContent Text) -> IO ()
forall (m :: * -> *) a.
MonadIO m =>
Trace m a -> (LOMeta, LOContent a) -> m ()
traceNamedObject (Text -> Trace IO Text -> Trace IO Text
forall (m :: * -> *) a. Text -> Trace m a -> Trace m a
appendName Text
"LeadershipCheck" Trace IO Text
tr)
          ( LOMeta
meta
          , Object -> LOContent Text
forall a. Object -> LOContent a
LogStructured (Object -> LOContent Text) -> Object -> LOContent Text
forall a b. (a -> b) -> a -> b
$ [(Text, Value)] -> Object
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
Map.fromList ([(Text, Value)] -> Object) -> [(Text, Value)] -> Object
forall a b. (a -> b) -> a -> b
$
            [(Text
"kind", Text -> Value
String Text
"TraceStartLeadershipCheck")
            ,(Text
"credentials", Text -> Value
String Text
creds)
            ,(Text
"slot", Word64 -> Value
forall a. ToJSON a => a -> Value
toJSON (Word64 -> Value) -> Word64 -> Value
forall a b. (a -> b) -> a -> b
$ SlotNo -> Word64
unSlotNo SlotNo
slot)]
            [(Text, Value)] -> [(Text, Value)] -> [(Text, Value)]
forall a. [a] -> [a] -> [a]
++ [(Text, Value)] -> StrictMaybe [(Text, Value)] -> [(Text, Value)]
forall a. a -> StrictMaybe a -> a
fromSMaybe []
               (StrictMaybe (Int, Int, Rational)
query StrictMaybe (Int, Int, Rational)
-> ((Int, Int, Rational) -> [(Text, Value)])
-> StrictMaybe [(Text, Value)]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&>
                 \(Int
utxoSize, Int
delegMapSize, Rational
chainDensity) ->
                   [ (Text
"utxoSize",     Int -> Value
forall a. ToJSON a => a -> Value
toJSON Int
utxoSize)
                   , (Text
"delegMapSize", Int -> Value
forall a. ToJSON a => a -> Value
toJSON Int
delegMapSize)
                   , (Text
"chainDensity", Float -> Value
forall a. ToJSON a => a -> Value
toJSON (Rational -> Float
forall a. Fractional a => Rational -> a
fromRational Rational
chainDensity :: Float))
                   ])
          )
      TraceForgeEvent blk
_ -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

teeForge ::
  forall blk
  . ( Consensus.RunNode blk
     , ToObject (CannotForge blk)
     , ToObject (LedgerErr (LedgerState blk))
     , ToObject (OtherHeaderEnvelopeError blk)
     , ToObject (ValidationErr (BlockProtocol blk))
     , ToObject (ForgeStateUpdateError blk)
     )
  => ForgeTracers
  -> TracingVerbosity
  -> Trace IO Text
  -> Tracer IO (WithSeverity (Consensus.TraceLabelCreds (Consensus.TraceForgeEvent blk)))
teeForge :: ForgeTracers
-> TracingVerbosity
-> Trace IO Text
-> Tracer IO (WithSeverity (TraceLabelCreds (TraceForgeEvent blk)))
teeForge ForgeTracers
ft TracingVerbosity
tverb Trace IO Text
tr = (WithSeverity (TraceLabelCreds (TraceForgeEvent blk)) -> IO ())
-> Tracer IO (WithSeverity (TraceLabelCreds (TraceForgeEvent blk)))
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer ((WithSeverity (TraceLabelCreds (TraceForgeEvent blk)) -> IO ())
 -> Tracer
      IO (WithSeverity (TraceLabelCreds (TraceForgeEvent blk))))
-> (WithSeverity (TraceLabelCreds (TraceForgeEvent blk)) -> IO ())
-> Tracer IO (WithSeverity (TraceLabelCreds (TraceForgeEvent blk)))
forall a b. (a -> b) -> a -> b
$
 \ev :: WithSeverity (TraceLabelCreds (TraceForgeEvent blk))
ev@(WithSeverity Severity
sev (Consensus.TraceLabelCreds Text
_creds TraceForgeEvent blk
event)) -> do
  (Tracer IO (WithSeverity (TraceForgeEvent blk))
 -> WithSeverity (TraceForgeEvent blk) -> IO ())
-> WithSeverity (TraceForgeEvent blk)
-> Tracer IO (WithSeverity (TraceForgeEvent blk))
-> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Tracer IO (WithSeverity (TraceForgeEvent blk))
-> WithSeverity (TraceForgeEvent blk) -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith (Severity
-> TraceForgeEvent blk -> WithSeverity (TraceForgeEvent blk)
forall a. Severity -> a -> WithSeverity a
WithSeverity Severity
sev TraceForgeEvent blk
event) (Tracer IO (WithSeverity (TraceForgeEvent blk)) -> IO ())
-> Tracer IO (WithSeverity (TraceForgeEvent blk)) -> IO ()
forall a b. (a -> b) -> a -> b
$ (WithSeverity (TraceForgeEvent blk)
 -> Tracer IO (WithSeverity (TraceForgeEvent blk)))
-> Tracer IO (WithSeverity (TraceForgeEvent blk))
forall (m :: * -> *) a. (a -> Tracer m a) -> Tracer m a
fanning ((WithSeverity (TraceForgeEvent blk)
  -> Tracer IO (WithSeverity (TraceForgeEvent blk)))
 -> Tracer IO (WithSeverity (TraceForgeEvent blk)))
-> (WithSeverity (TraceForgeEvent blk)
    -> Tracer IO (WithSeverity (TraceForgeEvent blk)))
-> Tracer IO (WithSeverity (TraceForgeEvent blk))
forall a b. (a -> b) -> a -> b
$ \(WithSeverity Severity
_ TraceForgeEvent blk
e) ->
    case TraceForgeEvent blk
e of
      Consensus.TraceStartLeadershipCheck{} -> Trace IO Text -> Tracer IO (WithSeverity (TraceForgeEvent blk))
forall blk.
Trace IO Text -> Tracer IO (WithSeverity (TraceForgeEvent blk))
teeForge' (ForgeTracers -> Trace IO Text
ftForgeAboutToLead ForgeTracers
ft)
      Consensus.TraceSlotIsImmutable{} -> Trace IO Text -> Tracer IO (WithSeverity (TraceForgeEvent blk))
forall blk.
Trace IO Text -> Tracer IO (WithSeverity (TraceForgeEvent blk))
teeForge' (ForgeTracers -> Trace IO Text
ftTraceSlotIsImmutable ForgeTracers
ft)
      Consensus.TraceBlockFromFuture{} -> Trace IO Text -> Tracer IO (WithSeverity (TraceForgeEvent blk))
forall blk.
Trace IO Text -> Tracer IO (WithSeverity (TraceForgeEvent blk))
teeForge' (ForgeTracers -> Trace IO Text
ftTraceBlockFromFuture ForgeTracers
ft)
      Consensus.TraceBlockContext{} -> Tracer IO (WithSeverity (TraceForgeEvent blk))
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
      Consensus.TraceNoLedgerState{} -> Trace IO Text -> Tracer IO (WithSeverity (TraceForgeEvent blk))
forall blk.
Trace IO Text -> Tracer IO (WithSeverity (TraceForgeEvent blk))
teeForge' (ForgeTracers -> Trace IO Text
ftCouldNotForge ForgeTracers
ft)
      Consensus.TraceLedgerState{} -> Tracer IO (WithSeverity (TraceForgeEvent blk))
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
      Consensus.TraceNoLedgerView{} -> Trace IO Text -> Tracer IO (WithSeverity (TraceForgeEvent blk))
forall blk.
Trace IO Text -> Tracer IO (WithSeverity (TraceForgeEvent blk))
teeForge' (ForgeTracers -> Trace IO Text
ftCouldNotForge ForgeTracers
ft)
      Consensus.TraceLedgerView{} -> Tracer IO (WithSeverity (TraceForgeEvent blk))
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
      Consensus.TraceForgeStateUpdateError{} -> Trace IO Text -> Tracer IO (WithSeverity (TraceForgeEvent blk))
forall blk.
Trace IO Text -> Tracer IO (WithSeverity (TraceForgeEvent blk))
teeForge' (ForgeTracers -> Trace IO Text
ftTraceForgeStateUpdateError ForgeTracers
ft)
      Consensus.TraceNodeCannotForge {} -> Trace IO Text -> Tracer IO (WithSeverity (TraceForgeEvent blk))
forall blk.
Trace IO Text -> Tracer IO (WithSeverity (TraceForgeEvent blk))
teeForge' (ForgeTracers -> Trace IO Text
ftTraceNodeCannotForge ForgeTracers
ft)
      Consensus.TraceNodeNotLeader{} -> Trace IO Text -> Tracer IO (WithSeverity (TraceForgeEvent blk))
forall blk.
Trace IO Text -> Tracer IO (WithSeverity (TraceForgeEvent blk))
teeForge' (ForgeTracers -> Trace IO Text
ftTraceNodeNotLeader ForgeTracers
ft)
      Consensus.TraceNodeIsLeader{} -> Trace IO Text -> Tracer IO (WithSeverity (TraceForgeEvent blk))
forall blk.
Trace IO Text -> Tracer IO (WithSeverity (TraceForgeEvent blk))
teeForge' (ForgeTracers -> Trace IO Text
ftTraceNodeIsLeader ForgeTracers
ft)
      Consensus.TraceForgedBlock{} -> Trace IO Text -> Tracer IO (WithSeverity (TraceForgeEvent blk))
forall blk.
Trace IO Text -> Tracer IO (WithSeverity (TraceForgeEvent blk))
teeForge' (ForgeTracers -> Trace IO Text
ftForged ForgeTracers
ft)
      Consensus.TraceDidntAdoptBlock{} -> Trace IO Text -> Tracer IO (WithSeverity (TraceForgeEvent blk))
forall blk.
Trace IO Text -> Tracer IO (WithSeverity (TraceForgeEvent blk))
teeForge' (ForgeTracers -> Trace IO Text
ftDidntAdoptBlock ForgeTracers
ft)
      Consensus.TraceForgedInvalidBlock{} -> Trace IO Text -> Tracer IO (WithSeverity (TraceForgeEvent blk))
forall blk.
Trace IO Text -> Tracer IO (WithSeverity (TraceForgeEvent blk))
teeForge' (ForgeTracers -> Trace IO Text
ftForgedInvalid ForgeTracers
ft)
      Consensus.TraceAdoptedBlock{} -> Trace IO Text -> Tracer IO (WithSeverity (TraceForgeEvent blk))
forall blk.
Trace IO Text -> Tracer IO (WithSeverity (TraceForgeEvent blk))
teeForge' (ForgeTracers -> Trace IO Text
ftAdopted ForgeTracers
ft)
  case TraceForgeEvent blk
event of
    Consensus.TraceStartLeadershipCheck SlotNo
_slot -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    TraceForgeEvent blk
_ -> Tracer IO (WithSeverity (TraceLabelCreds (TraceForgeEvent blk)))
-> WithSeverity (TraceLabelCreds (TraceForgeEvent blk)) -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith (TracingVerbosity
-> Trace IO Text
-> Tracer IO (WithSeverity (TraceLabelCreds (TraceForgeEvent blk)))
forall (m :: * -> *) a b.
(ToLogObject m, ToObject a, Transformable a m b) =>
TracingVerbosity -> Trace m a -> Tracer m b
toLogObject' TracingVerbosity
tverb Trace IO Text
tr) WithSeverity (TraceLabelCreds (TraceForgeEvent blk))
ev

teeForge'
  :: Trace IO Text
  -> Tracer IO (WithSeverity (Consensus.TraceForgeEvent blk))
teeForge' :: Trace IO Text -> Tracer IO (WithSeverity (TraceForgeEvent blk))
teeForge' Trace IO Text
tr =
  (WithSeverity (TraceForgeEvent blk) -> IO ())
-> Tracer IO (WithSeverity (TraceForgeEvent blk))
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer ((WithSeverity (TraceForgeEvent blk) -> IO ())
 -> Tracer IO (WithSeverity (TraceForgeEvent blk)))
-> (WithSeverity (TraceForgeEvent blk) -> IO ())
-> Tracer IO (WithSeverity (TraceForgeEvent blk))
forall a b. (a -> b) -> a -> b
$ \(WithSeverity Severity
_ TraceForgeEvent blk
ev) -> do
    LOMeta
meta <- Severity -> PrivacyAnnotation -> IO LOMeta
forall (m :: * -> *).
MonadIO m =>
Severity -> PrivacyAnnotation -> m LOMeta
mkLOMeta Severity
Critical PrivacyAnnotation
Confidential
    Trace IO Text -> (LOMeta, LOContent Text) -> IO ()
forall (m :: * -> *) a.
MonadIO m =>
Trace m a -> (LOMeta, LOContent a) -> m ()
traceNamedObject (Text -> Trace IO Text -> Trace IO Text
forall (m :: * -> *) a. Text -> Trace m a -> Trace m a
appendName Text
"metrics" Trace IO Text
tr) ((LOMeta, LOContent Text) -> IO ())
-> (LOContent Text -> (LOMeta, LOContent Text))
-> LOContent Text
-> IO ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (LOMeta
meta,) (LOContent Text -> IO ()) -> LOContent Text -> IO ()
forall a b. (a -> b) -> a -> b
$
      case TraceForgeEvent blk
ev of
        Consensus.TraceStartLeadershipCheck SlotNo
slot ->
          Text -> Measurable -> LOContent Text
forall a. Text -> Measurable -> LOContent a
LogValue Text
"aboutToLeadSlotLast" (Measurable -> LOContent Text) -> Measurable -> LOContent Text
forall a b. (a -> b) -> a -> b
$ Integer -> Measurable
PureI (Integer -> Measurable) -> Integer -> Measurable
forall a b. (a -> b) -> a -> b
$ 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
        Consensus.TraceSlotIsImmutable SlotNo
slot Point blk
_tipPoint BlockNo
_tipBlkNo ->
          Text -> Measurable -> LOContent Text
forall a. Text -> Measurable -> LOContent a
LogValue Text
"slotIsImmutable" (Measurable -> LOContent Text) -> Measurable -> LOContent Text
forall a b. (a -> b) -> a -> b
$ Integer -> Measurable
PureI (Integer -> Measurable) -> Integer -> Measurable
forall a b. (a -> b) -> a -> b
$ 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
        Consensus.TraceBlockFromFuture SlotNo
slot SlotNo
_slotNo ->
          Text -> Measurable -> LOContent Text
forall a. Text -> Measurable -> LOContent a
LogValue Text
"blockFromFuture" (Measurable -> LOContent Text) -> Measurable -> LOContent Text
forall a b. (a -> b) -> a -> b
$ Integer -> Measurable
PureI (Integer -> Measurable) -> Integer -> Measurable
forall a b. (a -> b) -> a -> b
$ 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
        Consensus.TraceBlockContext SlotNo
slot BlockNo
_tipBlkNo Point blk
_tipPoint ->
          Text -> Measurable -> LOContent Text
forall a. Text -> Measurable -> LOContent a
LogValue Text
"blockContext" (Measurable -> LOContent Text) -> Measurable -> LOContent Text
forall a b. (a -> b) -> a -> b
$ Integer -> Measurable
PureI (Integer -> Measurable) -> Integer -> Measurable
forall a b. (a -> b) -> a -> b
$ 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
        Consensus.TraceNoLedgerState SlotNo
slot Point blk
_ ->
          Text -> Measurable -> LOContent Text
forall a. Text -> Measurable -> LOContent a
LogValue Text
"couldNotForgeSlotLast" (Measurable -> LOContent Text) -> Measurable -> LOContent Text
forall a b. (a -> b) -> a -> b
$ Integer -> Measurable
PureI (Integer -> Measurable) -> Integer -> Measurable
forall a b. (a -> b) -> a -> b
$ 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
        Consensus.TraceLedgerState SlotNo
slot Point blk
_ ->
          Text -> Measurable -> LOContent Text
forall a. Text -> Measurable -> LOContent a
LogValue Text
"ledgerState" (Measurable -> LOContent Text) -> Measurable -> LOContent Text
forall a b. (a -> b) -> a -> b
$ Integer -> Measurable
PureI (Integer -> Measurable) -> Integer -> Measurable
forall a b. (a -> b) -> a -> b
$ 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
        Consensus.TraceNoLedgerView SlotNo
slot OutsideForecastRange
_ ->
          Text -> Measurable -> LOContent Text
forall a. Text -> Measurable -> LOContent a
LogValue Text
"couldNotForgeSlotLast" (Measurable -> LOContent Text) -> Measurable -> LOContent Text
forall a b. (a -> b) -> a -> b
$ Integer -> Measurable
PureI (Integer -> Measurable) -> Integer -> Measurable
forall a b. (a -> b) -> a -> b
$ 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
        Consensus.TraceLedgerView SlotNo
slot ->
          Text -> Measurable -> LOContent Text
forall a. Text -> Measurable -> LOContent a
LogValue Text
"ledgerView" (Measurable -> LOContent Text) -> Measurable -> LOContent Text
forall a b. (a -> b) -> a -> b
$ Integer -> Measurable
PureI (Integer -> Measurable) -> Integer -> Measurable
forall a b. (a -> b) -> a -> b
$ 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
        Consensus.TraceForgeStateUpdateError SlotNo
slot ForgeStateUpdateError blk
_reason ->
          Text -> Measurable -> LOContent Text
forall a. Text -> Measurable -> LOContent a
LogValue Text
"forgeStateUpdateError" (Measurable -> LOContent Text) -> Measurable -> LOContent Text
forall a b. (a -> b) -> a -> b
$ Integer -> Measurable
PureI (Integer -> Measurable) -> Integer -> Measurable
forall a b. (a -> b) -> a -> b
$ 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
        Consensus.TraceNodeCannotForge SlotNo
slot CannotForge blk
_reason ->
          Text -> Measurable -> LOContent Text
forall a. Text -> Measurable -> LOContent a
LogValue Text
"nodeCannotForge" (Measurable -> LOContent Text) -> Measurable -> LOContent Text
forall a b. (a -> b) -> a -> b
$ Integer -> Measurable
PureI (Integer -> Measurable) -> Integer -> Measurable
forall a b. (a -> b) -> a -> b
$ 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
        Consensus.TraceNodeNotLeader SlotNo
slot ->
          Text -> Measurable -> LOContent Text
forall a. Text -> Measurable -> LOContent a
LogValue Text
"nodeNotLeader" (Measurable -> LOContent Text) -> Measurable -> LOContent Text
forall a b. (a -> b) -> a -> b
$ Integer -> Measurable
PureI (Integer -> Measurable) -> Integer -> Measurable
forall a b. (a -> b) -> a -> b
$ 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
        Consensus.TraceNodeIsLeader SlotNo
slot ->
          Text -> Measurable -> LOContent Text
forall a. Text -> Measurable -> LOContent a
LogValue Text
"nodeIsLeader" (Measurable -> LOContent Text) -> Measurable -> LOContent Text
forall a b. (a -> b) -> a -> b
$ Integer -> Measurable
PureI (Integer -> Measurable) -> Integer -> Measurable
forall a b. (a -> b) -> a -> b
$ 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
        Consensus.TraceForgedBlock SlotNo
slot Point blk
_ blk
_ MempoolSize
_ ->
          Text -> Measurable -> LOContent Text
forall a. Text -> Measurable -> LOContent a
LogValue Text
"forgedSlotLast" (Measurable -> LOContent Text) -> Measurable -> LOContent Text
forall a b. (a -> b) -> a -> b
$ Integer -> Measurable
PureI (Integer -> Measurable) -> Integer -> Measurable
forall a b. (a -> b) -> a -> b
$ 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
        Consensus.TraceDidntAdoptBlock SlotNo
slot blk
_ ->
          Text -> Measurable -> LOContent Text
forall a. Text -> Measurable -> LOContent a
LogValue Text
"notAdoptedSlotLast" (Measurable -> LOContent Text) -> Measurable -> LOContent Text
forall a b. (a -> b) -> a -> b
$ Integer -> Measurable
PureI (Integer -> Measurable) -> Integer -> Measurable
forall a b. (a -> b) -> a -> b
$ 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
        Consensus.TraceForgedInvalidBlock SlotNo
slot blk
_ InvalidBlockReason blk
_ ->
          Text -> Measurable -> LOContent Text
forall a. Text -> Measurable -> LOContent a
LogValue Text
"forgedInvalidSlotLast" (Measurable -> LOContent Text) -> Measurable -> LOContent Text
forall a b. (a -> b) -> a -> b
$ Integer -> Measurable
PureI (Integer -> Measurable) -> Integer -> Measurable
forall a b. (a -> b) -> a -> b
$ 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
        Consensus.TraceAdoptedBlock SlotNo
slot blk
_ [Validated (GenTx blk)]
_ ->
          Text -> Measurable -> LOContent Text
forall a. Text -> Measurable -> LOContent a
LogValue Text
"adoptedSlotLast" (Measurable -> LOContent Text) -> Measurable -> LOContent Text
forall a b. (a -> b) -> a -> b
$ Integer -> Measurable
PureI (Integer -> Measurable) -> Integer -> Measurable
forall a b. (a -> b) -> a -> b
$ 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

forgeTracer
  :: forall blk.
     ( Consensus.RunNode blk
     , ToObject (CannotForge blk)
     , ToObject (LedgerErr (LedgerState blk))
     , ToObject (OtherHeaderEnvelopeError blk)
     , ToObject (ValidationErr (BlockProtocol blk))
     , ToObject (ForgeStateUpdateError blk)
     , HasKESInfo blk
     )
  => TracingVerbosity
  -> Trace IO Text
  -> ForgeTracers
  -> ForgingStats
  -> Tracer IO (Consensus.TraceLabelCreds (Consensus.TraceForgeEvent blk))
forgeTracer :: TracingVerbosity
-> Trace IO Text
-> ForgeTracers
-> ForgingStats
-> Tracer IO (TraceLabelCreds (TraceForgeEvent blk))
forgeTracer TracingVerbosity
verb Trace IO Text
tr ForgeTracers
forgeTracers ForgingStats
fStats =
  (TraceLabelCreds (TraceForgeEvent blk) -> IO ())
-> Tracer IO (TraceLabelCreds (TraceForgeEvent blk))
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer ((TraceLabelCreds (TraceForgeEvent blk) -> IO ())
 -> Tracer IO (TraceLabelCreds (TraceForgeEvent blk)))
-> (TraceLabelCreds (TraceForgeEvent blk) -> IO ())
-> Tracer IO (TraceLabelCreds (TraceForgeEvent blk))
forall a b. (a -> b) -> a -> b
$ \tlcev :: TraceLabelCreds (TraceForgeEvent blk)
tlcev@(Consensus.TraceLabelCreds Text
_ TraceForgeEvent blk
ev) -> do
    -- Ignoring the credentials label for measurement and counters:
    Tracer IO (TraceForgeEvent blk) -> TraceForgeEvent blk -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith (ForgingStats -> Trace IO Text -> Tracer IO (TraceForgeEvent blk)
forall blk.
ForgingStats -> Trace IO Text -> Tracer IO (TraceForgeEvent blk)
notifyBlockForging ForgingStats
fStats Trace IO Text
tr) TraceForgeEvent blk
ev
    -- Consensus tracer -- here we track the label:
    Tracer IO (TraceLabelCreds (TraceForgeEvent blk))
-> TraceLabelCreds (TraceForgeEvent blk) -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith (Tracer IO (WithSeverity (TraceLabelCreds (TraceForgeEvent blk)))
-> Tracer IO (TraceLabelCreds (TraceForgeEvent blk))
forall a (m :: * -> *).
HasSeverityAnnotation a =>
Tracer m (WithSeverity a) -> Tracer m a
annotateSeverity
                 (Tracer IO (WithSeverity (TraceLabelCreds (TraceForgeEvent blk)))
 -> Tracer IO (TraceLabelCreds (TraceForgeEvent blk)))
-> Tracer IO (WithSeverity (TraceLabelCreds (TraceForgeEvent blk)))
-> Tracer IO (TraceLabelCreds (TraceForgeEvent blk))
forall a b. (a -> b) -> a -> b
$ ForgeTracers
-> TracingVerbosity
-> Trace IO Text
-> Tracer IO (WithSeverity (TraceLabelCreds (TraceForgeEvent blk)))
forall blk.
(RunNode blk, ToObject (CannotForge blk),
 ToObject (LedgerErr (LedgerState blk)),
 ToObject (OtherHeaderEnvelopeError blk),
 ToObject (ValidationErr (BlockProtocol blk)),
 ToObject (ForgeStateUpdateError blk)) =>
ForgeTracers
-> TracingVerbosity
-> Trace IO Text
-> Tracer IO (WithSeverity (TraceLabelCreds (TraceForgeEvent blk)))
teeForge ForgeTracers
forgeTracers TracingVerbosity
verb
                 (Trace IO Text
 -> Tracer
      IO (WithSeverity (TraceLabelCreds (TraceForgeEvent blk))))
-> Trace IO Text
-> Tracer IO (WithSeverity (TraceLabelCreds (TraceForgeEvent blk)))
forall a b. (a -> b) -> a -> b
$ Text -> Trace IO Text -> Trace IO Text
forall (m :: * -> *) a. Text -> Trace m a -> Trace m a
appendName Text
"Forge" Trace IO Text
tr) TraceLabelCreds (TraceForgeEvent blk)
tlcev
    TraceForgeEvent blk -> IO ()
traceKESInfoIfKESExpired TraceForgeEvent blk
ev
 where
  traceKESInfoIfKESExpired :: TraceForgeEvent blk -> IO ()
traceKESInfoIfKESExpired TraceForgeEvent blk
ev =
    case TraceForgeEvent blk
ev of
      Consensus.TraceForgeStateUpdateError SlotNo
_ ForgeStateUpdateError blk
reason ->
        -- KES-key cannot be evolved, but anyway trace KES-values.
        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 -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          Just KESInfo
kesInfo -> do
            let logValues :: [LOContent a]
                logValues :: [LOContent a]
logValues =
                  [ Text -> Measurable -> LOContent a
forall a. Text -> Measurable -> LOContent a
LogValue Text
"operationalCertificateStartKESPeriod"
                      (Measurable -> LOContent a) -> Measurable -> LOContent a
forall a b. (a -> b) -> a -> b
$ Integer -> Measurable
PureI (Integer -> Measurable)
-> (KESInfo -> Integer) -> KESInfo -> Measurable
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. 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 -> Measurable) -> KESInfo -> Measurable
forall a b. (a -> b) -> a -> b
$ KESInfo
kesInfo
                  , Text -> Measurable -> LOContent a
forall a. Text -> Measurable -> LOContent a
LogValue Text
"operationalCertificateExpiryKESPeriod"
                      (Measurable -> LOContent a) -> Measurable -> LOContent a
forall a b. (a -> b) -> a -> b
$ Integer -> Measurable
PureI (Integer -> Measurable)
-> (KESInfo -> Integer) -> KESInfo -> Measurable
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. 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 -> Measurable) -> KESInfo -> Measurable
forall a b. (a -> b) -> a -> b
$ KESInfo
kesInfo
                  , Text -> Measurable -> LOContent a
forall a. Text -> Measurable -> LOContent a
LogValue Text
"currentKESPeriod"
                      (Measurable -> LOContent a) -> Measurable -> LOContent a
forall a b. (a -> b) -> a -> b
$ Integer -> Measurable
PureI Integer
0
                  , Text -> Measurable -> LOContent a
forall a. Text -> Measurable -> LOContent a
LogValue Text
"remainingKESPeriods"
                      (Measurable -> LOContent a) -> Measurable -> LOContent a
forall a b. (a -> b) -> a -> b
$ Integer -> Measurable
PureI Integer
0
                  ]
            LOMeta
meta <- Severity -> PrivacyAnnotation -> IO LOMeta
forall (m :: * -> *).
MonadIO m =>
Severity -> PrivacyAnnotation -> m LOMeta
mkLOMeta Severity
Critical PrivacyAnnotation
Confidential
            (LOContent Text -> IO ()) -> [LOContent Text] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Trace IO Text -> (LOMeta, LOContent Text) -> IO ()
forall (m :: * -> *) a.
MonadIO m =>
Trace m a -> (LOMeta, LOContent a) -> m ()
traceNamedObject (Text -> Trace IO Text -> Trace IO Text
forall (m :: * -> *) a. Text -> Trace m a -> Trace m a
appendName Text
"metrics" Trace IO Text
tr) ((LOMeta, LOContent Text) -> IO ())
-> (LOContent Text -> (LOMeta, LOContent Text))
-> LOContent Text
-> IO ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (LOMeta
meta,)) [LOContent Text]
forall a. [LOContent a]
logValues
      TraceForgeEvent blk
_ -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

notifyBlockForging
  :: ForgingStats
  -> Trace IO Text
  -> Tracer IO (Consensus.TraceForgeEvent blk)
notifyBlockForging :: ForgingStats -> Trace IO Text -> Tracer IO (TraceForgeEvent blk)
notifyBlockForging ForgingStats
fStats Trace IO Text
tr = (TraceForgeEvent blk -> IO ()) -> Tracer IO (TraceForgeEvent blk)
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer ((TraceForgeEvent blk -> IO ()) -> Tracer IO (TraceForgeEvent blk))
-> (TraceForgeEvent blk -> IO ())
-> Tracer IO (TraceForgeEvent blk)
forall a b. (a -> b) -> a -> b
$ \case
  Consensus.TraceNodeCannotForge {} ->
    Text -> Trace IO Text -> Int -> IO ()
traceCounter Text
"nodeCannotForge" Trace IO Text
tr
      (Int -> IO ()) -> IO Int -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ForgingStats
-> (ForgeThreadStats -> (ForgeThreadStats, Int)) -> IO Int
forall a.
ForgingStats -> (ForgeThreadStats -> (ForgeThreadStats, a)) -> IO a
mapForgingCurrentThreadStats ForgingStats
fStats
            (\ForgeThreadStats
fts -> (ForgeThreadStats
fts { ftsNodeCannotForgeNum :: Int
ftsNodeCannotForgeNum = ForgeThreadStats -> Int
ftsNodeCannotForgeNum ForgeThreadStats
fts Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 },
                       ForgeThreadStats -> Int
ftsNodeCannotForgeNum ForgeThreadStats
fts Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1))
  (Consensus.TraceNodeIsLeader (SlotNo Word64
slot')) -> do
    let slot :: Int
slot = Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
slot'
    Text -> Trace IO Text -> Int -> IO ()
traceCounter Text
"nodeIsLeaderNum" Trace IO Text
tr
      (Int -> IO ()) -> IO Int -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ForgingStats
-> (ForgeThreadStats -> (ForgeThreadStats, Int)) -> IO Int
forall a.
ForgingStats -> (ForgeThreadStats -> (ForgeThreadStats, a)) -> IO a
mapForgingCurrentThreadStats ForgingStats
fStats
            (\ForgeThreadStats
fts -> (ForgeThreadStats
fts { ftsNodeIsLeaderNum :: Int
ftsNodeIsLeaderNum = ForgeThreadStats -> Int
ftsNodeIsLeaderNum ForgeThreadStats
fts Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
                          , ftsLastSlot :: Int
ftsLastSlot = Int
slot },
                      ForgeThreadStats -> Int
ftsNodeIsLeaderNum ForgeThreadStats
fts Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1))
  Consensus.TraceForgedBlock {} -> do
    Text -> Trace IO Text -> Int -> IO ()
traceCounter Text
"blocksForgedNum" Trace IO Text
tr
      (Int -> IO ()) -> IO Int -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ForgingStats
-> (ForgeThreadStats -> (ForgeThreadStats, Int)) -> IO Int
forall a.
ForgingStats -> (ForgeThreadStats -> (ForgeThreadStats, a)) -> IO a
mapForgingCurrentThreadStats ForgingStats
fStats
            (\ForgeThreadStats
fts -> (ForgeThreadStats
fts { ftsBlocksForgedNum :: Int
ftsBlocksForgedNum = ForgeThreadStats -> Int
ftsBlocksForgedNum ForgeThreadStats
fts Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 },
                       ForgeThreadStats -> Int
ftsBlocksForgedNum ForgeThreadStats
fts Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1))

  Consensus.TraceNodeNotLeader (SlotNo Word64
slot') -> do
    -- Not is not a leader again, so now the number of blocks forged by this node
    -- should be equal to the number of slots when this node was a leader.
    let slot :: Int
slot = Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
slot'
    Bool
hasMissed <-
      ForgingStats
-> (ForgeThreadStats -> (ForgeThreadStats, Bool)) -> IO Bool
forall a.
ForgingStats -> (ForgeThreadStats -> (ForgeThreadStats, a)) -> IO a
mapForgingCurrentThreadStats ForgingStats
fStats
        (\ForgeThreadStats
fts ->
          if ForgeThreadStats -> Int
ftsLastSlot ForgeThreadStats
fts Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
|| Int -> Int
forall a. Enum a => a -> a
succ (ForgeThreadStats -> Int
ftsLastSlot ForgeThreadStats
fts) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
slot then
            (ForgeThreadStats
fts { ftsLastSlot :: Int
ftsLastSlot = Int
slot }, Bool
False)
          else
            let missed :: Int
missed = ForgeThreadStats -> Int
ftsSlotsMissedNum ForgeThreadStats
fts Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int
slot Int -> Int -> Int
forall a. Num a => a -> a -> a
- ForgeThreadStats -> Int
ftsLastSlot ForgeThreadStats
fts)
            in (ForgeThreadStats
fts { ftsLastSlot :: Int
ftsLastSlot = Int
slot, ftsSlotsMissedNum :: Int
ftsSlotsMissedNum = Int
missed }, Bool
True))
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
hasMissed (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      Int
x <- [Int] -> Int
forall (f :: * -> *) a. (Foldable f, Num a) => f a -> a
sum ([Int] -> Int) -> IO [Int] -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ForgingStats -> (ForgeThreadStats -> Int) -> IO [Int]
forall a. ForgingStats -> (ForgeThreadStats -> a) -> IO [a]
threadStatsProjection ForgingStats
fStats ForgeThreadStats -> Int
ftsSlotsMissedNum
      Text -> Trace IO Text -> Int -> IO ()
traceCounter Text
"slotsMissedNum" Trace IO Text
tr Int
x
  TraceForgeEvent blk
_ -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()


--------------------------------------------------------------------------------
-- Mempool Tracers
--------------------------------------------------------------------------------

notifyTxsProcessed :: ForgingStats -> Trace IO Text -> Tracer IO (TraceEventMempool blk)
notifyTxsProcessed :: ForgingStats -> Trace IO Text -> Tracer IO (TraceEventMempool blk)
notifyTxsProcessed ForgingStats
fStats Trace IO Text
tr = (TraceEventMempool blk -> IO ())
-> Tracer IO (TraceEventMempool blk)
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer ((TraceEventMempool blk -> IO ())
 -> Tracer IO (TraceEventMempool blk))
-> (TraceEventMempool blk -> IO ())
-> Tracer IO (TraceEventMempool blk)
forall a b. (a -> b) -> a -> b
$ \case
  TraceMempoolRemoveTxs [] MempoolSize
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  TraceMempoolRemoveTxs [Validated (GenTx blk)]
txs MempoolSize
_ -> do
    -- TraceMempoolRemoveTxs are previously valid transactions that are no longer valid because of
    -- changes in the ledger state. These transactions are already removed from the mempool,
    -- so we can treat them as completely processed.
    Int
updatedTxProcessed <- ForgingStats -> (Int -> Int) -> IO Int
mapForgingStatsTxsProcessed ForgingStats
fStats (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ([Validated (GenTx blk)] -> Int
forall a. HasLength a => a -> Int
length [Validated (GenTx blk)]
txs))
    Text -> Trace IO Text -> Int -> IO ()
traceCounter Text
"txsProcessedNum" Trace IO Text
tr (Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
updatedTxProcessed)
  -- The rest of the constructors.
  TraceEventMempool blk
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()


mempoolMetricsTraceTransformer :: Trace IO a -> Tracer IO (TraceEventMempool blk)
mempoolMetricsTraceTransformer :: Trace IO a -> Tracer IO (TraceEventMempool blk)
mempoolMetricsTraceTransformer Trace IO a
tr = (TraceEventMempool blk -> IO ())
-> Tracer IO (TraceEventMempool blk)
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer ((TraceEventMempool blk -> IO ())
 -> Tracer IO (TraceEventMempool blk))
-> (TraceEventMempool blk -> IO ())
-> Tracer IO (TraceEventMempool blk)
forall a b. (a -> b) -> a -> b
$ \TraceEventMempool blk
mempoolEvent -> do
  let tr' :: Trace IO a
tr' = Text -> Trace IO a -> Trace IO a
forall (m :: * -> *) a. Text -> Trace m a -> Trace m a
appendName Text
"metrics" Trace IO a
tr
      (Int
_n, MempoolSize
tot) = case TraceEventMempool blk
mempoolEvent of
                    TraceMempoolAddedTx     Validated (GenTx blk)
_tx0 MempoolSize
_ MempoolSize
tot0 -> (Int
1, MempoolSize
tot0)
                    TraceMempoolRejectedTx  GenTx blk
_tx0 ApplyTxErr blk
_ MempoolSize
tot0 -> (Int
1, MempoolSize
tot0)
                    TraceMempoolRemoveTxs   [Validated (GenTx blk)]
txs0   MempoolSize
tot0 -> ([Validated (GenTx blk)] -> Int
forall a. HasLength a => a -> Int
length [Validated (GenTx blk)]
txs0, MempoolSize
tot0)
                    TraceMempoolManuallyRemovedTxs [GenTxId blk]
txs0 [Validated (GenTx blk)]
txs1 MempoolSize
tot0 -> ( [GenTxId blk] -> Int
forall a. HasLength a => a -> Int
length [GenTxId blk]
txs0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Validated (GenTx blk)] -> Int
forall a. HasLength a => a -> Int
length [Validated (GenTx blk)]
txs1, MempoolSize
tot0)
      logValue1 :: LOContent a
      logValue1 :: LOContent a
logValue1 = Text -> Measurable -> LOContent a
forall a. Text -> Measurable -> LOContent a
LogValue Text
"txsInMempool" (Measurable -> LOContent a) -> Measurable -> LOContent a
forall a b. (a -> b) -> a -> b
$ Integer -> Measurable
PureI (Integer -> Measurable) -> Integer -> Measurable
forall a b. (a -> b) -> a -> b
$ SizeInBytes -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (MempoolSize -> SizeInBytes
msNumTxs MempoolSize
tot)
      logValue2 :: LOContent a
      logValue2 :: LOContent a
logValue2 = Text -> Measurable -> LOContent a
forall a. Text -> Measurable -> LOContent a
LogValue Text
"mempoolBytes" (Measurable -> LOContent a) -> Measurable -> LOContent a
forall a b. (a -> b) -> a -> b
$ Integer -> Measurable
PureI (Integer -> Measurable) -> Integer -> Measurable
forall a b. (a -> b) -> a -> b
$ SizeInBytes -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (MempoolSize -> SizeInBytes
msNumBytes MempoolSize
tot)
  LOMeta
meta <- Severity -> PrivacyAnnotation -> IO LOMeta
forall (m :: * -> *).
MonadIO m =>
Severity -> PrivacyAnnotation -> m LOMeta
mkLOMeta Severity
Critical PrivacyAnnotation
Confidential
  Trace IO a -> (LOMeta, LOContent a) -> IO ()
forall (m :: * -> *) a.
MonadIO m =>
Trace m a -> (LOMeta, LOContent a) -> m ()
traceNamedObject Trace IO a
tr' (LOMeta
meta, LOContent a
forall a. LOContent a
logValue1)
  Trace IO a -> (LOMeta, LOContent a) -> IO ()
forall (m :: * -> *) a.
MonadIO m =>
Trace m a -> (LOMeta, LOContent a) -> m ()
traceNamedObject Trace IO a
tr' (LOMeta
meta, LOContent a
forall a. LOContent a
logValue2)

mempoolTracer
  :: ( ToJSON (GenTxId blk)
     , ToObject (ApplyTxErr blk)
     , ToObject (GenTx blk)
     , LedgerSupportsMempool blk
     )
  => TraceSelection
  -> Trace IO Text
  -> ForgingStats
  -> Tracer IO (TraceEventMempool blk)
mempoolTracer :: TraceSelection
-> Trace IO Text
-> ForgingStats
-> Tracer IO (TraceEventMempool blk)
mempoolTracer TraceSelection
tc Trace IO Text
tracer ForgingStats
fStats = (TraceEventMempool blk -> IO ())
-> Tracer IO (TraceEventMempool blk)
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer ((TraceEventMempool blk -> IO ())
 -> Tracer IO (TraceEventMempool blk))
-> (TraceEventMempool blk -> IO ())
-> Tracer IO (TraceEventMempool blk)
forall a b. (a -> b) -> a -> b
$ \TraceEventMempool blk
ev -> do
    Tracer IO (TraceEventMempool blk) -> TraceEventMempool blk -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith (Trace IO Text -> Tracer IO (TraceEventMempool blk)
forall a blk. Trace IO a -> Tracer IO (TraceEventMempool blk)
mempoolMetricsTraceTransformer Trace IO Text
tracer) TraceEventMempool blk
ev
    Tracer IO (TraceEventMempool blk) -> TraceEventMempool blk -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith (ForgingStats -> Trace IO Text -> Tracer IO (TraceEventMempool blk)
forall blk.
ForgingStats -> Trace IO Text -> Tracer IO (TraceEventMempool blk)
notifyTxsProcessed ForgingStats
fStats Trace IO Text
tracer) TraceEventMempool blk
ev
    let tr :: Trace IO Text
tr = Text -> Trace IO Text -> Trace IO Text
forall (m :: * -> *) a. Text -> Trace m a -> Trace m a
appendName Text
"Mempool" Trace IO Text
tracer
    Tracer IO (TraceEventMempool blk) -> TraceEventMempool blk -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith (TraceSelection
-> Trace IO Text -> Tracer IO (TraceEventMempool blk)
forall blk.
(ToJSON (GenTxId blk), ToObject (ApplyTxErr blk),
 ToObject (GenTx blk), LedgerSupportsMempool blk) =>
TraceSelection
-> Trace IO Text -> Tracer IO (TraceEventMempool blk)
mpTracer TraceSelection
tc Trace IO Text
tr) TraceEventMempool blk
ev

mpTracer :: ( ToJSON (GenTxId blk)
            , ToObject (ApplyTxErr blk)
            , ToObject (GenTx blk)
            , LedgerSupportsMempool blk
            )
         => TraceSelection -> Trace IO Text -> Tracer IO (TraceEventMempool blk)
mpTracer :: TraceSelection
-> Trace IO Text -> Tracer IO (TraceEventMempool blk)
mpTracer TraceSelection
tc Trace IO Text
tr = Tracer IO (WithSeverity (TraceEventMempool blk))
-> Tracer IO (TraceEventMempool blk)
forall a (m :: * -> *).
HasSeverityAnnotation a =>
Tracer m (WithSeverity a) -> Tracer m a
annotateSeverity (Tracer IO (WithSeverity (TraceEventMempool blk))
 -> Tracer IO (TraceEventMempool blk))
-> Tracer IO (WithSeverity (TraceEventMempool blk))
-> Tracer IO (TraceEventMempool blk)
forall a b. (a -> b) -> a -> b
$ TracingVerbosity
-> Trace IO Text
-> Tracer IO (WithSeverity (TraceEventMempool blk))
forall (m :: * -> *) a b.
(ToLogObject m, ToObject a, Transformable a m b) =>
TracingVerbosity -> Trace m a -> Tracer m b
toLogObject' (TraceSelection -> TracingVerbosity
traceVerbosity TraceSelection
tc) Trace IO Text
tr

--------------------------------------------------------------------------------
-- ForgeStateInfo Tracers
--------------------------------------------------------------------------------

forgeStateInfoMetricsTraceTransformer
  :: forall a blk. HasKESMetricsData blk
  => Proxy blk
  -> Trace IO a
  -> Tracer IO (Consensus.TraceLabelCreds (ForgeStateInfo blk))
forgeStateInfoMetricsTraceTransformer :: Proxy blk
-> Trace IO a -> Tracer IO (TraceLabelCreds (ForgeStateInfo blk))
forgeStateInfoMetricsTraceTransformer Proxy blk
p Trace IO a
tr = (TraceLabelCreds (ForgeStateInfo blk) -> IO ())
-> Tracer IO (TraceLabelCreds (ForgeStateInfo blk))
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer ((TraceLabelCreds (ForgeStateInfo blk) -> IO ())
 -> Tracer IO (TraceLabelCreds (ForgeStateInfo blk)))
-> (TraceLabelCreds (ForgeStateInfo blk) -> IO ())
-> Tracer IO (TraceLabelCreds (ForgeStateInfo blk))
forall a b. (a -> b) -> a -> b
$
  \(Consensus.TraceLabelCreds Text
_ ForgeStateInfo blk
forgeStateInfo) -> do
    case Proxy blk -> ForgeStateInfo blk -> KESMetricsData
forall blk.
HasKESMetricsData blk =>
Proxy blk -> ForgeStateInfo blk -> KESMetricsData
getKESMetricsData Proxy blk
p ForgeStateInfo blk
forgeStateInfo of
      KESMetricsData
NoKESMetricsData -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      TPraosKESMetricsData Word
kesPeriodOfKey
                           (MaxKESEvolutions Word64
maxKesEvos)
                           (OperationalCertStartKESPeriod Word
oCertStartKesPeriod) -> do
        let metricsTr :: Trace IO a
metricsTr = Text -> Trace IO a -> Trace IO a
forall (m :: * -> *) a. Text -> Trace m a -> Trace m a
appendName Text
"metrics" Trace IO a
tr

            -- The KES period of the hot key is relative to the start KES
            -- period of the operational certificate.
            currentKesPeriod :: Word
currentKesPeriod = Word
oCertStartKesPeriod Word -> Word -> Word
forall a. Num a => a -> a -> a
+ Word
kesPeriodOfKey

            oCertExpiryKesPeriod :: Word
oCertExpiryKesPeriod = Word
oCertStartKesPeriod Word -> Word -> Word
forall a. Num a => a -> a -> a
+ Word64 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
maxKesEvos

            kesPeriodsUntilExpiry :: Word
kesPeriodsUntilExpiry =
              Word -> Word -> Word
forall a. Ord a => a -> a -> a
max Word
0 (Word
oCertExpiryKesPeriod Word -> Word -> Word
forall a. Num a => a -> a -> a
- Word
currentKesPeriod)

            logValues :: [LOContent a]
            logValues :: [LOContent a]
logValues =
              [ Text -> Measurable -> LOContent a
forall a. Text -> Measurable -> LOContent a
LogValue Text
"operationalCertificateStartKESPeriod"
                  (Measurable -> LOContent a) -> Measurable -> LOContent a
forall a b. (a -> b) -> a -> b
$ Integer -> Measurable
PureI
                  (Integer -> Measurable) -> Integer -> Measurable
forall a b. (a -> b) -> a -> b
$ Word -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
oCertStartKesPeriod
              , Text -> Measurable -> LOContent a
forall a. Text -> Measurable -> LOContent a
LogValue Text
"operationalCertificateExpiryKESPeriod"
                  (Measurable -> LOContent a) -> Measurable -> LOContent a
forall a b. (a -> b) -> a -> b
$ Integer -> Measurable
PureI
                  (Integer -> Measurable) -> Integer -> Measurable
forall a b. (a -> b) -> a -> b
$ Word -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
oCertExpiryKesPeriod
              , Text -> Measurable -> LOContent a
forall a. Text -> Measurable -> LOContent a
LogValue Text
"currentKESPeriod"
                  (Measurable -> LOContent a) -> Measurable -> LOContent a
forall a b. (a -> b) -> a -> b
$ Integer -> Measurable
PureI
                  (Integer -> Measurable) -> Integer -> Measurable
forall a b. (a -> b) -> a -> b
$ Word -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
currentKesPeriod
              , Text -> Measurable -> LOContent a
forall a. Text -> Measurable -> LOContent a
LogValue Text
"remainingKESPeriods"
                  (Measurable -> LOContent a) -> Measurable -> LOContent a
forall a b. (a -> b) -> a -> b
$ Integer -> Measurable
PureI
                  (Integer -> Measurable) -> Integer -> Measurable
forall a b. (a -> b) -> a -> b
$ Word -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
kesPeriodsUntilExpiry
              ]

        LOMeta
meta <- Severity -> PrivacyAnnotation -> IO LOMeta
forall (m :: * -> *).
MonadIO m =>
Severity -> PrivacyAnnotation -> m LOMeta
mkLOMeta Severity
Critical PrivacyAnnotation
Confidential
        (LOContent a -> IO ()) -> [LOContent a] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Trace IO a -> (LOMeta, LOContent a) -> IO ()
forall (m :: * -> *) a.
MonadIO m =>
Trace m a -> (LOMeta, LOContent a) -> m ()
traceNamedObject Trace IO a
metricsTr ((LOMeta, LOContent a) -> IO ())
-> (LOContent a -> (LOMeta, LOContent a)) -> LOContent a -> IO ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (LOMeta
meta,)) [LOContent a]
logValues

        -- Trace warning messages on the last 7 KES periods and, in the
        -- final and subsequent KES periods, trace alert messages.
        LOMeta
metaWarning <- Severity -> PrivacyAnnotation -> IO LOMeta
forall (m :: * -> *).
MonadIO m =>
Severity -> PrivacyAnnotation -> m LOMeta
mkLOMeta Severity
Warning PrivacyAnnotation
Public
        LOMeta
metaAlert <- Severity -> PrivacyAnnotation -> IO LOMeta
forall (m :: * -> *).
MonadIO m =>
Severity -> PrivacyAnnotation -> m LOMeta
mkLOMeta Severity
Alert PrivacyAnnotation
Public
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word
kesPeriodsUntilExpiry Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
<= Word
7) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
          Trace IO a -> (Text, LogObject a) -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Trace IO a
tr
            ( Text
forall a. Monoid a => a
mempty
            , Text -> LOMeta -> LOContent a -> LogObject a
forall a. Text -> LOMeta -> LOContent a -> LogObject a
LogObject
                Text
forall a. Monoid a => a
mempty
                (if Word
kesPeriodsUntilExpiry Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
<= Word
1 then LOMeta
metaAlert else LOMeta
metaWarning)
                (Object -> Text -> LOContent a
forall a. Object -> Text -> LOContent a
LogStructuredText Object
forall a. Monoid a => a
mempty (Word -> Text
expiryLogMessage Word
kesPeriodsUntilExpiry))
            )
  where
    expiryLogMessage :: Word -> Text
    expiryLogMessage :: Word -> Text
expiryLogMessage Word
kesPeriodsUntilExpiry =
      Text
"Operational key will expire in "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
Text.pack (String -> Text) -> (Word -> String) -> Word -> Text
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Word -> String
forall a. Show a => a -> String
show) Word
kesPeriodsUntilExpiry
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" KES periods."

forgeStateInfoTracer
  :: forall blk.
     ( HasKESMetricsData blk
     , Show (ForgeStateInfo blk)
     )
  => Proxy blk
  -> TraceSelection
  -> Trace IO Text
  -> Tracer IO (Consensus.TraceLabelCreds (ForgeStateInfo blk))
forgeStateInfoTracer :: Proxy blk
-> TraceSelection
-> Trace IO Text
-> Tracer IO (TraceLabelCreds (ForgeStateInfo blk))
forgeStateInfoTracer Proxy blk
p TraceSelection
_ts Trace IO Text
tracer = (TraceLabelCreds (ForgeStateInfo blk) -> IO ())
-> Tracer IO (TraceLabelCreds (ForgeStateInfo blk))
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer ((TraceLabelCreds (ForgeStateInfo blk) -> IO ())
 -> Tracer IO (TraceLabelCreds (ForgeStateInfo blk)))
-> (TraceLabelCreds (ForgeStateInfo blk) -> IO ())
-> Tracer IO (TraceLabelCreds (ForgeStateInfo blk))
forall a b. (a -> b) -> a -> b
$ \TraceLabelCreds (ForgeStateInfo blk)
ev -> do
    let tr :: Trace IO Text
tr = Text -> Trace IO Text -> Trace IO Text
forall (m :: * -> *) a. Text -> Trace m a -> Trace m a
appendName Text
"Forge" Trace IO Text
tracer
    Tracer IO (TraceLabelCreds (ForgeStateInfo blk))
-> TraceLabelCreds (ForgeStateInfo blk) -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith (Proxy blk
-> Trace IO Text
-> Tracer IO (TraceLabelCreds (ForgeStateInfo blk))
forall a blk.
HasKESMetricsData blk =>
Proxy blk
-> Trace IO a -> Tracer IO (TraceLabelCreds (ForgeStateInfo blk))
forgeStateInfoMetricsTraceTransformer Proxy blk
p Trace IO Text
tracer) TraceLabelCreds (ForgeStateInfo blk)
ev
    Tracer IO (TraceLabelCreds (ForgeStateInfo blk))
-> TraceLabelCreds (ForgeStateInfo blk) -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith (Trace IO Text -> Tracer IO (TraceLabelCreds (ForgeStateInfo blk))
fsTracer Trace IO Text
tr) TraceLabelCreds (ForgeStateInfo blk)
ev
  where
    fsTracer :: Trace IO Text -> Tracer IO (Consensus.TraceLabelCreds (ForgeStateInfo blk))
    fsTracer :: Trace IO Text -> Tracer IO (TraceLabelCreds (ForgeStateInfo blk))
fsTracer Trace IO Text
tr = Tracer IO String
-> Tracer IO (TraceLabelCreds (ForgeStateInfo blk))
forall a (m :: * -> *). Show a => Tracer m String -> Tracer m a
showTracing (Tracer IO String
 -> Tracer IO (TraceLabelCreds (ForgeStateInfo blk)))
-> Tracer IO String
-> Tracer IO (TraceLabelCreds (ForgeStateInfo blk))
forall a b. (a -> b) -> a -> b
$ (String -> Text) -> Tracer IO Text -> Tracer IO String
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap String -> Text
Text.pack (Tracer IO Text -> Tracer IO String)
-> Tracer IO Text -> Tracer IO String
forall a b. (a -> b) -> a -> b
$ Trace IO Text -> Tracer IO Text
forall (m :: * -> *) a b.
(ToLogObject m, ToObject a, Transformable a m b) =>
Trace m a -> Tracer m b
toLogObject Trace IO Text
tr

--------------------------------------------------------------------------------
-- NodeToClient Tracers
--------------------------------------------------------------------------------

nodeToClientTracers'
  :: ( StandardHash blk
     , Show (ApplyTxErr blk)
     , Show (GenTx blk)
     , Show localPeer
     , ToObject localPeer
     , ShowQuery (Query blk)
     )
  => TraceSelection
  -> TracingVerbosity
  -> Trace IO Text
  -> NodeToClient.Tracers' localPeer blk DeserialiseFailure (Tracer IO)
nodeToClientTracers' :: TraceSelection
-> TracingVerbosity
-> Trace IO Text
-> Tracers' localPeer blk DeserialiseFailure (Tracer IO)
nodeToClientTracers' TraceSelection
trSel TracingVerbosity
verb Trace IO Text
tr =
  Tracers :: forall peer blk e (f :: * -> *).
f (TraceLabelPeer
     peer
     (TraceSendRecv (ChainSync (Serialised blk) (Point blk) (Tip blk))))
-> f (TraceLabelPeer
        peer
        (TraceSendRecv (LocalTxSubmission (GenTx blk) (ApplyTxErr blk))))
-> f (TraceLabelPeer
        peer (TraceSendRecv (LocalStateQuery blk (Point blk) (Query blk))))
-> Tracers' peer blk e f
NodeToClient.Tracers
  { tChainSyncTracer :: Tracer
  IO
  (TraceLabelPeer
     localPeer
     (TraceSendRecv (ChainSync (Serialised blk) (Point blk) (Tip blk))))
NodeToClient.tChainSyncTracer =
    OnOff TraceLocalChainSyncProtocol
-> TracingVerbosity
-> Text
-> Trace IO Text
-> Tracer
     IO
     (TraceLabelPeer
        localPeer
        (TraceSendRecv (ChainSync (Serialised blk) (Point blk) (Tip blk))))
forall a (b :: Symbol).
Transformable Text IO a =>
OnOff b -> TracingVerbosity -> Text -> Trace IO Text -> Tracer IO a
tracerOnOff (TraceSelection -> OnOff TraceLocalChainSyncProtocol
traceLocalChainSyncProtocol TraceSelection
trSel) TracingVerbosity
verb Text
"LocalChainSyncProtocol" Trace IO Text
tr
  , tTxSubmissionTracer :: Tracer
  IO
  (TraceLabelPeer
     localPeer
     (TraceSendRecv (LocalTxSubmission (GenTx blk) (ApplyTxErr blk))))
NodeToClient.tTxSubmissionTracer =
    OnOff TraceLocalTxSubmissionProtocol
-> TracingVerbosity
-> Text
-> Trace IO Text
-> Tracer
     IO
     (TraceLabelPeer
        localPeer
        (TraceSendRecv (LocalTxSubmission (GenTx blk) (ApplyTxErr blk))))
forall a (b :: Symbol).
Transformable Text IO a =>
OnOff b -> TracingVerbosity -> Text -> Trace IO Text -> Tracer IO a
tracerOnOff (TraceSelection -> OnOff TraceLocalTxSubmissionProtocol
traceLocalTxSubmissionProtocol TraceSelection
trSel) TracingVerbosity
verb Text
"LocalTxSubmissionProtocol" Trace IO Text
tr
  , tStateQueryTracer :: Tracer
  IO
  (TraceLabelPeer
     localPeer
     (TraceSendRecv (LocalStateQuery blk (Point blk) (Query blk))))
NodeToClient.tStateQueryTracer =
    OnOff TraceLocalStateQueryProtocol
-> TracingVerbosity
-> Text
-> Trace IO Text
-> Tracer
     IO
     (TraceLabelPeer
        localPeer
        (TraceSendRecv (LocalStateQuery blk (Point blk) (Query blk))))
forall a (b :: Symbol).
Transformable Text IO a =>
OnOff b -> TracingVerbosity -> Text -> Trace IO Text -> Tracer IO a
tracerOnOff (TraceSelection -> OnOff TraceLocalStateQueryProtocol
traceLocalStateQueryProtocol TraceSelection
trSel) TracingVerbosity
verb Text
"LocalStateQueryProtocol" Trace IO Text
tr
  }

--------------------------------------------------------------------------------
-- NodeToNode Tracers
--------------------------------------------------------------------------------

nodeToNodeTracers'
  :: ( Consensus.RunNode blk
     , ConvertTxId blk
     , HasTxs blk
     , Show blk
     , Show (Header blk)
     , Show peer
     , ToObject peer
     )
  => TraceSelection
  -> TracingVerbosity
  -> Trace IO Text
  -> NodeToNode.Tracers' peer blk DeserialiseFailure (Tracer IO)
nodeToNodeTracers' :: TraceSelection
-> TracingVerbosity
-> Trace IO Text
-> Tracers' peer blk DeserialiseFailure (Tracer IO)
nodeToNodeTracers' TraceSelection
trSel TracingVerbosity
verb Trace IO Text
tr =
  Tracers :: forall peer blk e (f :: * -> *).
f (TraceLabelPeer
     peer
     (TraceSendRecv (ChainSync (Header blk) (Point blk) (Tip blk))))
-> f (TraceLabelPeer
        peer
        (TraceSendRecv
           (ChainSync (SerialisedHeader blk) (Point blk) (Tip blk))))
-> f (TraceLabelPeer
        peer (TraceSendRecv (BlockFetch blk (Point blk))))
-> f (TraceLabelPeer
        peer (TraceSendRecv (BlockFetch (Serialised blk) (Point blk))))
-> f (TraceLabelPeer
        peer (TraceSendRecv (TxSubmission (GenTxId blk) (GenTx blk))))
-> f (TraceLabelPeer
        peer (TraceSendRecv (TxSubmission2 (GenTxId blk) (GenTx blk))))
-> Tracers' peer blk e f
NodeToNode.Tracers
  { tChainSyncTracer :: Tracer
  IO
  (TraceLabelPeer
     peer
     (TraceSendRecv (ChainSync (Header blk) (Point blk) (Tip blk))))
NodeToNode.tChainSyncTracer = OnOff TraceChainSyncProtocol
-> TracingVerbosity
-> Text
-> Trace IO Text
-> Tracer
     IO
     (TraceLabelPeer
        peer
        (TraceSendRecv (ChainSync (Header blk) (Point blk) (Tip blk))))
forall a (b :: Symbol).
Transformable Text IO a =>
OnOff b -> TracingVerbosity -> Text -> Trace IO Text -> Tracer IO a
tracerOnOff (TraceSelection -> OnOff TraceChainSyncProtocol
traceChainSyncProtocol TraceSelection
trSel) TracingVerbosity
verb Text
"ChainSyncProtocol" Trace IO Text
tr
  , tChainSyncSerialisedTracer :: Tracer
  IO
  (TraceLabelPeer
     peer
     (TraceSendRecv
        (ChainSync (SerialisedHeader blk) (Point blk) (Tip blk))))
NodeToNode.tChainSyncSerialisedTracer = OnOff TraceChainSyncProtocol
-> Text
-> Trace IO Text
-> Tracer
     IO
     (TraceLabelPeer
        peer
        (TraceSendRecv
           (ChainSync (SerialisedHeader blk) (Point blk) (Tip blk))))
forall a (b :: Symbol).
(Show a, HasSeverityAnnotation a) =>
OnOff b -> Text -> Trace IO Text -> Tracer IO a
showOnOff (TraceSelection -> OnOff TraceChainSyncProtocol
traceChainSyncProtocol TraceSelection
trSel) Text
"ChainSyncProtocolSerialised" Trace IO Text
tr
  , tBlockFetchTracer :: Tracer
  IO
  (TraceLabelPeer peer (TraceSendRecv (BlockFetch blk (Point blk))))
NodeToNode.tBlockFetchTracer = OnOff TraceBlockFetchProtocol
-> TracingVerbosity
-> Text
-> Trace IO Text
-> Tracer
     IO
     (TraceLabelPeer peer (TraceSendRecv (BlockFetch blk (Point blk))))
forall a (b :: Symbol).
Transformable Text IO a =>
OnOff b -> TracingVerbosity -> Text -> Trace IO Text -> Tracer IO a
tracerOnOff (TraceSelection -> OnOff TraceBlockFetchProtocol
traceBlockFetchProtocol TraceSelection
trSel) TracingVerbosity
verb Text
"BlockFetchProtocol" Trace IO Text
tr
  , tBlockFetchSerialisedTracer :: Tracer
  IO
  (TraceLabelPeer
     peer (TraceSendRecv (BlockFetch (Serialised blk) (Point blk))))
NodeToNode.tBlockFetchSerialisedTracer = OnOff TraceBlockFetchProtocolSerialised
-> Text
-> Trace IO Text
-> Tracer
     IO
     (TraceLabelPeer
        peer (TraceSendRecv (BlockFetch (Serialised blk) (Point blk))))
forall a (b :: Symbol).
(Show a, HasSeverityAnnotation a) =>
OnOff b -> Text -> Trace IO Text -> Tracer IO a
showOnOff (TraceSelection -> OnOff TraceBlockFetchProtocolSerialised
traceBlockFetchProtocolSerialised TraceSelection
trSel) Text
"BlockFetchProtocolSerialised" Trace IO Text
tr
  , tTxSubmissionTracer :: Tracer
  IO
  (TraceLabelPeer
     peer (TraceSendRecv (TxSubmission (GenTxId blk) (GenTx blk))))
NodeToNode.tTxSubmissionTracer = OnOff TraceTxSubmissionProtocol
-> TracingVerbosity
-> Text
-> Trace IO Text
-> Tracer
     IO
     (TraceLabelPeer
        peer (TraceSendRecv (TxSubmission (GenTxId blk) (GenTx blk))))
forall a (b :: Symbol).
Transformable Text IO a =>
OnOff b -> TracingVerbosity -> Text -> Trace IO Text -> Tracer IO a
tracerOnOff (TraceSelection -> OnOff TraceTxSubmissionProtocol
traceTxSubmissionProtocol TraceSelection
trSel) TracingVerbosity
verb Text
"TxSubmissionProtocol" Trace IO Text
tr
  , tTxSubmission2Tracer :: Tracer
  IO
  (TraceLabelPeer
     peer (TraceSendRecv (TxSubmission2 (GenTxId blk) (GenTx blk))))
NodeToNode.tTxSubmission2Tracer = OnOff TraceTxSubmission2Protocol
-> TracingVerbosity
-> Text
-> Trace IO Text
-> Tracer
     IO
     (TraceLabelPeer
        peer (TraceSendRecv (TxSubmission2 (GenTxId blk) (GenTx blk))))
forall a (b :: Symbol).
Transformable Text IO a =>
OnOff b -> TracingVerbosity -> Text -> Trace IO Text -> Tracer IO a
tracerOnOff (TraceSelection -> OnOff TraceTxSubmission2Protocol
traceTxSubmission2Protocol TraceSelection
trSel) TracingVerbosity
verb Text
"TxSubmission2Protocol" Trace IO Text
tr
  }

teeTraceBlockFetchDecision
    :: ( Eq peer
       , HasHeader blk
       , Show peer
       , ToObject peer
       )
    => TracingVerbosity
    -> MVar (Maybe (WithSeverity [TraceLabelPeer peer (FetchDecision [Point (Header blk)])]),Integer)
    -> Trace IO Text
    -> Tracer IO (WithSeverity [TraceLabelPeer peer (FetchDecision [Point (Header blk)])])
teeTraceBlockFetchDecision :: TracingVerbosity
-> MVar
     (Maybe
        (WithSeverity
           [TraceLabelPeer peer (FetchDecision [Point (Header blk)])]),
      Integer)
-> Trace IO Text
-> Tracer
     IO
     (WithSeverity
        [TraceLabelPeer peer (FetchDecision [Point (Header blk)])])
teeTraceBlockFetchDecision TracingVerbosity
verb MVar
  (Maybe
     (WithSeverity
        [TraceLabelPeer peer (FetchDecision [Point (Header blk)])]),
   Integer)
eliding Trace IO Text
tr =
  (WithSeverity
   [TraceLabelPeer peer (FetchDecision [Point (Header blk)])]
 -> IO ())
-> Tracer
     IO
     (WithSeverity
        [TraceLabelPeer peer (FetchDecision [Point (Header blk)])])
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer ((WithSeverity
    [TraceLabelPeer peer (FetchDecision [Point (Header blk)])]
  -> IO ())
 -> Tracer
      IO
      (WithSeverity
         [TraceLabelPeer peer (FetchDecision [Point (Header blk)])]))
-> (WithSeverity
      [TraceLabelPeer peer (FetchDecision [Point (Header blk)])]
    -> IO ())
-> Tracer
     IO
     (WithSeverity
        [TraceLabelPeer peer (FetchDecision [Point (Header blk)])])
forall a b. (a -> b) -> a -> b
$ \WithSeverity
  [TraceLabelPeer peer (FetchDecision [Point (Header blk)])]
ev -> do
    Tracer
  IO
  (WithSeverity
     [TraceLabelPeer peer (FetchDecision [Point (Header blk)])])
-> WithSeverity
     [TraceLabelPeer peer (FetchDecision [Point (Header blk)])]
-> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith (Trace IO Text
-> Tracer
     IO
     (WithSeverity
        [TraceLabelPeer peer (FetchDecision [Point (Header blk)])])
forall peer blk.
Trace IO Text
-> Tracer
     IO
     (WithSeverity
        [TraceLabelPeer peer (FetchDecision [Point (Header blk)])])
teeTraceBlockFetchDecision' Trace IO Text
meTr) WithSeverity
  [TraceLabelPeer peer (FetchDecision [Point (Header blk)])]
ev
    Tracer
  IO
  (WithSeverity
     [TraceLabelPeer peer (FetchDecision [Point (Header blk)])])
-> WithSeverity
     [TraceLabelPeer peer (FetchDecision [Point (Header blk)])]
-> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith (TracingVerbosity
-> MVar
     (Maybe
        (WithSeverity
           [TraceLabelPeer peer (FetchDecision [Point (Header blk)])]),
      Integer)
-> Trace IO Text
-> Tracer
     IO
     (WithSeverity
        [TraceLabelPeer peer (FetchDecision [Point (Header blk)])])
forall peer blk.
(Eq peer, HasHeader blk, Show peer, ToObject peer) =>
TracingVerbosity
-> MVar
     (Maybe
        (WithSeverity
           [TraceLabelPeer peer (FetchDecision [Point (Header blk)])]),
      Integer)
-> Trace IO Text
-> Tracer
     IO
     (WithSeverity
        [TraceLabelPeer peer (FetchDecision [Point (Header blk)])])
teeTraceBlockFetchDecisionElide TracingVerbosity
verb MVar
  (Maybe
     (WithSeverity
        [TraceLabelPeer peer (FetchDecision [Point (Header blk)])]),
   Integer)
eliding Trace IO Text
bfdTr) WithSeverity
  [TraceLabelPeer peer (FetchDecision [Point (Header blk)])]
ev
 where
   meTr :: Trace IO Text
meTr  = Text -> Trace IO Text -> Trace IO Text
forall (m :: * -> *) a. Text -> Trace m a -> Trace m a
appendName Text
"metrics" Trace IO Text
tr
   bfdTr :: Trace IO Text
bfdTr = Text -> Trace IO Text -> Trace IO Text
forall (m :: * -> *) a. Text -> Trace m a -> Trace m a
appendName Text
"BlockFetchDecision" Trace IO Text
tr

teeTraceBlockFetchDecision'
    :: Trace IO Text
    -> Tracer IO (WithSeverity [TraceLabelPeer peer (FetchDecision [Point (Header blk)])])
teeTraceBlockFetchDecision' :: Trace IO Text
-> Tracer
     IO
     (WithSeverity
        [TraceLabelPeer peer (FetchDecision [Point (Header blk)])])
teeTraceBlockFetchDecision' Trace IO Text
tr =
    (WithSeverity
   [TraceLabelPeer peer (FetchDecision [Point (Header blk)])]
 -> IO ())
-> Tracer
     IO
     (WithSeverity
        [TraceLabelPeer peer (FetchDecision [Point (Header blk)])])
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer ((WithSeverity
    [TraceLabelPeer peer (FetchDecision [Point (Header blk)])]
  -> IO ())
 -> Tracer
      IO
      (WithSeverity
         [TraceLabelPeer peer (FetchDecision [Point (Header blk)])]))
-> (WithSeverity
      [TraceLabelPeer peer (FetchDecision [Point (Header blk)])]
    -> IO ())
-> Tracer
     IO
     (WithSeverity
        [TraceLabelPeer peer (FetchDecision [Point (Header blk)])])
forall a b. (a -> b) -> a -> b
$ \(WithSeverity Severity
_ [TraceLabelPeer peer (FetchDecision [Point (Header blk)])]
peers) -> do
      LOMeta
meta <- Severity -> PrivacyAnnotation -> IO LOMeta
forall (m :: * -> *).
MonadIO m =>
Severity -> PrivacyAnnotation -> m LOMeta
mkLOMeta Severity
Info PrivacyAnnotation
Confidential
      Trace IO Text -> (LOMeta, LOContent Text) -> IO ()
forall (m :: * -> *) a.
MonadIO m =>
Trace m a -> (LOMeta, LOContent a) -> m ()
traceNamedObject Trace IO Text
tr (LOMeta
meta, Text -> Measurable -> LOContent Text
forall a. Text -> Measurable -> LOContent a
LogValue Text
"connectedPeers" (Measurable -> LOContent Text)
-> (Integer -> Measurable) -> Integer -> LOContent Text
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Integer -> Measurable
PureI (Integer -> LOContent Text) -> Integer -> LOContent Text
forall a b. (a -> b) -> a -> b
$ Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ [TraceLabelPeer peer (FetchDecision [Point (Header blk)])] -> Int
forall a. HasLength a => a -> Int
length [TraceLabelPeer peer (FetchDecision [Point (Header blk)])]
peers)

teeTraceBlockFetchDecisionElide
    :: ( Eq peer
       , HasHeader blk
       , Show peer
       , ToObject peer
       )
    => TracingVerbosity
    -> MVar (Maybe (WithSeverity [TraceLabelPeer peer (FetchDecision [Point (Header blk)])]),Integer)
    -> Trace IO Text
    -> Tracer IO (WithSeverity [TraceLabelPeer peer (FetchDecision [Point (Header blk)])])
teeTraceBlockFetchDecisionElide :: TracingVerbosity
-> MVar
     (Maybe
        (WithSeverity
           [TraceLabelPeer peer (FetchDecision [Point (Header blk)])]),
      Integer)
-> Trace IO Text
-> Tracer
     IO
     (WithSeverity
        [TraceLabelPeer peer (FetchDecision [Point (Header blk)])])
teeTraceBlockFetchDecisionElide = TracingVerbosity
-> MVar
     (Maybe
        (WithSeverity
           [TraceLabelPeer peer (FetchDecision [Point (Header blk)])]),
      Integer)
-> Trace IO Text
-> Tracer
     IO
     (WithSeverity
        [TraceLabelPeer peer (FetchDecision [Point (Header blk)])])
forall a t.
(ElidingTracer a, ToObject t, Transformable t IO a) =>
TracingVerbosity
-> MVar (Maybe a, Integer) -> Trace IO t -> Tracer IO a
elideToLogObject


-- | get information about a chain fragment

data ChainInformation = ChainInformation
  { ChainInformation -> Word64
slots :: Word64
  , ChainInformation -> Word64
blocks :: Word64
  , ChainInformation -> Rational
density :: Rational
    -- ^ the actual number of blocks created over the maximum expected number
    -- of blocks that could be created over the span of the last @k@ blocks.
  , ChainInformation -> EpochNo
epoch :: EpochNo
    -- ^ In which epoch is the tip of the current chain
  , ChainInformation -> Word64
slotInEpoch :: Word64
    -- ^ Relative slot number of the tip of the current chain within the
    -- epoch.
  , ChainInformation -> Int64
blocksUncoupledDelta :: Int64
    -- ^ The net change in number of blocks forged since last restart not on the
    -- current chain.
  }

chainInformation
  :: forall blk. HasHeader (Header blk)
  => ChainDB.NewTipInfo blk
  -> AF.AnchoredFragment (Header blk)
  -> Int64
  -> ChainInformation
chainInformation :: NewTipInfo blk
-> AnchoredFragment (Header blk) -> Int64 -> ChainInformation
chainInformation NewTipInfo blk
newTipInfo AnchoredFragment (Header blk)
frag Int64
blocksUncoupledDelta = ChainInformation :: Word64
-> Word64
-> Rational
-> EpochNo
-> Word64
-> Int64
-> ChainInformation
ChainInformation
    { slots :: Word64
slots = SlotNo -> Word64
unSlotNo (SlotNo -> Word64) -> SlotNo -> Word64
forall a b. (a -> b) -> a -> b
$ SlotNo -> WithOrigin SlotNo -> SlotNo
forall t. t -> WithOrigin t -> t
fromWithOrigin SlotNo
0 (AnchoredFragment (Header blk) -> WithOrigin SlotNo
forall block.
HasHeader block =>
AnchoredFragment block -> WithOrigin SlotNo
AF.headSlot AnchoredFragment (Header blk)
frag)
    , blocks :: Word64
blocks = BlockNo -> Word64
unBlockNo (BlockNo -> Word64) -> BlockNo -> Word64
forall a b. (a -> b) -> a -> b
$ BlockNo -> WithOrigin BlockNo -> BlockNo
forall t. t -> WithOrigin t -> t
fromWithOrigin (Word64 -> BlockNo
BlockNo Word64
1) (AnchoredFragment (Header blk) -> WithOrigin BlockNo
forall block.
HasHeader block =>
AnchoredFragment block -> WithOrigin BlockNo
AF.headBlockNo AnchoredFragment (Header blk)
frag)
    , density :: Rational
density = AnchoredFragment (Header blk) -> Rational
forall blk.
HasHeader (Header blk) =>
AnchoredFragment (Header blk) -> Rational
fragmentChainDensity AnchoredFragment (Header blk)
frag
    , epoch :: EpochNo
epoch = NewTipInfo blk -> EpochNo
forall blk. NewTipInfo blk -> EpochNo
ChainDB.newTipEpoch NewTipInfo blk
newTipInfo
    , slotInEpoch :: Word64
slotInEpoch = NewTipInfo blk -> Word64
forall blk. NewTipInfo blk -> Word64
ChainDB.newTipSlotInEpoch NewTipInfo blk
newTipInfo
    , blocksUncoupledDelta :: Int64
blocksUncoupledDelta = Int64
blocksUncoupledDelta
    }

fragmentChainDensity ::
  HasHeader (Header blk)
  => AF.AnchoredFragment (Header blk) -> Rational
fragmentChainDensity :: AnchoredFragment (Header blk) -> Rational
fragmentChainDensity AnchoredFragment (Header blk)
frag = Word64 -> Word64 -> Rational
calcDensity Word64
blockD Word64
slotD
  where
    calcDensity :: Word64 -> Word64 -> Rational
    calcDensity :: Word64 -> Word64 -> Rational
calcDensity Word64
bl Word64
sl
      | Word64
sl Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
> Word64
0 = Word64 -> Rational
forall a. Real a => a -> Rational
toRational Word64
bl Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ Word64 -> Rational
forall a. Real a => a -> Rational
toRational Word64
sl
      | Bool
otherwise = Rational
0
    slotN :: Word64
slotN  = SlotNo -> Word64
unSlotNo (SlotNo -> Word64) -> SlotNo -> Word64
forall a b. (a -> b) -> a -> b
$ SlotNo -> WithOrigin SlotNo -> SlotNo
forall t. t -> WithOrigin t -> t
fromWithOrigin SlotNo
0 (AnchoredFragment (Header blk) -> WithOrigin SlotNo
forall block.
HasHeader block =>
AnchoredFragment block -> WithOrigin SlotNo
AF.headSlot AnchoredFragment (Header blk)
frag)
    -- Slot of the tip - slot @k@ blocks back. Use 0 as the slot for genesis
    -- includes EBBs
    slotD :: Word64
slotD   = Word64
slotN
            Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- SlotNo -> Word64
unSlotNo (SlotNo -> WithOrigin SlotNo -> SlotNo
forall t. t -> WithOrigin t -> t
fromWithOrigin SlotNo
0 (AnchoredFragment (Header blk) -> WithOrigin SlotNo
forall block.
HasHeader block =>
AnchoredFragment block -> WithOrigin SlotNo
AF.lastSlot AnchoredFragment (Header blk)
frag))
    -- Block numbers start at 1. We ignore the genesis EBB, which has block number 0.
    blockD :: Word64
blockD = Word64
blockN Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
firstBlock
    blockN :: Word64
blockN = BlockNo -> Word64
unBlockNo (BlockNo -> Word64) -> BlockNo -> Word64
forall a b. (a -> b) -> a -> b
$ BlockNo -> WithOrigin BlockNo -> BlockNo
forall t. t -> WithOrigin t -> t
fromWithOrigin (Word64 -> BlockNo
BlockNo Word64
1) (AnchoredFragment (Header blk) -> WithOrigin BlockNo
forall block.
HasHeader block =>
AnchoredFragment block -> WithOrigin BlockNo
AF.headBlockNo AnchoredFragment (Header blk)
frag)
    firstBlock :: Word64
firstBlock = case BlockNo -> Word64
unBlockNo (BlockNo -> Word64)
-> (Header blk -> BlockNo) -> Header blk -> Word64
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Header blk -> BlockNo
forall b. HasHeader b => b -> BlockNo
blockNo (Header blk -> Word64)
-> Either (Anchor (Header blk)) (Header blk)
-> Either (Anchor (Header blk)) Word64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AnchoredFragment (Header blk)
-> Either (Anchor (Header blk)) (Header blk)
forall v a b. Anchorable v a b => AnchoredSeq v a b -> Either a b
AF.last AnchoredFragment (Header blk)
frag of
      -- Empty fragment, no blocks. We have that @blocks = 1 - 1 = 0@
      Left Anchor (Header blk)
_  -> Word64
1
      -- The oldest block is the genesis EBB with block number 0,
      -- don't let it contribute to the number of blocks
      Right Word64
0 -> Word64
1
      Right Word64
b -> Word64
b


--------------------------------------------------------------------------------
-- Trace Helpers
--------------------------------------------------------------------------------

readableTraceBlockchainTimeEvent :: TraceBlockchainTimeEvent UTCTime -> Text
readableTraceBlockchainTimeEvent :: TraceBlockchainTimeEvent UTCTime -> Text
readableTraceBlockchainTimeEvent TraceBlockchainTimeEvent UTCTime
ev = case TraceBlockchainTimeEvent UTCTime
ev of
    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
    TraceCurrentSlotUnknown UTCTime
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) -> (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
time
    TraceSystemClockMovedBack UTCTime
prevTime UTCTime
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) -> (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
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) -> (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
newTime

tracerOnOff :: Transformable Text IO a
            => OnOff b
            -> TracingVerbosity
            -> LoggerName
            -> Trace IO Text
            -> Tracer IO a
tracerOnOff :: OnOff b -> TracingVerbosity -> Text -> Trace IO Text -> Tracer IO a
tracerOnOff (OnOff Bool
False) TracingVerbosity
_ Text
_ Trace IO Text
_ = Tracer IO a
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
tracerOnOff (OnOff Bool
True) TracingVerbosity
verb Text
name Trace IO Text
trcer = Tracer IO (WithSeverity a) -> Tracer IO a
forall a (m :: * -> *).
HasSeverityAnnotation a =>
Tracer m (WithSeverity a) -> Tracer m a
annotateSeverity
                                        (Tracer IO (WithSeverity a) -> Tracer IO a)
-> Tracer IO (WithSeverity a) -> Tracer IO a
forall a b. (a -> b) -> a -> b
$ TracingVerbosity -> Trace IO Text -> Tracer IO (WithSeverity a)
forall (m :: * -> *) a b.
(ToLogObject m, ToObject a, Transformable a m b) =>
TracingVerbosity -> Trace m a -> Tracer m b
toLogObject' TracingVerbosity
verb
                                        (Trace IO Text -> Tracer IO (WithSeverity a))
-> Trace IO Text -> Tracer IO (WithSeverity a)
forall a b. (a -> b) -> a -> b
$ Text -> Trace IO Text -> Trace IO Text
forall (m :: * -> *) a. Text -> Trace m a -> Trace m a
appendName Text
name Trace IO Text
trcer

tracerOnOff'
  :: OnOff b -> Tracer IO a -> Tracer IO a
tracerOnOff' :: OnOff b -> Tracer IO a -> Tracer IO a
tracerOnOff' (OnOff Bool
False) Tracer IO a
_ = Tracer IO a
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
tracerOnOff' (OnOff Bool
True) Tracer IO a
tr = Tracer IO a
tr

instance Show a => Show (WithSeverity a) where
  show :: WithSeverity a -> String
show (WithSeverity Severity
_sev a
a) = a -> String
forall a. Show a => a -> String
show a
a

showOnOff
  :: (Show a, HasSeverityAnnotation a)
  => OnOff b -> LoggerName -> Trace IO Text -> Tracer IO a
showOnOff :: OnOff b -> Text -> Trace IO Text -> Tracer IO a
showOnOff (OnOff Bool
False) Text
_ Trace IO Text
_ = Tracer IO a
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
showOnOff (OnOff Bool
True) Text
name Trace IO Text
trcer = Tracer IO (WithSeverity a) -> Tracer IO a
forall a (m :: * -> *).
HasSeverityAnnotation a =>
Tracer m (WithSeverity a) -> Tracer m a
annotateSeverity
                                        (Tracer IO (WithSeverity a) -> Tracer IO a)
-> Tracer IO (WithSeverity a) -> Tracer IO a
forall a b. (a -> b) -> a -> b
$ Tracer IO String -> Tracer IO (WithSeverity a)
forall a (m :: * -> *). Show a => Tracer m String -> Tracer m a
showTracing
                                        (Tracer IO String -> Tracer IO (WithSeverity a))
-> Tracer IO String -> Tracer IO (WithSeverity a)
forall a b. (a -> b) -> a -> b
$ Text -> Trace IO Text -> Tracer IO String
withName Text
name Trace IO Text
trcer

withName :: Text -> Trace IO Text -> Tracer IO String
withName :: Text -> Trace IO Text -> Tracer IO String
withName Text
name Trace IO Text
tr = (String -> Text) -> Tracer IO Text -> Tracer IO String
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap String -> Text
Text.pack (Tracer IO Text -> Tracer IO String)
-> Tracer IO Text -> Tracer IO String
forall a b. (a -> b) -> a -> b
$ Trace IO Text -> Tracer IO Text
forall (m :: * -> *) a b.
(ToLogObject m, ToObject a, Transformable a m b) =>
Trace m a -> Tracer m b
toLogObject (Trace IO Text -> Tracer IO Text)
-> Trace IO Text -> Tracer IO Text
forall a b. (a -> b) -> a -> b
$ Text -> Trace IO Text -> Trace IO Text
forall (m :: * -> *) a. Text -> Trace m a -> Trace m a
appendName Text
name Trace IO Text
tr