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

{-# OPTIONS_GHC -Wno-orphans  #-}

module Cardano.Tracing.Tracers
  ( BlockchainCounters
  , Tracers (..)
  , TraceOptions
  , mkTracers
  , nullTracers
  ) 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           Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef)
import qualified Data.Text as Text
import           Network.Mux (MuxTrace, WithMuxBearer)
import qualified Network.Socket as Socket (SockAddr)

import           Control.Tracer
import           Control.Tracer.Transformers

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

import           Cardano.BM.Data.Aggregated (Measurable (..))
import           Cardano.BM.Data.LogItem (LOContent (..), LoggerName)
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 (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.SupportsMempool (ApplyTxErr, GenTx, GenTxId, HasTxs)
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.Network.AnchoredFragment as AF
import           Ouroboros.Network.Block (BlockNo (..), HasHeader (..), Point, StandardHash,
                     blockNo, pointSlot, unBlockNo, unSlotNo)
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.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 (HasKESMetricsData (..), KESMetricsData (..),
                     MaxKESEvolutions (..), OperationalCertStartKESPeriod (..))
import           Cardano.Tracing.MicroBenchmarking
import           Cardano.Tracing.Queries

-- For tracing instances
import           Cardano.Node.Protocol.Byron ()
import           Cardano.Node.Protocol.Shelley ()

{- 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 HandshakeTr
handshakeTracer :: Tracer IO NtN.HandshakeTr
  , Tracers peer localPeer blk -> Tracer IO HandshakeTr
localHandshakeTracer :: Tracer IO NtC.HandshakeTr
  }

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 HandshakeTr
-> Tracer IO HandshakeTr
-> 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
  , 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
  }


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)

-- | This structure stores counters of blockchain-related events.
--   These values will be traced periodically.
data BlockchainCounters = BlockchainCounters
  { BlockchainCounters -> Word64
bcTxsProcessedNum        :: !Word64
  , BlockchainCounters -> Word64
bcBlocksForgedNum        :: !Word64
  , BlockchainCounters -> Word64
bcNodeCannotForgeNum     :: !Word64
  , BlockchainCounters -> Word64
bcNodeIsLeaderNum        :: !Word64
  , BlockchainCounters -> Word64
bcSlotsMissedNum         :: !Word64
  }

initialBlockchainCounters :: BlockchainCounters
initialBlockchainCounters :: BlockchainCounters
initialBlockchainCounters = Word64
-> Word64 -> Word64 -> Word64 -> Word64 -> BlockchainCounters
BlockchainCounters Word64
0 Word64
0 Word64
0 Word64
0 Word64
0

-- | Tracers for all system components.
--
mkTracers
  :: forall peer localPeer blk.
     ( Consensus.RunNode blk
     , HasKESMetricsData blk
     , TraceConstraints blk
     , Show peer, Eq peer
     , Show localPeer
     )
  => TraceOptions
  -> Trace IO Text
  -> NodeKernelData blk
  -> IO (Tracers peer localPeer blk)
mkTracers :: TraceOptions
-> Trace IO Text
-> NodeKernelData blk
-> IO (Tracers peer localPeer blk)
mkTracers tOpts :: TraceOptions
tOpts@(TracingOn TraceSelection
trSel) Trace IO Text
tr NodeKernelData blk
nodeKern = do
  IORef BlockchainCounters
bcCounters :: IORef BlockchainCounters <- BlockchainCounters -> IO (IORef BlockchainCounters)
forall a. a -> IO (IORef a)
newIORef BlockchainCounters
initialBlockchainCounters
  Tracers' peer localPeer blk (Tracer IO)
consensusTracers <- TraceSelection
-> TracingVerbosity
-> Trace IO Text
-> NodeKernelData blk
-> IORef BlockchainCounters
-> 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), RunNode blk,
 HasKESMetricsData blk) =>
TraceSelection
-> TracingVerbosity
-> Trace IO Text
-> NodeKernelData blk
-> IORef BlockchainCounters
-> IO (Tracers' peer localPeer blk (Tracer IO))
mkConsensusTracers TraceSelection
trSel TracingVerbosity
verb Trace IO Text
tr NodeKernelData blk
nodeKern IORef BlockchainCounters
bcCounters
  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 HandshakeTr
-> Tracer IO HandshakeTr
-> Tracers peer localPeer blk
Tracers
    { chainDBTracer :: Tracer IO (TraceEvent blk)
chainDBTracer = Bool -> Tracer IO (TraceEvent blk) -> Tracer IO (TraceEvent blk)
forall a. Bool -> Tracer IO a -> Tracer IO a
tracerOnOff' (TraceSelection -> Bool
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))
-> (Trace IO Text -> Tracer IO (WithSeverity (TraceEvent blk)))
-> Trace IO Text
-> Tracer IO (TraceEvent blk)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. TraceOptions
-> 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)) =>
TraceOptions
-> MVar (Maybe (WithSeverity (TraceEvent blk)), Integer)
-> Trace IO Text
-> Tracer IO (WithSeverity (TraceEvent blk))
teeTraceChainTip TraceOptions
tOpts MVar (Maybe (WithSeverity (TraceEvent blk)), Integer)
elidedChainDB (Trace IO Text -> Tracer IO (TraceEvent blk))
-> Trace IO Text -> Tracer IO (TraceEvent 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
"ChainDB" 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 localPeer blk.
Show localPeer =>
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 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 = Bool
-> TracingVerbosity
-> Text
-> Trace IO Text
-> Tracer IO (WithIPList (SubscriptionTrace SockAddr))
forall a.
Transformable Text IO a =>
Bool -> TracingVerbosity -> Text -> Trace IO Text -> Tracer IO a
tracerOnOff (TraceSelection -> Bool
traceIpSubscription TraceSelection
trSel) TracingVerbosity
verb Text
"IpSubscription" Trace IO Text
tr
    , dnsSubscriptionTracer :: Tracer IO (WithDomainName (SubscriptionTrace SockAddr))
dnsSubscriptionTracer =  Bool
-> TracingVerbosity
-> Text
-> Trace IO Text
-> Tracer IO (WithDomainName (SubscriptionTrace SockAddr))
forall a.
Transformable Text IO a =>
Bool -> TracingVerbosity -> Text -> Trace IO Text -> Tracer IO a
tracerOnOff (TraceSelection -> Bool
traceDnsSubscription TraceSelection
trSel) TracingVerbosity
verb Text
"DnsSubscription" Trace IO Text
tr
    , dnsResolverTracer :: Tracer IO (WithDomainName DnsTrace)
dnsResolverTracer = Bool
-> TracingVerbosity
-> Text
-> Trace IO Text
-> Tracer IO (WithDomainName DnsTrace)
forall a.
Transformable Text IO a =>
Bool -> TracingVerbosity -> Text -> Trace IO Text -> Tracer IO a
tracerOnOff (TraceSelection -> Bool
traceDnsResolver TraceSelection
trSel) TracingVerbosity
verb Text
"DnsResolver" Trace IO Text
tr
    , errorPolicyTracer :: Tracer IO (WithAddr SockAddr ErrorPolicyTrace)
errorPolicyTracer = Bool
-> TracingVerbosity
-> Text
-> Trace IO Text
-> Tracer IO (WithAddr SockAddr ErrorPolicyTrace)
forall a.
Transformable Text IO a =>
Bool -> TracingVerbosity -> Text -> Trace IO Text -> Tracer IO a
tracerOnOff (TraceSelection -> Bool
traceErrorPolicy TraceSelection
trSel) TracingVerbosity
verb Text
"ErrorPolicy" Trace IO Text
tr
    , localErrorPolicyTracer :: Tracer IO (WithAddr LocalAddress ErrorPolicyTrace)
localErrorPolicyTracer = Bool
-> TracingVerbosity
-> Text
-> Trace IO Text
-> Tracer IO (WithAddr LocalAddress ErrorPolicyTrace)
forall a.
Transformable Text IO a =>
Bool -> TracingVerbosity -> Text -> Trace IO Text -> Tracer IO a
tracerOnOff (TraceSelection -> Bool
traceLocalErrorPolicy TraceSelection
trSel) TracingVerbosity
verb Text
"LocalErrorPolicy" Trace IO Text
tr
    , acceptPolicyTracer :: Tracer IO AcceptConnectionsPolicyTrace
acceptPolicyTracer = Bool
-> TracingVerbosity
-> Text
-> Trace IO Text
-> Tracer IO AcceptConnectionsPolicyTrace
forall a.
Transformable Text IO a =>
Bool -> TracingVerbosity -> Text -> Trace IO Text -> Tracer IO a
tracerOnOff (TraceSelection -> Bool
traceAcceptPolicy TraceSelection
trSel) TracingVerbosity
verb Text
"AcceptPolicy" Trace IO Text
tr
    , muxTracer :: Tracer IO (WithMuxBearer peer MuxTrace)
muxTracer = Bool
-> TracingVerbosity
-> Text
-> Trace IO Text
-> Tracer IO (WithMuxBearer peer MuxTrace)
forall a.
Transformable Text IO a =>
Bool -> TracingVerbosity -> Text -> Trace IO Text -> Tracer IO a
tracerOnOff (TraceSelection -> Bool
traceMux TraceSelection
trSel) TracingVerbosity
verb Text
"Mux" Trace IO Text
tr
    , handshakeTracer :: Tracer IO HandshakeTr
handshakeTracer = Bool
-> TracingVerbosity
-> Text
-> Trace IO Text
-> Tracer IO HandshakeTr
forall a.
Transformable Text IO a =>
Bool -> TracingVerbosity -> Text -> Trace IO Text -> Tracer IO a
tracerOnOff (TraceSelection -> Bool
traceHandshake TraceSelection
trSel) TracingVerbosity
verb Text
"Handshake" Trace IO Text
tr
    , localHandshakeTracer :: Tracer IO HandshakeTr
localHandshakeTracer = Bool
-> TracingVerbosity
-> Text
-> Trace IO Text
-> Tracer IO HandshakeTr
forall a.
Transformable Text IO a =>
Bool -> TracingVerbosity -> Text -> Trace IO Text -> Tracer IO a
tracerOnOff (TraceSelection -> Bool
traceLocalHandshake TraceSelection
trSel) TracingVerbosity
verb Text
"LocalHandshake" Trace IO Text
tr
    }
 where
   verb :: TracingVerbosity
   verb :: TracingVerbosity
