{-# 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
import Cardano.Node.Protocol.Byron ()
import Cardano.Node.Protocol.Shelley ()
data Tracers peer localPeer blk = Tracers
{
Tracers peer localPeer blk -> Tracer IO (TraceEvent blk)
chainDBTracer :: Tracer IO (ChainDB.TraceEvent blk)
, Tracers peer localPeer blk -> Tracers IO peer localPeer blk
consensusTracers :: Consensus.Tracers IO peer localPeer blk
, Tracers peer localPeer blk
-> Tracers IO peer blk DeserialiseFailure
nodeToNodeTracers :: NodeToNode.Tracers IO peer blk DeserialiseFailure
, Tracers peer localPeer blk
-> Tracers IO localPeer blk DeserialiseFailure
nodeToClientTracers :: NodeToClient.Tracers IO localPeer blk DeserialiseFailure
, Tracers peer localPeer blk
-> Tracer IO (WithIPList (SubscriptionTrace SockAddr))
ipSubscriptionTracer :: Tracer IO (WithIPList (SubscriptionTrace Socket.SockAddr))
, Tracers peer localPeer blk
-> Tracer IO (WithDomainName (SubscriptionTrace SockAddr))
dnsSubscriptionTracer :: Tracer IO (WithDomainName (SubscriptionTrace Socket.SockAddr))
, Tracers peer localPeer blk -> Tracer IO (WithDomainName DnsTrace)
dnsResolverTracer :: Tracer IO (WithDomainName DnsTrace)
, Tracers peer localPeer blk
-> Tracer IO (WithAddr SockAddr ErrorPolicyTrace)
errorPolicyTracer :: Tracer IO (NtN.WithAddr Socket.SockAddr NtN.ErrorPolicyTrace)
, 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
, 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
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
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
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
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
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
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
$
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)
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
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
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
}
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
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 ()
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
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
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
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
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
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
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
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 ()
TraceForgeEvent blk
_ -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
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
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
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
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
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
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
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
}
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
data ChainInformation = ChainInformation
{ ChainInformation -> Word64
slots :: Word64
, ChainInformation -> Word64
blocks :: Word64
, ChainInformation -> Rational
density :: Rational
, ChainInformation -> EpochNo
epoch :: EpochNo
, ChainInformation -> Word64
slotInEpoch :: Word64
}
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)
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))
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
Left Anchor (Header blk)
_ -> Word64
1
Right Word64
0 -> Word64
1
Right Word64
b -> Word64
b
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