verb = TraceSelection -> TracingVerbosity
traceVerbosity TraceSelection
trSel

mkTracers TraceOptions
TracingOff Trace IO Text
_ NodeKernelData blk
_ =
  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 HandshakeTr
-> Tracer IO HandshakeTr
-> 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 (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
-> f (TraceLabelCreds (ForgeStateInfo blk))
-> f (TraceKeepAliveClient remotePeer)
-> Tracers' remotePeer localPeer blk f
Consensus.Tracers
      { chainSyncClientTracer :: Tracer IO (TraceChainSyncClientEvent blk)
Consensus.chainSyncClientTracer = Tracer IO (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
Consensus.blockchainTimeTracer = Tracer IO TraceBlockchainTimeEvent
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))))
-> 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
      }
    , 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
    , 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
    }

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

teeTraceChainTip
  :: ( ConvertRawHash blk
     , LedgerSupportsProtocol blk
     , InspectLedger blk
     , ToObject (Header blk)
     , ToObject (LedgerEvent blk)
     )
  => TraceOptions
  -> MVar (Maybe (WithSeverity (ChainDB.TraceEvent blk)), Integer)
  -> Trace IO Text
  -> Tracer IO (WithSeverity (ChainDB.TraceEvent blk))
teeTraceChainTip :: TraceOptions
-> MVar (Maybe (WithSeverity (TraceEvent blk)), Integer)
-> Trace IO Text
-> Tracer IO (WithSeverity (TraceEvent blk))
teeTraceChainTip TraceOptions
TracingOff MVar (Maybe (WithSeverity (TraceEvent blk)), Integer)
_ Trace IO Text
_ = Tracer IO (WithSeverity (TraceEvent blk))
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
teeTraceChainTip (TracingOn TraceSelection
trSel) MVar (Maybe (WithSeverity (TraceEvent blk)), Integer)
elided Trace IO Text
tr =
  (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 (Trace IO Text -> Tracer IO (WithSeverity (TraceEvent blk))
forall blk.
HasHeader (Header blk) =>
Trace IO Text -> Tracer IO (WithSeverity (TraceEvent blk))
teeTraceChainTip' Trace IO Text
tr) WithSeverity (TraceEvent blk)
ev
    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
tr) 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

traceChainInformation :: Trace IO Text -> ChainInformation -> IO ()
traceChainInformation :: Trace IO Text -> ChainInformation -> IO ()
traceChainInformation Trace IO Text
tr 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 chain changes. How cheap is it?
  LOMeta
meta <- Severity -> PrivacyAnnotation -> IO LOMeta
forall (m :: * -> *).
MonadIO m =>
Severity -> PrivacyAnnotation -> m LOMeta
mkLOMeta Severity
Critical PrivacyAnnotation
Confidential
  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
"metrics" Trace IO Text
tr
      traceD :: Text -> Double -> IO ()
      traceD :: Text -> Double -> IO ()
traceD Text
msg Double
d = 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
msg (Double -> Measurable
PureD Double
d))
      traceI :: Integral a => Text -> a -> IO ()
      traceI :: Text -> a -> IO ()
traceI Text
msg a
i = 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
msg (Integer -> Measurable
PureI (a -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
i)))

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

teeTraceChainTip'
  :: HasHeader (Header blk)
  => Trace IO Text -> Tracer IO (WithSeverity (ChainDB.TraceEvent blk))
teeTraceChainTip' :: Trace IO Text -> Tracer IO (WithSeverity (TraceEvent blk))
teeTraceChainTip' Trace IO Text
tr =
    (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 Severity
_ TraceEvent blk
ev') ->
      case TraceEvent blk
ev' of
          (ChainDB.TraceAddBlockEvent TraceAddBlockEvent blk
ev) -> case TraceAddBlockEvent blk
ev of
            ChainDB.SwitchedToAFork [LedgerEvent blk]
_warnings NewTipInfo blk
newTipInfo AnchoredFragment (Header blk)
_ AnchoredFragment (Header blk)
newChain ->
              Trace IO Text -> ChainInformation -> IO ()
traceChainInformation Trace IO Text
tr (NewTipInfo blk -> AnchoredFragment (Header blk) -> ChainInformation
forall blk.
HasHeader (Header blk) =>
NewTipInfo blk -> AnchoredFragment (Header blk) -> ChainInformation
chainInformation NewTipInfo blk
newTipInfo AnchoredFragment (Header blk)
newChain)
            ChainDB.AddedToCurrentChain [LedgerEvent blk]
_warnings NewTipInfo blk
newTipInfo AnchoredFragment (Header blk)
_ AnchoredFragment (Header blk)
newChain ->
              Trace IO Text -> ChainInformation -> IO ()
traceChainInformation Trace IO Text
tr (NewTipInfo blk -> AnchoredFragment (Header blk) -> ChainInformation
forall blk.
HasHeader (Header blk) =>
NewTipInfo blk -> AnchoredFragment (Header blk) -> ChainInformation
chainInformation NewTipInfo blk
newTipInfo AnchoredFragment (Header blk)
newChain)
            TraceAddBlockEvent blk
_ -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          TraceEvent blk
_ -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

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

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)
     , Consensus.RunNode blk
     , HasKESMetricsData blk
     )
  => TraceSelection
  -> TracingVerbosity
  -> Trace IO Text
  -> NodeKernelData blk
  -> IORef BlockchainCounters
  -> IO (Consensus.Tracers' peer localPeer blk (Tracer IO))
mkConsensusTracers :: TraceSelection
-> TracingVerbosity
-> Trace IO Text
-> NodeKernelData blk
-> IORef BlockchainCounters
-> IO (Tracers' peer localPeer blk (Tracer IO))
mkConsensusTracers TraceSelection
trSel TracingVerbosity
verb Trace IO Text
tr NodeKernelData blk
nodeKern IORef BlockchainCounters
bcCounters = do
  Tracer
  IO
  (Either
     (TraceForgeEvent blk)
     (OutcomeFidelity (Maybe (SlotNo, DiffTime, MempoolSize))))
-> Tracer IO (TraceForgeEvent blk)
blockForgeOutcomeExtractor <- IO
  (Tracer
     IO
     (Either
        (TraceForgeEvent blk)
        (OutcomeFidelity (Maybe (SlotNo, DiffTime, MempoolSize))))
   -> Tracer IO (TraceForgeEvent blk))
forall (m :: * -> *) a.
(MonadIO m, MonadMask m, Outcome m a) =>
m (OutcomeEnhancedTracer m a -> Tracer m a)
mkOutcomeExtractor
  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

  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 (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
-> f (TraceLabelCreds (ForgeStateInfo blk))
-> f (TraceKeepAliveClient remotePeer)
-> Tracers' remotePeer localPeer blk f
Consensus.Tracers
    { chainSyncClientTracer :: Tracer IO (TraceChainSyncClientEvent blk)
Consensus.chainSyncClientTracer = Bool
-> TracingVerbosity
-> Text
-> Trace IO Text
-> Tracer IO (TraceChainSyncClientEvent blk)
forall a.
Transformable Text IO a =>
Bool -> TracingVerbosity -> Text -> Trace IO Text -> Tracer IO a
tracerOnOff (TraceSelection -> Bool
traceChainSyncClient TraceSelection
trSel) TracingVerbosity
verb Text
"ChainSyncClient" Trace IO Text
tr
    , chainSyncServerHeaderTracer :: Tracer IO (TraceChainSyncServerEvent blk)
Consensus.chainSyncServerHeaderTracer = Bool
-> TracingVerbosity
-> Text
-> Trace IO Text
-> Tracer IO (TraceChainSyncServerEvent blk)
forall a.
Transformable Text IO a =>
Bool -> TracingVerbosity -> Text -> Trace IO Text -> Tracer IO a
tracerOnOff (TraceSelection -> Bool
traceChainSyncHeaderServer TraceSelection
trSel) TracingVerbosity
verb Text
"ChainSyncHeaderServer" Trace IO Text
tr
    , chainSyncServerBlockTracer :: Tracer IO (TraceChainSyncServerEvent blk)
Consensus.chainSyncServerBlockTracer = Bool
-> TracingVerbosity
-> Text
-> Trace IO Text
-> Tracer IO (TraceChainSyncServerEvent blk)
forall a.
Transformable Text IO a =>
Bool -> TracingVerbosity -> Text -> Trace IO Text -> Tracer IO a
tracerOnOff (TraceSelection -> Bool
traceChainSyncHeaderServer TraceSelection
trSel) TracingVerbosity
verb Text
"ChainSyncBlockServer" Trace IO Text
tr
    , blockFetchDecisionTracer :: Tracer
  IO [TraceLabelPeer peer (FetchDecision [Point (Header blk)])]
Consensus.blockFetchDecisionTracer = Bool
-> Tracer
     IO [TraceLabelPeer peer (FetchDecision [Point (Header blk)])]
-> Tracer
     IO [TraceLabelPeer peer (FetchDecision [Point (Header blk)])]
forall a. Bool -> Tracer IO a -> Tracer IO a
tracerOnOff' (TraceSelection -> Bool
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) =>
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
 -> Tracer
      IO
      (WithSeverity
         [TraceLabelPeer peer (FetchDecision [Point (Header blk)])]))
-> Trace IO Text
-> Tracer
     IO
     (WithSeverity
        [TraceLabelPeer peer (FetchDecision [Point (Header 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
"BlockFetchDecision" Trace IO Text
tr
    , blockFetchClientTracer :: Tracer
  IO (TraceLabelPeer peer (TraceFetchClientState (Header blk)))
Consensus.blockFetchClientTracer = Bool
-> TracingVerbosity
-> Text
-> Trace IO Text
-> Tracer
     IO (TraceLabelPeer peer (TraceFetchClientState (Header blk)))
forall a.
Transformable Text IO a =>
Bool -> TracingVerbosity -> Text -> Trace IO Text -> Tracer IO a
tracerOnOff (TraceSelection -> Bool
traceBlockFetchClient TraceSelection
trSel) TracingVerbosity
verb Text
"BlockFetchClient" Trace IO Text
tr
    , blockFetchServerTracer :: Tracer IO (TraceBlockFetchServerEvent blk)
Consensus.blockFetchServerTracer = Bool
-> TracingVerbosity
-> Text
-> Trace IO Text
-> Tracer IO (TraceBlockFetchServerEvent blk)
forall a.
Transformable Text IO a =>
Bool -> TracingVerbosity -> Text -> Trace IO Text -> Tracer IO a
tracerOnOff (TraceSelection -> Bool
traceBlockFetchServer TraceSelection
trSel) TracingVerbosity
verb Text
"BlockFetchServer" Trace IO Text
tr
    , forgeStateInfoTracer :: Tracer IO (TraceLabelCreds (ForgeStateInfo blk))
Consensus.forgeStateInfoTracer = Bool
-> Tracer IO (TraceLabelCreds (ForgeStateInfo blk))
-> Tracer IO (TraceLabelCreds (ForgeStateInfo blk))
forall a. Bool -> Tracer IO a -> Tracer IO a
tracerOnOff' (TraceSelection -> Bool
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
$
        (TraceLabelCreds (ForgeStateInfo blk) -> ForgeStateInfo blk)
-> Tracer IO (ForgeStateInfo blk)
-> Tracer IO (TraceLabelCreds (ForgeStateInfo blk))
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap (\(Consensus.TraceLabelCreds Text
_ ForgeStateInfo blk
ev) -> ForgeStateInfo blk
ev) (Tracer IO (ForgeStateInfo blk)
 -> Tracer IO (TraceLabelCreds (ForgeStateInfo blk)))
-> Tracer IO (ForgeStateInfo blk)
-> Tracer IO (TraceLabelCreds (ForgeStateInfo blk))
forall a b. (a -> b) -> a -> b
$
        Proxy blk
-> TraceSelection
-> Trace IO Text
-> Tracer IO (ForgeStateInfo blk)
forall blk.
(HasKESMetricsData blk, Show (ForgeStateInfo blk)) =>
Proxy blk
-> TraceSelection
-> Trace IO Text
-> Tracer IO (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 = Bool
-> TracingVerbosity
-> Text
-> Trace IO Text
-> Tracer
     IO
     (TraceLabelPeer
        peer (TraceTxSubmissionInbound (GenTxId blk) (GenTx blk)))
forall a.
Transformable Text IO a =>
Bool -> TracingVerbosity -> Text -> Trace IO Text -> Tracer IO a
tracerOnOff (TraceSelection -> Bool
traceTxInbound TraceSelection
trSel) TracingVerbosity
verb Text
"TxInbound" Trace IO Text
tr
    , txOutboundTracer :: Tracer
  IO
  (TraceLabelPeer
     peer (TraceTxSubmissionOutbound (GenTxId blk) (GenTx blk)))
Consensus.txOutboundTracer = Bool
-> TracingVerbosity
-> Text
-> Trace IO Text
-> Tracer
     IO
     (TraceLabelPeer
        peer (TraceTxSubmissionOutbound (GenTxId blk) (GenTx blk)))
forall a.
Transformable Text IO a =>
Bool -> TracingVerbosity -> Text -> Trace IO Text -> Tracer IO a
tracerOnOff (TraceSelection -> Bool
traceTxOutbound TraceSelection
trSel) TracingVerbosity
verb Text
"TxOutbound" Trace IO Text
tr
    , localTxSubmissionServerTracer :: Tracer IO (TraceLocalTxSubmissionServerEvent blk)
Consensus.localTxSubmissionServerTracer = Bool
-> TracingVerbosity
-> Text
-> Trace IO Text
-> Tracer IO (TraceLocalTxSubmissionServerEvent blk)
forall a.
Transformable Text IO a =>
Bool -> TracingVerbosity -> Text -> Trace IO Text -> Tracer IO a
tracerOnOff (TraceSelection -> Bool
traceLocalTxSubmissionServer TraceSelection
trSel) TracingVerbosity
verb Text
"LocalTxSubmissionServer" Trace IO Text
tr
    , mempoolTracer :: Tracer IO (TraceEventMempool blk)
Consensus.mempoolTracer = Bool
-> Tracer IO (TraceEventMempool blk)
-> Tracer IO (TraceEventMempool blk)
forall a. Bool -> Tracer IO a -> Tracer IO a
tracerOnOff' (TraceSelection -> Bool
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
-> IORef BlockchainCounters
-> Tracer IO (TraceEventMempool blk)
forall blk.
(Show (ApplyTxErr blk), ToJSON (GenTxId blk),
 ToObject (ApplyTxErr blk), ToObject (GenTx blk)) =>
TraceSelection
-> Trace IO Text
-> IORef BlockchainCounters
-> Tracer IO (TraceEventMempool blk)
mempoolTracer TraceSelection
trSel Trace IO Text
tr IORef BlockchainCounters
bcCounters
    , forgeTracer :: Tracer IO (TraceLabelCreds (TraceForgeEvent blk))
Consensus.forgeTracer = Bool
-> Tracer IO (TraceLabelCreds (TraceForgeEvent blk))
-> Tracer IO (TraceLabelCreds (TraceForgeEvent blk))
forall a. Bool -> Tracer IO a -> Tracer IO a
tracerOnOff' (TraceSelection -> Bool
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
$ \(Consensus.TraceLabelCreds Text
_ TraceForgeEvent blk
ev) -> do
          Tracer IO (TraceForgeEvent blk) -> TraceForgeEvent blk -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith (TracingVerbosity
-> Trace IO Text
-> ForgeTracers
-> NodeKernelData blk
-> IORef BlockchainCounters
-> Tracer IO (TraceForgeEvent blk)
forall blk.
(RunNode blk, LedgerQueries blk, ToObject (CannotForge blk),
 ToObject (LedgerErr (LedgerState blk)),
 ToObject (OtherHeaderEnvelopeError blk),
 ToObject (ValidationErr (BlockProtocol blk)),
 ToObject (ForgeStateUpdateError blk)) =>
TracingVerbosity
-> Trace IO Text
-> ForgeTracers
-> NodeKernelData blk
-> IORef BlockchainCounters
-> Tracer IO (TraceForgeEvent blk)
forgeTracer TracingVerbosity
verb Trace IO Text
tr ForgeTracers
forgeTracers NodeKernelData blk
nodeKern IORef BlockchainCounters
bcCounters) TraceForgeEvent blk
ev
          Tracer IO (TraceForgeEvent blk) -> TraceForgeEvent blk -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith (Tracer
  IO
  (Either
     (TraceForgeEvent blk)
     (OutcomeFidelity (Maybe (SlotNo, DiffTime, MempoolSize))))
-> Tracer IO (TraceForgeEvent blk)
blockForgeOutcomeExtractor
                    (Tracer
   IO
   (Either
      (TraceForgeEvent blk)
      (OutcomeFidelity (Maybe (SlotNo, DiffTime, MempoolSize))))
 -> Tracer IO (TraceForgeEvent blk))
-> Tracer
     IO
     (Either
        (TraceForgeEvent blk)
        (OutcomeFidelity (Maybe (SlotNo, DiffTime, MempoolSize))))
-> Tracer IO (TraceForgeEvent blk)
forall a b. (a -> b) -> a -> b
$ TracingVerbosity
-> Trace IO Text
-> Tracer
     IO
     (Either
        (TraceForgeEvent blk)
        (OutcomeFidelity (Maybe (SlotNo, DiffTime, MempoolSize))))
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
      (Either
         (TraceForgeEvent blk)
         (OutcomeFidelity (Maybe (SlotNo, DiffTime, MempoolSize)))))
-> Trace IO Text
-> Tracer
     IO
     (Either
        (TraceForgeEvent blk)
        (OutcomeFidelity (Maybe (SlotNo, DiffTime, MempoolSize))))
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
"ForgeTime" Trace IO Text
tr) TraceForgeEvent blk
ev

    , blockchainTimeTracer :: Tracer IO TraceBlockchainTimeEvent
Consensus.blockchainTimeTracer = Bool
-> Tracer IO TraceBlockchainTimeEvent
-> Tracer IO TraceBlockchainTimeEvent
forall a. Bool -> Tracer IO a -> Tracer IO a
tracerOnOff' (TraceSelection -> Bool
traceBlockchainTime TraceSelection
trSel) (Tracer IO TraceBlockchainTimeEvent
 -> Tracer IO TraceBlockchainTimeEvent)
-> Tracer IO TraceBlockchainTimeEvent
-> Tracer IO TraceBlockchainTimeEvent
forall a b. (a -> b) -> a -> b
$
        (TraceBlockchainTimeEvent -> IO ())
-> Tracer IO TraceBlockchainTimeEvent
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer ((TraceBlockchainTimeEvent -> IO ())
 -> Tracer IO TraceBlockchainTimeEvent)
-> (TraceBlockchainTimeEvent -> IO ())
-> Tracer IO TraceBlockchainTimeEvent
forall a b. (a -> b) -> a -> b
$ \TraceBlockchainTimeEvent
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 -> Text
readableTraceBlockchainTimeEvent TraceBlockchainTimeEvent
ev)
    , keepAliveClientTracer :: Tracer IO (TraceKeepAliveClient peer)
Consensus.keepAliveClientTracer = Bool
-> TracingVerbosity
-> Text
-> Trace IO Text
-> Tracer IO (TraceKeepAliveClient peer)
forall a.
Transformable Text IO a =>
Bool -> TracingVerbosity -> Text -> Trace IO Text -> Tracer IO a
tracerOnOff (TraceSelection -> Bool
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)

teeForge ::
  forall blk
  . ( Consensus.RunNode blk
     , LedgerQueries blk
     , ToObject (CannotForge blk)
     , ToObject (LedgerErr (LedgerState blk))
     , ToObject (OtherHeaderEnvelopeError blk)
     , ToObject (ValidationErr (BlockProtocol blk))
     , ToObject (ForgeStateUpdateError blk)
     )
  => ForgeTracers
  -> NodeKernelData blk
  -> TracingVerbosity
  -> Trace IO Text
  -> Tracer IO (WithSeverity (Consensus.TraceForgeEvent blk))
teeForge :: ForgeTracers
-> NodeKernelData blk
-> TracingVerbosity
-> Trace IO Text
-> Tracer IO (WithSeverity (TraceForgeEvent blk))
teeForge ForgeTracers
ft NodeKernelData blk
nodeKern TracingVerbosity
tverb 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
$ \ev :: WithSeverity (TraceForgeEvent blk)
ev@(WithSeverity Severity
sev 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 WithSeverity (TraceForgeEvent blk)
ev (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 -> do
      !StrictMaybe Int
utxoSize <- (NodeKernel IO RemoteConnectionId LocalConnectionId blk -> IO Int)
-> NodeKernelData blk -> IO (StrictMaybe Int)
forall blk a.
(NodeKernel IO RemoteConnectionId LocalConnectionId blk -> IO a)
-> NodeKernelData blk -> IO (StrictMaybe a)
mapNodeKernelDataIO NodeKernel IO RemoteConnectionId LocalConnectionId blk -> IO Int
nkUtxoSize NodeKernelData blk
nodeKern
      LOMeta
meta <- Severity -> PrivacyAnnotation -> IO LOMeta
forall (m :: * -> *).
MonadIO m =>
Severity -> PrivacyAnnotation -> m LOMeta
mkLOMeta Severity
sev PrivacyAnnotation
Public
      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
        , 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
"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 [] (((Text, Value) -> [(Text, Value)] -> [(Text, Value)]
forall a. a -> [a] -> [a]
:[]) ((Text, Value) -> [(Text, Value)])
-> (Int -> (Text, Value)) -> Int -> [(Text, Value)]
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Text
"utxoSize",) (Value -> (Text, Value)) -> (Int -> Value) -> Int -> (Text, Value)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Int -> Value
forall a. ToJSON a => a -> Value
toJSON (Int -> [(Text, Value)])
-> StrictMaybe Int -> StrictMaybe [(Text, Value)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictMaybe Int
utxoSize))
    TraceForgeEvent blk
_ -> Tracer IO (WithSeverity (TraceForgeEvent blk))
-> WithSeverity (TraceForgeEvent blk) -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith (TracingVerbosity
-> Trace IO Text -> Tracer IO (WithSeverity (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 (TraceForgeEvent blk)
ev
 where
   nkUtxoSize
     :: NodeKernel IO RemoteConnectionId LocalConnectionId blk -> IO Int
   nkUtxoSize :: NodeKernel IO RemoteConnectionId LocalConnectionId blk -> IO Int
nkUtxoSize NodeKernel{ChainDB IO blk
$sel:getChainDB:NodeKernel :: forall (m :: * -> *) remotePeer localPeer blk.
NodeKernel m remotePeer localPeer blk -> ChainDB m blk
getChainDB :: ChainDB IO blk
getChainDB} =
     STM (ExtLedgerState blk) -> IO (ExtLedgerState blk)
forall a. STM a -> IO a
atomically (ChainDB IO blk -> STM IO (ExtLedgerState blk)
forall (m :: * -> *) blk.
ChainDB m blk -> STM m (ExtLedgerState blk)
ChainDB.getCurrentLedger ChainDB IO blk
getChainDB)
     IO (ExtLedgerState blk) -> (ExtLedgerState blk -> Int) -> IO Int
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> 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

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
_ [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
  :: ( Consensus.RunNode blk
     , LedgerQueries blk
     , ToObject (CannotForge blk)
     , ToObject (LedgerErr (LedgerState blk))
     , ToObject (OtherHeaderEnvelopeError blk)
     , ToObject (ValidationErr (BlockProtocol blk))
     , ToObject (ForgeStateUpdateError blk)
     )
  => TracingVerbosity
  -> Trace IO Text
  -> ForgeTracers
  -> NodeKernelData blk
  -> IORef BlockchainCounters
  -> Tracer IO (Consensus.TraceForgeEvent blk)
forgeTracer :: TracingVerbosity
-> Trace IO Text
-> ForgeTracers
-> NodeKernelData blk
-> IORef BlockchainCounters
-> Tracer IO (TraceForgeEvent blk)
forgeTracer TracingVerbosity
verb Trace IO Text
tr ForgeTracers
forgeTracers NodeKernelData blk
nodeKern IORef BlockchainCounters
bcCounters =
  (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
$ \TraceForgeEvent blk
ev -> do
    Tracer IO (TraceForgeEvent blk) -> TraceForgeEvent blk -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith (Trace IO Text -> Tracer IO (TraceForgeEvent blk)
forall blk. Trace IO Text -> Tracer IO (TraceForgeEvent blk)
measureTxsEnd Trace IO Text
tr) TraceForgeEvent blk
ev
    Tracer IO (TraceForgeEvent blk) -> TraceForgeEvent blk -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith (IORef BlockchainCounters
-> Trace IO Text -> Tracer IO (TraceForgeEvent blk)
forall blk.
IORef BlockchainCounters
-> Trace IO Text -> Tracer IO (TraceForgeEvent blk)
notifyBlockForging IORef BlockchainCounters
bcCounters Trace IO Text
tr) TraceForgeEvent blk
ev
    Tracer IO (TraceForgeEvent blk) -> TraceForgeEvent blk -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith (IORef BlockchainCounters
-> Trace IO Text -> Tracer IO (TraceForgeEvent blk)
forall blk.
IORef BlockchainCounters
-> Trace IO Text -> Tracer IO (TraceForgeEvent blk)
notifySlotsMissedIfNeeded IORef BlockchainCounters
bcCounters Trace IO Text
tr) TraceForgeEvent blk
ev
    -- Consensus tracer
    Tracer IO (TraceForgeEvent blk) -> TraceForgeEvent blk -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith (Tracer IO (WithSeverity (TraceForgeEvent blk))
-> Tracer IO (TraceForgeEvent blk)
forall a (m :: * -> *).
HasSeverityAnnotation a =>
Tracer m (WithSeverity a) -> Tracer m a
annotateSeverity
                 (Tracer IO (WithSeverity (TraceForgeEvent blk))
 -> Tracer IO (TraceForgeEvent blk))
-> Tracer IO (WithSeverity (TraceForgeEvent blk))
-> Tracer IO (TraceForgeEvent blk)
forall a b. (a -> b) -> a -> b
$ ForgeTracers
-> NodeKernelData blk
-> TracingVerbosity
-> Trace IO Text
-> Tracer IO (WithSeverity (TraceForgeEvent blk))
forall blk.
(RunNode blk, LedgerQueries blk, ToObject (CannotForge blk),
 ToObject (LedgerErr (LedgerState blk)),
 ToObject (OtherHeaderEnvelopeError blk),
 ToObject (ValidationErr (BlockProtocol blk)),
 ToObject (ForgeStateUpdateError blk)) =>
ForgeTracers
-> NodeKernelData blk
-> TracingVerbosity
-> Trace IO Text
-> Tracer IO (WithSeverity (TraceForgeEvent blk))
teeForge ForgeTracers
forgeTracers NodeKernelData blk
nodeKern TracingVerbosity
verb
                 (Trace IO Text -> Tracer IO (WithSeverity (TraceForgeEvent blk)))
-> Trace IO Text -> Tracer IO (WithSeverity (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) TraceForgeEvent blk
ev

notifyBlockForging
  :: IORef BlockchainCounters
  -> Trace IO Text
  -> Tracer IO (Consensus.TraceForgeEvent blk)
notifyBlockForging :: IORef BlockchainCounters
-> Trace IO Text -> Tracer IO (TraceForgeEvent blk)
notifyBlockForging IORef BlockchainCounters
bcCounters 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.TraceForgedBlock {} -> do
    Word64
updatedBlocksForged <- IORef BlockchainCounters
-> (BlockchainCounters -> (BlockchainCounters, Word64))
-> IO Word64
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef BlockchainCounters
bcCounters (\BlockchainCounters
cnts -> let nc :: Word64
nc = BlockchainCounters -> Word64
bcBlocksForgedNum BlockchainCounters
cnts Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
1
                                                                   in (BlockchainCounters
cnts { bcBlocksForgedNum :: Word64
bcBlocksForgedNum = Word64
nc }, Word64
nc)
                                                         )
    Text -> Word64 -> Trace IO Text -> IO ()
traceCounter Text
"blocksForgedNum" Word64
updatedBlocksForged Trace IO Text
tr
  Consensus.TraceNodeCannotForge {} -> do
    -- It means that node have tried to forge new block, but because of misconfiguration
    -- (for example, invalid key) it's impossible.
    Word64
updatedNodeCannotForge <- IORef BlockchainCounters
-> (BlockchainCounters -> (BlockchainCounters, Word64))
-> IO Word64
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef BlockchainCounters
bcCounters ((BlockchainCounters -> (BlockchainCounters, Word64)) -> IO Word64)
-> (BlockchainCounters -> (BlockchainCounters, Word64))
-> IO Word64
forall a b. (a -> b) -> a -> b
$ \BlockchainCounters
cnts ->
      let nc :: Word64
nc = BlockchainCounters -> Word64
bcNodeCannotForgeNum BlockchainCounters
cnts Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
1
      in (BlockchainCounters
cnts { bcNodeCannotForgeNum :: Word64
bcNodeCannotForgeNum = Word64
nc }, Word64
nc)
    Text -> Word64 -> Trace IO Text -> IO ()
traceCounter Text
"nodeCannotForge" Word64
updatedNodeCannotForge Trace IO Text
tr
  -- The rest of the constructors.
  TraceForgeEvent blk
_ -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

notifySlotsMissedIfNeeded
  :: IORef BlockchainCounters
  -> Trace IO Text
  -> Tracer IO (Consensus.TraceForgeEvent blk)
notifySlotsMissedIfNeeded :: IORef BlockchainCounters
-> Trace IO Text -> Tracer IO (TraceForgeEvent blk)
notifySlotsMissedIfNeeded IORef BlockchainCounters
bcCounters 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.TraceNodeIsLeader {} -> do
    Word64
updatedNodeIsLeaderNum <- IORef BlockchainCounters
-> (BlockchainCounters -> (BlockchainCounters, Word64))
-> IO Word64
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef BlockchainCounters
bcCounters (\BlockchainCounters
cnts -> let nc :: Word64
nc = BlockchainCounters -> Word64
bcNodeIsLeaderNum BlockchainCounters
cnts Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
1
                                                                      in (BlockchainCounters
cnts { bcNodeIsLeaderNum :: Word64
bcNodeIsLeaderNum = Word64
nc }, Word64
nc)
                                                            )
    Text -> Word64 -> Trace IO Text -> IO ()
traceCounter Text
"nodeIsLeaderNum" Word64
updatedNodeIsLeaderNum Trace IO Text
tr
  Consensus.TraceNodeNotLeader {} -> 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.
    BlockchainCounters
counters <- IORef BlockchainCounters -> IO BlockchainCounters
forall a. IORef a -> IO a
readIORef IORef BlockchainCounters
bcCounters
    let howManyBlocksWereForged :: Word64
howManyBlocksWereForged = BlockchainCounters -> Word64
bcBlocksForgedNum BlockchainCounters
counters
        timesNodeWasALeader :: Word64
timesNodeWasALeader = BlockchainCounters -> Word64
bcNodeIsLeaderNum BlockchainCounters
counters
        numberOfMissedSlots :: Word64
numberOfMissedSlots = Word64
timesNodeWasALeader Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
howManyBlocksWereForged
    if Word64
numberOfMissedSlots Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
> Word64
0
    then do
        -- Node was a leader more times than the number of forged blocks,
        -- it means that some slots were missed.
      Word64
updatesSlotsMissed <- IORef BlockchainCounters
-> (BlockchainCounters -> (BlockchainCounters, Word64))
-> IO Word64
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef BlockchainCounters
bcCounters (\BlockchainCounters
cnts -> let nc :: Word64
nc = BlockchainCounters -> Word64
bcSlotsMissedNum BlockchainCounters
cnts Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
numberOfMissedSlots
                                                                    in (BlockchainCounters
cnts { bcSlotsMissedNum :: Word64
bcSlotsMissedNum = Word64
nc }, Word64
nc)
                                                          )
      Text -> Word64 -> Trace IO Text -> IO ()
traceCounter Text
"slotsMissedNum" Word64
updatesSlotsMissed Trace IO Text
tr
    else () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  -- The rest of the constructors.
  TraceForgeEvent blk
_ -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()


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

notifyTxsProcessed :: IORef BlockchainCounters -> Trace IO Text -> Tracer IO (TraceEventMempool blk)
notifyTxsProcessed :: IORef BlockchainCounters
-> Trace IO Text -> Tracer IO (TraceEventMempool blk)
notifyTxsProcessed IORef BlockchainCounters
bcCounters 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 [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.
    Word64
updatedTxProcessed <- IORef BlockchainCounters
-> (BlockchainCounters -> (BlockchainCounters, Word64))
-> IO Word64
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef BlockchainCounters
bcCounters (\BlockchainCounters
cnts -> let nc :: Word64
nc = BlockchainCounters -> Word64
bcTxsProcessedNum BlockchainCounters
cnts Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([GenTx blk] -> Int
forall a. HasLength a => a -> Int
length [GenTx blk]
txs)
                                                                  in (BlockchainCounters
cnts { bcTxsProcessedNum :: Word64
bcTxsProcessedNum = Word64
nc }, Word64
nc)
                                                        )
    Text -> Word64 -> Trace IO Text -> IO ()
traceCounter Text
"txsProcessedNum" Word64
updatedTxProcessed Trace IO Text
tr
  -- 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     GenTx blk
_tx0 MempoolSize
_ MempoolSize
tot0 -> (Int
1, MempoolSize
tot0)
                    TraceMempoolRejectedTx  GenTx blk
_tx0 ApplyTxErr blk
_ MempoolSize
tot0 -> (Int
1, MempoolSize
tot0)
                    TraceMempoolRemoveTxs   [GenTx blk]
txs0   MempoolSize
tot0 -> ([GenTx blk] -> Int
forall a. HasLength a => a -> Int
length [GenTx blk]
txs0, MempoolSize
tot0)
                    TraceMempoolManuallyRemovedTxs [GenTxId blk]
txs0 [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
+ [GenTx blk] -> Int
forall a. HasLength a => a -> Int
length [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
  :: ( Show (ApplyTxErr blk)
     , ToJSON (GenTxId blk)
     , ToObject (ApplyTxErr blk)
     , ToObject (GenTx blk)
     )
  => TraceSelection
  -> Trace IO Text
  -> IORef BlockchainCounters
  -> Tracer IO (TraceEventMempool blk)
mempoolTracer :: TraceSelection
-> Trace IO Text
-> IORef BlockchainCounters
-> Tracer IO (TraceEventMempool blk)
mempoolTracer TraceSelection
tc Trace IO Text
tracer IORef BlockchainCounters
bChainCounters = (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 (IORef BlockchainCounters
-> Trace IO Text -> Tracer IO (TraceEventMempool blk)
forall blk.
IORef BlockchainCounters
-> Trace IO Text -> Tracer IO (TraceEventMempool blk)
notifyTxsProcessed IORef BlockchainCounters
bChainCounters Trace IO Text
tracer) TraceEventMempool blk
ev
    Tracer IO (TraceEventMempool blk) -> TraceEventMempool blk -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith (Trace IO Text -> Tracer IO (TraceEventMempool blk)
forall blk. Trace IO Text -> Tracer IO (TraceEventMempool blk)
measureTxsStart 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.
(Show (ApplyTxErr blk), ToJSON (GenTxId blk),
 ToObject (ApplyTxErr blk), ToObject (GenTx blk)) =>
TraceSelection
-> Trace IO Text -> Tracer IO (TraceEventMempool blk)
mpTracer TraceSelection
tc Trace IO Text
tr) TraceEventMempool blk
ev

mpTracer :: ( Show (ApplyTxErr blk)
            , ToJSON (GenTxId blk)
            , ToObject (ApplyTxErr blk)
            , ToObject (GenTx 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 (ForgeStateInfo blk)
forgeStateInfoMetricsTraceTransformer :: Proxy blk -> Trace IO a -> Tracer IO (ForgeStateInfo blk)
forgeStateInfoMetricsTraceTransformer Proxy blk
p Trace IO a
tr = (ForgeStateInfo blk -> IO ()) -> Tracer IO (ForgeStateInfo blk)
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer ((ForgeStateInfo blk -> IO ()) -> Tracer IO (ForgeStateInfo blk))
-> (ForgeStateInfo blk -> IO ()) -> Tracer IO (ForgeStateInfo blk)
forall a b. (a -> b) -> a -> b
$ \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 (ForgeStateInfo blk)
forgeStateInfoTracer :: Proxy blk
-> TraceSelection
-> Trace IO Text
-> Tracer IO (ForgeStateInfo blk)
forgeStateInfoTracer Proxy blk
p TraceSelection
_ts Trace IO Text
tracer = (ForgeStateInfo blk -> IO ()) -> Tracer IO (ForgeStateInfo blk)
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer ((ForgeStateInfo blk -> IO ()) -> Tracer IO (ForgeStateInfo blk))
-> (ForgeStateInfo blk -> IO ()) -> Tracer IO (ForgeStateInfo blk)
forall a b. (a -> b) -> a -> b
$ \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 (ForgeStateInfo blk) -> ForgeStateInfo blk -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith (Proxy blk -> Trace IO Text -> Tracer IO (ForgeStateInfo blk)
forall a blk.
HasKESMetricsData blk =>
Proxy blk -> Trace IO a -> Tracer IO (ForgeStateInfo blk)
forgeStateInfoMetricsTraceTransformer Proxy blk
p Trace IO Text
tr) ForgeStateInfo blk
ev
    Tracer IO (ForgeStateInfo blk) -> ForgeStateInfo blk -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith (Trace IO Text -> Tracer IO (ForgeStateInfo blk)
fsTracer Trace IO Text
tr) ForgeStateInfo blk
ev
  where
    fsTracer :: Trace IO Text -> Tracer IO (ForgeStateInfo blk)
    fsTracer :: Trace IO Text -> Tracer IO (ForgeStateInfo blk)
fsTracer Trace IO Text
tr = Tracer IO String -> Tracer IO (ForgeStateInfo blk)
forall a (m :: * -> *). Show a => Tracer m String -> Tracer m a
showTracing (Tracer IO String -> Tracer IO (ForgeStateInfo blk))
-> Tracer IO String -> Tracer IO (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'
  :: Show localPeer
  => 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 =
    Bool
-> TracingVerbosity
-> Text
-> Trace IO Text
-> Tracer
     IO
     (TraceLabelPeer
        localPeer
        (TraceSendRecv (ChainSync (Serialised blk) (Point blk) (Tip blk))))
forall a.
Transformable Text IO a =>
Bool -> TracingVerbosity -> Text -> Trace IO Text -> Tracer IO a
tracerOnOff (TraceSelection -> Bool
traceLocalChainSyncProtocol TraceSelection
trSel) TracingVerbosity
verb Text
"LocalChainSyncProtocol" Trace IO Text
tr
  , tTxSubmissionTracer :: Tracer
  IO
  (TraceLabelPeer
     localPeer
     (TraceSendRecv (LocalTxSubmission (GenTx blk) (ApplyTxErr blk))))
NodeToClient.tTxSubmissionTracer =
    Bool
-> TracingVerbosity
-> Text
-> Trace IO Text
-> Tracer
     IO
     (TraceLabelPeer
        localPeer
        (TraceSendRecv (LocalTxSubmission (GenTx blk) (ApplyTxErr blk))))
forall a.
Transformable Text IO a =>
Bool -> TracingVerbosity -> Text -> Trace IO Text -> Tracer IO a
tracerOnOff (TraceSelection -> Bool
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 =
    Bool
-> TracingVerbosity
-> Text
-> Trace IO Text
-> Tracer
     IO
     (TraceLabelPeer
        localPeer
        (TraceSendRecv (LocalStateQuery blk (Point blk) (Query blk))))
forall a.
Transformable Text IO a =>
Bool -> TracingVerbosity -> Text -> Trace IO Text -> Tracer IO a
tracerOnOff (TraceSelection -> Bool
traceLocalStateQueryProtocol TraceSelection
trSel) TracingVerbosity
verb Text
"LocalStateQueryProtocol" Trace IO Text
tr
  }

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

nodeToNodeTracers'
  :: ( Consensus.RunNode blk
     , ConvertTxId blk
     , HasTxs blk
     , Show 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))))
-> Tracers' peer blk e f
NodeToNode.Tracers
  { tChainSyncTracer :: Tracer
  IO
  (TraceLabelPeer
     peer
     (TraceSendRecv (ChainSync (Header blk) (Point blk) (Tip blk))))
NodeToNode.tChainSyncTracer = Bool
-> TracingVerbosity
-> Text
-> Trace IO Text
-> Tracer
     IO
     (TraceLabelPeer
        peer
        (TraceSendRecv (ChainSync (Header blk) (Point blk) (Tip blk))))
forall a.
Transformable Text IO a =>
Bool -> TracingVerbosity -> Text -> Trace IO Text -> Tracer IO a
tracerOnOff (TraceSelection -> Bool
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 = Bool
-> Text
-> Trace IO Text
-> Tracer
     IO
     (TraceLabelPeer
        peer
        (TraceSendRecv
           (ChainSync (SerialisedHeader blk) (Point blk) (Tip blk))))
forall a.
(Show a, HasSeverityAnnotation a) =>
Bool -> Text -> Trace IO Text -> Tracer IO a
showOnOff (TraceSelection -> Bool
traceChainSyncProtocol TraceSelection
trSel) Text
"ChainSyncProtocolSerialised" Trace IO Text
tr
  , tBlockFetchTracer :: Tracer
  IO
  (TraceLabelPeer peer (TraceSendRecv (BlockFetch blk (Point blk))))
NodeToNode.tBlockFetchTracer = Bool
-> TracingVerbosity
-> Text
-> Trace IO Text
-> Tracer
     IO
     (TraceLabelPeer peer (TraceSendRecv (BlockFetch blk (Point blk))))
forall a.
Transformable Text IO a =>
Bool -> TracingVerbosity -> Text -> Trace IO Text -> Tracer IO a
tracerOnOff (TraceSelection -> Bool
traceBlockFetchProtocol TraceSelection
trSel) TracingVerbosity
verb Text
"BlockFetchProtocol" Trace IO Text
tr
  , tBlockFetchSerialisedTracer :: Tracer
  IO
  (TraceLabelPeer
     peer (TraceSendRecv (BlockFetch (Serialised blk) (Point blk))))
NodeToNode.tBlockFetchSerialisedTracer = Bool
-> Text
-> Trace IO Text
-> Tracer
     IO
     (TraceLabelPeer
        peer (TraceSendRecv (BlockFetch (Serialised blk) (Point blk))))
forall a.
(Show a, HasSeverityAnnotation a) =>
Bool -> Text -> Trace IO Text -> Tracer IO a
showOnOff (TraceSelection -> Bool
traceBlockFetchProtocolSerialised TraceSelection
trSel) Text
"BlockFetchProtocolSerialised" Trace IO Text
tr
  , tTxSubmissionTracer :: Tracer
  IO
  (TraceLabelPeer
     peer (TraceSendRecv (TxSubmission (GenTxId blk) (GenTx blk))))
NodeToNode.tTxSubmissionTracer = Bool
-> TracingVerbosity
-> Text
-> Trace IO Text
-> Tracer
     IO
     (TraceLabelPeer
        peer (TraceSendRecv (TxSubmission (GenTxId blk) (GenTx blk))))
forall a.
Transformable Text IO a =>
Bool -> TracingVerbosity -> Text -> Trace IO Text -> Tracer IO a
tracerOnOff (TraceSelection -> Bool
traceTxSubmissionProtocol TraceSelection
trSel) TracingVerbosity
verb Text
"TxSubmissionProtocol" Trace IO Text
tr
  }

teeTraceBlockFetchDecision
    :: ( Eq peer
       , HasHeader blk
       , Show 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
tr) 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) =>
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
tr) WithSeverity
  [TraceLabelPeer peer (FetchDecision [Point (Header blk)])]
ev


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
      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
"peers" Trace IO Text
tr
      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
       )
    => 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
  :: forall blk. HasHeader (Header blk)
  => ChainDB.NewTipInfo blk
  -> AF.AnchoredFragment (Header blk)
  -> ChainInformation
chainInformation :: NewTipInfo blk -> AnchoredFragment (Header blk) -> ChainInformation
chainInformation NewTipInfo blk
newTipInfo AnchoredFragment (Header blk)
frag = ChainInformation :: Word64
-> Word64 -> Rational -> EpochNo -> Word64 -> ChainInformation
ChainInformation
    { slots :: Word64
slots       = Word64
slotN
    , blocks :: Word64
blocks      = Word64
blockN
    , density :: Rational
density     = Word64 -> Word64 -> Rational
calcDensity Word64
blockD Word64
slotD
    , 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
    }
  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 block.
HasHeader block =>
AnchoredFragment block -> Either (Anchor block) block
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 -> Text
readableTraceBlockchainTimeEvent :: TraceBlockchainTimeEvent -> Text
readableTraceBlockchainTimeEvent TraceBlockchainTimeEvent
ev = case TraceBlockchainTimeEvent
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

traceCounter
  :: Text
  -> Word64
  -> Trace IO Text
  -> IO ()
traceCounter :: Text -> Word64 -> Trace IO Text -> IO ()
traceCounter Text
logValueName Word64
aCounter Trace IO Text
tracer = do
  LOMeta
meta <- Severity -> PrivacyAnnotation -> IO LOMeta
forall (m :: * -> *).
MonadIO m =>
Severity -> PrivacyAnnotation -> m LOMeta
mkLOMeta Severity
Notice PrivacyAnnotation
Public
  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
tracer)
                   (LOMeta
meta, Text -> Measurable -> LOContent Text
forall a. Text -> Measurable -> LOContent a
LogValue Text
logValueName (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
aCounter))

tracerOnOff
  :: Transformable Text IO a
  => Bool -> TracingVerbosity -> LoggerName -> Trace IO Text -> Tracer IO a
tracerOnOff :: Bool -> TracingVerbosity -> Text -> Trace IO Text -> Tracer IO a
tracerOnOff Bool
False TracingVerbosity
_ Text
_ Trace IO Text
_ = Tracer IO a
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
tracerOnOff 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'
  :: Bool -> Tracer IO a -> Tracer IO a
tracerOnOff' :: Bool -> Tracer IO a -> Tracer IO a
tracerOnOff' Bool
False Tracer IO a
_ = Tracer IO a
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
tracerOnOff' 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)
  => Bool -> LoggerName -> Trace IO Text -> Tracer IO a
showOnOff :: Bool -> Text -> Trace IO Text -> Tracer IO a
showOnOff Bool
False Text
_ Trace IO Text
_ = Tracer IO a
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
showOnOff 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