From 0305116dc8c54ad63ee234ab9dcb035653547e22 Mon Sep 17 00:00:00 2001 From: Yupanqui Date: Thu, 5 Aug 2021 12:39:12 +0300 Subject: [PATCH] cardano-node: integrate with trace-dispatcher --- cardano-node/cardano-node.cabal | 26 + .../src/Cardano/Node/Configuration/Logging.hs | 47 +- .../src/Cardano/Node/Configuration/POM.hs | 15 +- .../src/Cardano/Node/Handlers/Shutdown.hs | 3 +- .../src/Cardano/Node/Protocol/Byron.hs | 4 + .../src/Cardano/Node/Protocol/Shelley.hs | 4 + .../src/Cardano/Node/Protocol/Types.hs | 4 +- cardano-node/src/Cardano/Node/Run.hs | 159 ++- cardano-node/src/Cardano/Node/Types.hs | 1 + .../TraceDispatcher/BasicInfo/Combinators.hs | 158 +++ .../TraceDispatcher/BasicInfo/Types.hs | 116 ++ .../TraceDispatcher/ChainDB/Combinators.hs | 335 +++++ .../Cardano/TraceDispatcher/ChainDB/Docu.hs | 581 +++++++++ .../TraceDispatcher/ChainDB/Formatting.hs | 806 ++++++++++++ .../TraceDispatcher/Consensus/Combinators.hs | 345 +++++ .../Cardano/TraceDispatcher/Consensus/Docu.hs | 688 ++++++++++ .../Consensus/ForgingThreadStats.hs | 185 +++ .../TraceDispatcher/Consensus/Formatting.hs | 708 +++++++++++ .../Consensus/StartLeadershipCheck.hs | 193 +++ .../TraceDispatcher/Consensus/StateInfo.hs | 76 ++ .../src/Cardano/TraceDispatcher/Era/Byron.hs | 223 ++++ .../TraceDispatcher/Era/ConvertTxId.hs | 48 + .../Cardano/TraceDispatcher/Era/HardFork.hs | 372 ++++++ .../Cardano/TraceDispatcher/Era/Shelley.hs | 869 +++++++++++++ .../src/Cardano/TraceDispatcher/Formatting.hs | 58 + .../TraceDispatcher/Network/Combinators.hs | 829 ++++++++++++ .../Cardano/TraceDispatcher/Network/Docu.hs | 1111 +++++++++++++++++ .../TraceDispatcher/Network/Formatting.hs | 489 ++++++++ .../src/Cardano/TraceDispatcher/Peer.hs | 145 +++ .../src/Cardano/TraceDispatcher/Render.hs | 177 +++ .../src/Cardano/TraceDispatcher/Resources.hs | 29 + .../src/Cardano/TraceDispatcher/Tracers.hs | 996 +++++++++++++++ cardano-node/src/Cardano/Tracing/Config.hs | 9 +- .../src/Cardano/Tracing/Constraints.hs | 49 +- .../Cardano/Tracing/OrphanInstances/Common.hs | 11 +- cardano-node/src/Cardano/Tracing/Tracers.hs | 27 +- scripts/lite/configuration/shelley-1.yaml | 33 + scripts/lite/configuration/shelley-2.yaml | 33 + scripts/lite/configuration/shelley-3.yaml | 33 + 39 files changed, 9903 insertions(+), 92 deletions(-) create mode 100644 cardano-node/src/Cardano/TraceDispatcher/BasicInfo/Combinators.hs create mode 100644 cardano-node/src/Cardano/TraceDispatcher/BasicInfo/Types.hs create mode 100644 cardano-node/src/Cardano/TraceDispatcher/ChainDB/Combinators.hs create mode 100644 cardano-node/src/Cardano/TraceDispatcher/ChainDB/Docu.hs create mode 100644 cardano-node/src/Cardano/TraceDispatcher/ChainDB/Formatting.hs create mode 100644 cardano-node/src/Cardano/TraceDispatcher/Consensus/Combinators.hs create mode 100644 cardano-node/src/Cardano/TraceDispatcher/Consensus/Docu.hs create mode 100644 cardano-node/src/Cardano/TraceDispatcher/Consensus/ForgingThreadStats.hs create mode 100644 cardano-node/src/Cardano/TraceDispatcher/Consensus/Formatting.hs create mode 100644 cardano-node/src/Cardano/TraceDispatcher/Consensus/StartLeadershipCheck.hs create mode 100644 cardano-node/src/Cardano/TraceDispatcher/Consensus/StateInfo.hs create mode 100644 cardano-node/src/Cardano/TraceDispatcher/Era/Byron.hs create mode 100644 cardano-node/src/Cardano/TraceDispatcher/Era/ConvertTxId.hs create mode 100644 cardano-node/src/Cardano/TraceDispatcher/Era/HardFork.hs create mode 100644 cardano-node/src/Cardano/TraceDispatcher/Era/Shelley.hs create mode 100644 cardano-node/src/Cardano/TraceDispatcher/Formatting.hs create mode 100644 cardano-node/src/Cardano/TraceDispatcher/Network/Combinators.hs create mode 100644 cardano-node/src/Cardano/TraceDispatcher/Network/Docu.hs create mode 100644 cardano-node/src/Cardano/TraceDispatcher/Network/Formatting.hs create mode 100644 cardano-node/src/Cardano/TraceDispatcher/Peer.hs create mode 100644 cardano-node/src/Cardano/TraceDispatcher/Render.hs create mode 100644 cardano-node/src/Cardano/TraceDispatcher/Resources.hs create mode 100644 cardano-node/src/Cardano/TraceDispatcher/Tracers.hs diff --git a/cardano-node/cardano-node.cabal b/cardano-node/cardano-node.cabal index 53c42de4cc9..e8bde0c3758 100644 --- a/cardano-node/cardano-node.cabal +++ b/cardano-node/cardano-node.cabal @@ -75,6 +75,29 @@ library Cardano.Node.Run Cardano.Node.STM Cardano.Node.Types + Cardano.TraceDispatcher.Era.Byron + Cardano.TraceDispatcher.Era.HardFork + Cardano.TraceDispatcher.Era.Shelley + Cardano.TraceDispatcher.Era.ConvertTxId + Cardano.TraceDispatcher.ChainDB.Docu + Cardano.TraceDispatcher.ChainDB.Formatting + Cardano.TraceDispatcher.ChainDB.Combinators + Cardano.TraceDispatcher.Consensus.Docu + Cardano.TraceDispatcher.Consensus.Formatting + Cardano.TraceDispatcher.Consensus.Combinators + Cardano.TraceDispatcher.Consensus.StateInfo + Cardano.TraceDispatcher.Consensus.StartLeadershipCheck + Cardano.TraceDispatcher.Consensus.ForgingThreadStats + Cardano.TraceDispatcher.Resources + Cardano.TraceDispatcher.BasicInfo.Types + Cardano.TraceDispatcher.BasicInfo.Combinators + Cardano.TraceDispatcher.Peer + Cardano.TraceDispatcher.Network.Docu + Cardano.TraceDispatcher.Network.Formatting + Cardano.TraceDispatcher.Network.Combinators + Cardano.TraceDispatcher.Formatting + Cardano.TraceDispatcher.Render + Cardano.TraceDispatcher.Tracers Cardano.Tracing.Config Cardano.Tracing.Constraints Cardano.Tracing.ConvertTxId @@ -146,6 +169,9 @@ library , text , time , tracer-transformers + , trace-dispatcher + , trace-forward + , trace-resources , transformers , transformers-except , unordered-containers diff --git a/cardano-node/src/Cardano/Node/Configuration/Logging.hs b/cardano-node/src/Cardano/Node/Configuration/Logging.hs index 196405f9e51..3caaba6bd8b 100644 --- a/cardano-node/src/Cardano/Node/Configuration/Logging.hs +++ b/cardano-node/src/Cardano/Node/Configuration/Logging.hs @@ -1,8 +1,9 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} module Cardano.Node.Configuration.Logging @@ -24,10 +25,11 @@ module Cardano.Node.Configuration.Logging import Cardano.Prelude hiding (trace) +import qualified Control.Concurrent as Conc import qualified Control.Concurrent.Async as Async import Control.Exception.Safe (MonadCatch) import Control.Monad.Trans.Except.Extra (catchIOExceptT) -import Control.Tracer +import "contra-tracer" Control.Tracer import Data.List (nub) import qualified Data.Map as Map import Data.Text (pack) @@ -49,7 +51,8 @@ import qualified Cardano.BM.Configuration as Config import qualified Cardano.BM.Configuration.Model as Config import Cardano.BM.Data.Aggregated (Measurable (..)) import Cardano.BM.Data.Backend (Backend, BackendKind (..)) -import Cardano.BM.Data.LogItem (LOContent (..), LOMeta (..), LoggerName) +import Cardano.BM.Data.LogItem (LOContent (..), LOMeta (..), + LoggerName) import qualified Cardano.BM.Observer.Monadic as Monadic import qualified Cardano.BM.Observer.STM as Stm import Cardano.BM.Plugin (loadPlugin) @@ -63,13 +66,13 @@ import qualified Cardano.BM.Trace as Trace import Cardano.BM.Tracing import qualified Cardano.Chain.Genesis as Gen -import Cardano.Slotting.Slot (EpochSize (..)) import qualified Ouroboros.Consensus.BlockchainTime.WallClock.Types as WCT import Ouroboros.Consensus.Byron.Ledger.Conversions import Ouroboros.Consensus.Cardano.Block import Ouroboros.Consensus.Cardano.CanHardFork import qualified Ouroboros.Consensus.Config as Consensus -import Ouroboros.Consensus.Config.SupportsNode (ConfigSupportsNode (..)) +import Ouroboros.Consensus.Config.SupportsNode + (ConfigSupportsNode (..)) import Ouroboros.Consensus.HardFork.Combinator.Degenerate import Ouroboros.Consensus.Node.ProtocolInfo import Ouroboros.Consensus.Shelley.Ledger.Ledger @@ -80,6 +83,8 @@ import Cardano.Config.Git.Rev (gitRev) import Cardano.Node.Configuration.POM (NodeConfiguration (..), ncProtocol) import Cardano.Node.Protocol.Types (SomeConsensusProtocol (..)) import Cardano.Node.Types +import Cardano.Slotting.Slot (EpochSize (..)) +import Cardano.Tracing.Config (TraceOptions (..)) import Cardano.Tracing.OrphanInstances.Common () import Paths_cardano_node (version) @@ -148,12 +153,12 @@ loggingCLIConfiguration = maybe emptyConfig readConfig -- | Create logging feature for `cardano-node` createLoggingLayer - :: Text + :: TraceOptions + -> Text -> NodeConfiguration -> SomeConsensusProtocol -> ExceptT ConfigError IO LoggingLayer -createLoggingLayer ver nodeConfig' p = do - +createLoggingLayer topt ver nodeConfig' p = do logConfig <- loggingCLIConfiguration $ if ncLoggingSwitch nodeConfig' -- Re-interpret node config again, as logging 'Configuration': @@ -165,13 +170,13 @@ createLoggingLayer ver nodeConfig' p = do Config.setTextOption logConfig "appversion" ver Config.setTextOption logConfig "appcommit" gitRev - (baseTrace, switchBoard) <- liftIO $ setupTrace_ logConfig "cardano" + (baseTrace', switchBoard) <- liftIO $ setupTrace_ logConfig "cardano" let loggingEnabled :: Bool loggingEnabled = ncLoggingSwitch nodeConfig' trace :: Trace IO Text trace = if loggingEnabled - then baseTrace + then baseTrace' else Trace.nullTracer when loggingEnabled $ liftIO $ @@ -244,7 +249,7 @@ createLoggingLayer ver nodeConfig' p = do when (ncLogMetrics nodeConfig) $ -- Record node metrics, if configured - startCapturingMetrics trace + startCapturingMetrics topt trace mkLogLayer :: Configuration -> Switchboard Text -> Maybe EKGDirect -> Trace IO Text -> LoggingLayer mkLogLayer logConfig switchBoard mbEkgDirect trace = @@ -267,14 +272,20 @@ createLoggingLayer ver nodeConfig' p = do , llEKGDirect = mbEkgDirect } - startCapturingMetrics :: Trace IO Text -> IO () - startCapturingMetrics tr = do + startCapturingMetrics :: TraceOptions + -> Trace IO Text + -> IO () + startCapturingMetrics (TraceDispatcher _) _tr = do + pure () + + startCapturingMetrics _ tr = do void . Async.async . forever $ do readResourceStats >>= maybe (pure ()) (traceResourceStats (appendName "node" tr)) - threadDelay 1000000 -- TODO: make configurable + Conc.threadDelay 1000000 -- TODO: make configurable + traceResourceStats :: Trace IO Text -> ResourceStats -> IO () traceResourceStats tr rs = do traceWith (toLogObject' NormalVerbosity $ appendName "resources" tr) rs diff --git a/cardano-node/src/Cardano/Node/Configuration/POM.hs b/cardano-node/src/Cardano/Node/Configuration/POM.hs index 7667ed349b6..7cc7acbd5de 100644 --- a/cardano-node/src/Cardano/Node/Configuration/POM.hs +++ b/cardano-node/src/Cardano/Node/Configuration/POM.hs @@ -148,9 +148,16 @@ instance FromJSON PartialNodeConfiguration where pncMaxConcurrencyDeadline <- Last <$> v .:? "MaxConcurrencyDeadline" -- Logging parameters - pncLoggingSwitch <- Last . Just <$> v .:? "TurnOnLogging" .!= True - pncLogMetrics <- Last <$> v .:? "TurnOnLogMetrics" - pncTraceConfig <- Last . Just <$> traceConfigParser v + pncLoggingSwitch' <- v .:? "TurnOnLogging" .!= True + pncLogMetrics <- Last <$> v .:? "TurnOnLogMetrics" + useTraceDispatcher <- v .:? "UseTraceDispatcher" .!= False + pncTraceConfig <- if pncLoggingSwitch' + then Last . Just <$> + traceConfigParser v + (if useTraceDispatcher + then TraceDispatcher + else TracingOn) + else return . Last $ Just TracingOff -- Protocol parameters protocol <- v .:? "Protocol" .!= ByronProtocol @@ -175,7 +182,7 @@ instance FromJSON PartialNodeConfiguration where , pncTestEnableDevelopmentNetworkProtocols , pncMaxConcurrencyBulkSync , pncMaxConcurrencyDeadline - , pncLoggingSwitch + , pncLoggingSwitch = Last $ Just pncLoggingSwitch' , pncLogMetrics , pncTraceConfig , pncNodeIPv4Addr = mempty diff --git a/cardano-node/src/Cardano/Node/Handlers/Shutdown.hs b/cardano-node/src/Cardano/Node/Handlers/Shutdown.hs index c5c563353a9..7aaa3072975 100644 --- a/cardano-node/src/Cardano/Node/Handlers/Shutdown.hs +++ b/cardano-node/src/Cardano/Node/Handlers/Shutdown.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE PackageImports #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -33,7 +34,7 @@ import qualified System.Process as IO (createPipeFd) import Cardano.BM.Data.Tracer (TracingVerbosity (..), severityNotice, trTransformer) import Cardano.BM.Trace import Cardano.Slotting.Slot (WithOrigin (..)) -import Control.Tracer +import "contra-tracer" Control.Tracer import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB import Ouroboros.Consensus.Util.ResourceRegistry (ResourceRegistry) import Ouroboros.Consensus.Util.STM (Watcher(..), forkLinkedWatcher) diff --git a/cardano-node/src/Cardano/Node/Protocol/Byron.hs b/cardano-node/src/Cardano/Node/Protocol/Byron.hs index 2e51e4dd16c..c6d10c815aa 100644 --- a/cardano-node/src/Cardano/Node/Protocol/Byron.hs +++ b/cardano-node/src/Cardano/Node/Protocol/Byron.hs @@ -40,6 +40,10 @@ import Cardano.Tracing.OrphanInstances.Byron () import Cardano.Tracing.OrphanInstances.HardFork () import Cardano.Tracing.OrphanInstances.Shelley () +import Cardano.TraceDispatcher.Era.Byron () +import Cardano.TraceDispatcher.Era.HardFork () +import Cardano.TraceDispatcher.ChainDB.Formatting () + ------------------------------------------------------------------------------ -- Byron protocol diff --git a/cardano-node/src/Cardano/Node/Protocol/Shelley.hs b/cardano-node/src/Cardano/Node/Protocol/Shelley.hs index c83151b16aa..02128fc215a 100644 --- a/cardano-node/src/Cardano/Node/Protocol/Shelley.hs +++ b/cardano-node/src/Cardano/Node/Protocol/Shelley.hs @@ -54,6 +54,10 @@ import Cardano.Node.Types import Cardano.Tracing.OrphanInstances.HardFork () import Cardano.Tracing.OrphanInstances.Shelley () +import Cardano.TraceDispatcher.Era.HardFork () +import Cardano.TraceDispatcher.Era.Shelley () +import Cardano.TraceDispatcher.Formatting () + import Cardano.Node.Protocol.Types ------------------------------------------------------------------------------ diff --git a/cardano-node/src/Cardano/Node/Protocol/Types.hs b/cardano-node/src/Cardano/Node/Protocol/Types.hs index 7daac7d5dd8..4bbd8618d37 100644 --- a/cardano-node/src/Cardano/Node/Protocol/Types.hs +++ b/cardano-node/src/Cardano/Node/Protocol/Types.hs @@ -5,6 +5,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE MonoLocalBinds #-} module Cardano.Node.Protocol.Types ( Protocol(..) @@ -23,6 +24,7 @@ import Cardano.Node.Orphans () import Cardano.Tracing.Constraints (TraceConstraints) import Cardano.Tracing.Metrics (HasKESInfo, HasKESMetricsData) + data Protocol = ByronProtocol | ShelleyProtocol | CardanoProtocol @@ -47,8 +49,6 @@ instance FromJSON Protocol where _ -> fail $ "Parsing of Protocol failed. " <> show str <> " is not a valid protocol" - - data SomeConsensusProtocol where SomeConsensusProtocol :: forall blk. ( Cardano.Protocol IO blk diff --git a/cardano-node/src/Cardano/Node/Run.hs b/cardano-node/src/Cardano/Node/Run.hs index a1734f2f744..90faa82d993 100644 --- a/cardano-node/src/Cardano/Node/Run.hs +++ b/cardano-node/src/Cardano/Node/Run.hs @@ -1,9 +1,10 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PackageImports #-} {-# LANGUAGE ScopedTypeVariables #-} #if !defined(mingw32_HOST_OS) @@ -20,15 +21,16 @@ import Prelude (String) import qualified Control.Concurrent.Async as Async import Control.Monad.Trans.Except.Extra (left) -import Control.Tracer +import "contra-tracer" Control.Tracer import Data.Text (breakOn, pack, take) import qualified Data.Text as Text -import Data.Time.Clock (getCurrentTime) +import Data.Time.Clock (UTCTime, getCurrentTime) import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds) import Data.Version (showVersion) import Network.HostName (getHostName) import Network.Socket (AddrInfo, Socket) -import System.Directory (canonicalizePath, createDirectoryIfMissing, makeAbsolute) +import System.Directory (canonicalizePath, createDirectoryIfMissing, + makeAbsolute) import System.Environment (lookupEnv) #ifdef UNIX import System.Posix.Files @@ -37,40 +39,54 @@ import System.Posix.Types (FileMode) import System.Win32.File #endif -import Cardano.BM.Data.LogItem (LOContent (..), LogObject (..), PrivacyAnnotation (..), - mkLOMeta) -import Cardano.BM.Data.Tracer (ToLogObject (..), TracingVerbosity (..)) +import Cardano.BM.Data.LogItem (LOContent (..), LogObject (..), + PrivacyAnnotation (..), mkLOMeta) +import Cardano.BM.Data.Tracer (ToLogObject (..), + TracingVerbosity (..)) import Cardano.BM.Data.Transformers (setHostname) import Cardano.BM.Trace import Paths_cardano_node (version) import qualified Cardano.Crypto.Libsodium as Crypto -import Cardano.Node.Configuration.Logging (LoggingLayer (..), Severity (..), - createLoggingLayer, nodeBasicInfo, shutdownLoggingLayer) +import qualified Cardano.Logging as NL +import Cardano.Node.Configuration.Logging (EKGDirect (..), + LoggingLayer (..), Severity (..), createLoggingLayer, + nodeBasicInfo, shutdownLoggingLayer) import Cardano.Node.Configuration.POM (NodeConfiguration (..), - PartialNodeConfiguration (..), defaultPartialNodeConfiguration, - makeNodeConfiguration, parseNodeConfigurationFP) + PartialNodeConfiguration (..), + defaultPartialNodeConfiguration, makeNodeConfiguration, + parseNodeConfigurationFP) import Cardano.Node.Types +import Cardano.TraceDispatcher.BasicInfo.Combinators (getBasicInfo) +import Cardano.TraceDispatcher.BasicInfo.Types +import Cardano.TraceDispatcher.Era.Byron () +import Cardano.TraceDispatcher.Era.Shelley () +import Cardano.TraceDispatcher.Tracers (mkDispatchTracers) import Cardano.Tracing.Config (TraceOptions (..), TraceSelection (..)) import Cardano.Tracing.Constraints (TraceConstraints) -import Cardano.Tracing.Metrics (HasKESInfo (..), HasKESMetricsData (..)) import qualified Ouroboros.Consensus.Config as Consensus import Ouroboros.Consensus.Config.SupportsNode (getNetworkMagic) -import Ouroboros.Consensus.Node (DiffusionArguments (..), DiffusionTracers (..), - DnsSubscriptionTarget (..), IPSubscriptionTarget (..), RunNode, RunNodeArgs (..), - StdRunNodeArgs (..)) +import Ouroboros.Consensus.Node (DiffusionArguments (..), + DiffusionTracers (..), DnsSubscriptionTarget (..), + IPSubscriptionTarget (..), RunNode, RunNodeArgs (..), + StdRunNodeArgs (..)) import qualified Ouroboros.Consensus.Node as Node (getChainDB, run) import Ouroboros.Consensus.Node.ProtocolInfo import Ouroboros.Consensus.Util.Orphans () -import Ouroboros.Network.NodeToNode (AcceptedConnectionsLimit (..), DiffusionMode) +import Ouroboros.Network.IOManager (withIOManager) +import Ouroboros.Network.NodeToNode (AcceptedConnectionsLimit (..), + DiffusionMode) import Cardano.Api import qualified Cardano.Api.Protocol.Types as Protocol +import Trace.Forward.Protocol.Type (NodeInfo (..)) + import Cardano.Node.Configuration.Socket (SocketOrSocketInfo (..), - gatherConfiguredSockets, getSocketOrSocketInfoAddr, renderSocketConfigError) + gatherConfiguredSockets, getSocketOrSocketInfoAddr, + renderSocketConfigError) import Cardano.Node.Configuration.Topology import Cardano.Node.Handlers.Shutdown import Cardano.Node.Protocol (mkConsensusProtocol) @@ -85,6 +101,7 @@ runNode :: PartialNodeConfiguration -> IO () runNode cmdPc = do + now <- getCurrentTime -- TODO: Remove sodiumInit: https://github.com/input-output-hk/cardano-base/issues/175 Crypto.sodiumInit @@ -108,9 +125,10 @@ runNode cmdPc = do p :: SomeConsensusProtocol <- case eitherSomeProtocol of Left err -> putStrLn (displayError err) >> exitFailure - Right p -> pure p + Right p -> pure p eLoggingLayer <- runExceptT $ createLoggingLayer + (ncTraceConfig nc) (Text.pack (showVersion version)) nc p @@ -119,15 +137,27 @@ runNode cmdPc = do Left err -> putTextLn (show err) >> exitFailure Right res -> return res + -- New logging initialisation + loggerConfiguration <- + case getLast $ pncConfigFile cmdPc of + Just fileName -> NL.readConfiguration (unConfigPath fileName) + Nothing -> putTextLn "No configuration file name found!" >> exitFailure + baseTrace <- NL.standardTracer Nothing + nodeInfo <- prepareNodeInfo now + forwardTrace <- withIOManager $ \iomgr -> NL.forwardTracer iomgr loggerConfiguration nodeInfo + mbEkgTrace <- case llEKGDirect loggingLayer of + Nothing -> pure Nothing + Just ekgDirect -> + liftM Just (NL.ekgTracer (Right (ekgServer ekgDirect))) + -- End new logging initialisation + !trace <- setupTrace loggingLayer let tracer = contramap pack $ toLogObject trace logTracingVerbosity nc tracer let handleNodeWithTracers - :: ( HasKESMetricsData blk - , HasKESInfo blk - , TraceConstraints blk + :: ( TraceConstraints blk , Protocol.Protocol IO blk ) => Protocol.ProtocolInfoArgs IO blk @@ -137,12 +167,22 @@ runNode cmdPc = do -- Used for ledger queries and peer connection status. nodeKernelData <- mkNodeKernelData let ProtocolInfo { pInfoConfig = cfg } = Protocol.protocolInfo runP - tracers <- mkTracers + let fp = case getLast (pncConfigFile cmdPc) of + Just fileName -> unConfigPath fileName + Nothing -> "No file path found!" + bi <- getBasicInfo nc p fp + tracers <- mkDispatchTracers (Consensus.configBlock cfg) (ncTraceConfig nc) trace nodeKernelData (llEKGDirect loggingLayer) + baseTrace + forwardTrace + mbEkgTrace + loggerConfiguration + bi + Async.withAsync (handlePeersListSimple trace nodeKernelData) $ \_peerLogingThread -> -- We ignore peer loging thread if it dies, but it will be killed @@ -163,7 +203,8 @@ logTracingVerbosity nc tracer = NormalVerbosity -> traceWith tracer "tracing verbosity = normal verbosity " MinimalVerbosity -> traceWith tracer "tracing verbosity = minimal verbosity " MaximalVerbosity -> traceWith tracer "tracing verbosity = maximal verbosity " - + TraceDispatcher _traceConf -> + pure () -- | Add the application name and unqualified hostname to the logging -- layer basic trace. -- @@ -191,6 +232,16 @@ handlePeersListSimple tr nodeKern = forever $ do getCurrentPeers nodeKern >>= tracePeers tr threadDelay 2000000 -- 2 seconds. +isOldLogging :: TraceOptions -> Bool +isOldLogging TracingOff = False +isOldLogging (TracingOn _) = True +isOldLogging (TraceDispatcher _) = False + +isNewLogging :: TraceOptions -> Bool +isNewLogging TracingOff = False +isNewLogging (TracingOn _) = False +isNewLogging (TraceDispatcher _) = True + -- | Sets up a simple node, which will run the chain sync protocol and block -- fetch protocol, and, if core, will also look at the mempool when trying to -- create a new block. @@ -216,7 +267,9 @@ handleSimpleNode scp runP trace nodeTracers nc onKernel = do let pInfo = Protocol.protocolInfo runP tracer = toLogObject trace - createTracers nc trace tracer + if isOldLogging (ncTraceConfig nc) + then createTracers nc trace tracer + else pure () (publicIPv4SocketOrAddr, publicIPv6SocketOrAddr, localSocketOrPath) <- do result <- runExceptT (gatherConfiguredSockets nc) @@ -257,18 +310,30 @@ handleSimpleNode scp runP trace nodeTracers nc onKernel = do ipv4 <- traverse getSocketOrSocketInfoAddr publicIPv4SocketOrAddr ipv6 <- traverse getSocketOrSocketInfoAddr publicIPv6SocketOrAddr - traceNamedObject - (appendName "addresses" trace) - (meta, LogMessage . Text.pack . show $ catMaybes [ipv4, ipv6]) - traceNamedObject - (appendName "diffusion-mode" trace) - (meta, LogMessage . Text.pack . show . ncDiffusionMode $ nc) - traceNamedObject - (appendName "dns-producers" trace) - (meta, LogMessage . Text.pack . show $ dnsProducers) - traceNamedObject - (appendName "ip-producers" trace) - (meta, LogMessage . Text.pack . show $ ipProducers) + if isOldLogging (ncTraceConfig nc) + then do + traceNamedObject + (appendName "addresses" trace) + (meta, LogMessage . Text.pack . show $ catMaybes [ipv4, ipv6]) + traceNamedObject + (appendName "diffusion-mode" trace) + (meta, LogMessage . Text.pack . show . ncDiffusionMode $ nc) + traceNamedObject + (appendName "dns-producers" trace) + (meta, LogMessage . Text.pack . show $ dnsProducers) + traceNamedObject + (appendName "ip-producers" trace) + (meta, LogMessage . Text.pack . show $ ipProducers) + else if isNewLogging (ncTraceConfig nc) + then do + let bin = BasicInfoNetwork { + niAddresses = catMaybes [ipv4, ipv6] + , niDiffusionMode = ncDiffusionMode $ nc + , niDnsProducers = dnsProducers + , niIpProducers = ipProducers + } + traceWith (basicInfoTracer nodeTracers) (BINetwork bin) + else pure () withShutdownHandling nc trace $ \sfds -> Node.run @@ -456,3 +521,15 @@ producerAddresses nt = . mapMaybe remoteAddressToNodeAddress . concatMap producers $ nodeSetup + +-- TODO: temporary function. It will be replaced by the real collector of node's info. +prepareNodeInfo :: UTCTime -> IO NodeInfo +prepareNodeInfo now = return $ + NodeInfo + { niName = "" + , niProtocol = "" + , niVersion = "" + , niCommit = "" + , niStartTime = now + , niSystemStartTime = now + } diff --git a/cardano-node/src/Cardano/Node/Types.hs b/cardano-node/src/Cardano/Node/Types.hs index ee5531031c3..3f33295d85e 100644 --- a/cardano-node/src/Cardano/Node/Types.hs +++ b/cardano-node/src/Cardano/Node/Types.hs @@ -4,6 +4,7 @@ {-# LANGUAGE GeneralisedNewtypeDeriving #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE MonoLocalBinds #-} module Cardano.Node.Types ( -- * Configuration diff --git a/cardano-node/src/Cardano/TraceDispatcher/BasicInfo/Combinators.hs b/cardano-node/src/Cardano/TraceDispatcher/BasicInfo/Combinators.hs new file mode 100644 index 00000000000..baaca113ed0 --- /dev/null +++ b/cardano-node/src/Cardano/TraceDispatcher/BasicInfo/Combinators.hs @@ -0,0 +1,158 @@ +{-# LANGUAGE GADTs #-} +{-# OPTIONS_GHC -Wno-deprecations #-} + +module Cardano.TraceDispatcher.BasicInfo.Combinators + ( + getBasicInfo + , severityBasicInfo + , namesForBasicInfo + , docBasicInfo + ) where + +import Cardano.Config.Git.Rev (gitRev) +import Cardano.Logging +import Cardano.Prelude hiding (trace) +import Paths_cardano_node (version) + +import Data.Text (pack) +import Data.Time (getCurrentTime) +import Data.Version (showVersion) + +import Cardano.Api.Protocol.Types (BlockType (..), protocolInfo) +import qualified Cardano.Chain.Genesis as Gen +import Cardano.Node.Configuration.POM (NodeConfiguration, ncProtocol) +import Cardano.Node.Protocol (SomeConsensusProtocol (..)) +import Cardano.Node.Types (protocolName) +import Cardano.Slotting.Slot (EpochSize (..)) +import Cardano.TraceDispatcher.BasicInfo.Types + +import qualified Ouroboros.Consensus.BlockchainTime.WallClock.Types as WCT +import Ouroboros.Consensus.Byron.Ledger.Conversions + (fromByronEpochSlots, fromByronSlotLength, + genesisSlotLength) +import Ouroboros.Consensus.Cardano.Block (HardForkLedgerConfig (..)) +import Ouroboros.Consensus.Cardano.CanHardFork + (ByronPartialLedgerConfig (..), + ShelleyPartialLedgerConfig (..)) +import qualified Ouroboros.Consensus.Config as Consensus +import Ouroboros.Consensus.Config.SupportsNode + (ConfigSupportsNode (..)) +import Ouroboros.Consensus.HardFork.Combinator.Degenerate + (HardForkLedgerConfig (..)) +import Ouroboros.Consensus.Node.ProtocolInfo (ProtocolInfo (..)) +import Ouroboros.Consensus.Shelley.Ledger.Ledger + (shelleyLedgerGenesis) + +import qualified Shelley.Spec.Ledger.API as SL + +severityBasicInfo :: BasicInfo -> SeverityS +severityBasicInfo _ = Notice + +namesForBasicInfo :: BasicInfo -> [Text] +namesForBasicInfo BICommon {} = ["Common"] +namesForBasicInfo BIShelley {} = ["ShelleyBased"] +namesForBasicInfo BIByron {} = ["Byron"] +namesForBasicInfo BINetwork {} = ["Network"] + +protoBasicInfoCommon :: BasicInfoCommon +protoBasicInfoCommon = undefined + +protoBasicInfoShelley :: BasicInfoShelleyBased +protoBasicInfoShelley = undefined + +protoBasicInfoByron :: BasicInfoByron +protoBasicInfoByron = undefined + +protoBasicInfoNetwork :: BasicInfoNetwork +protoBasicInfoNetwork = undefined + +docBasicInfo :: Documented BasicInfo +docBasicInfo = Documented [ + DocMsg + (BICommon protoBasicInfoCommon) + [] + "biConfigPath is the path to the config in use. \ + \\nbiProtocol is the name of the protocol, e.g. \"Byron\", \"Shelley\" \ + \or \"Byron; Shelley\". \ + \\nbiVersion is the version of the node software running. \ + \\nbiCommit is the commit revision of the software running. \ + \\nbiNodeStartTime gives the time this node was started." + , DocMsg + (BIShelley protoBasicInfoShelley) + [] + "bisEra is the current era, e.g. \"Shelley\", \"Allegra\", \"Mary\" \ + \or \"Alonzo\". \ + \\nbisSystemStartTime TODO JNF \ + \\nbisSlotLength gives the length of a slot as time interval. \ + \\nbisEpochLength gives the number of slots which forms an epoch. \ + \\nbisSlotsPerKESPeriod gives the slots per KES period." + , DocMsg + (BIByron protoBasicInfoByron) + [] + "bibSystemStartTime TODO JNF \ + \\nbibSlotLength gives the length of a slot as time interval. \ + \\nbibEpochLength gives the number of slots which forms an epoch." + , DocMsg + (BINetwork protoBasicInfoNetwork) + [] + "niAddresses IPv4 or IPv6 socket ready to accept connections\ + \or diffusion addresses. \ + \\nniDiffusionMode shows if the node runs only initiator or both\ + \initiator or responder node. \ + \\nniDnsProducers shows the list of domain names to subscribe to. \ + \\nniIpProducers shows the list of ip subscription addresses." + ] + +getBasicInfo :: + NodeConfiguration + -> SomeConsensusProtocol + -> FilePath + -> IO [BasicInfo] +getBasicInfo nc (SomeConsensusProtocol whichP pForInfo) fp = do + nodeStartTime <- getCurrentTime + let cfg = pInfoConfig $ protocolInfo pForInfo + basicInfoCommon = BICommon $ BasicInfoCommon { + biProtocol = pack . protocolName $ ncProtocol nc + , biVersion = pack . showVersion $ version + , biCommit = gitRev + , biNodeStartTime = nodeStartTime + , biConfigPath = fp + , biNetworkMagic = getNetworkMagic $ Consensus.configBlock cfg + } + protocolDependentItems = + case whichP of + ByronBlockType -> + let DegenLedgerConfig cfgByron = Consensus.configLedger cfg + in [getGenesisValuesByron cfg cfgByron] + ShelleyBlockType -> + let DegenLedgerConfig cfgShelley = Consensus.configLedger cfg + in [getGenesisValues "Shelley" cfgShelley] + CardanoBlockType -> + let CardanoLedgerConfig cfgByron cfgShelley cfgAllegra cfgMary cfgAlonzo = Consensus.configLedger cfg + in getGenesisValuesByron cfg cfgByron + : getGenesisValues "Shelley" cfgShelley + : getGenesisValues "Allegra" cfgAllegra + : getGenesisValues "Mary" cfgMary + : [getGenesisValues "Alonzo" cfgAlonzo] + pure (basicInfoCommon : protocolDependentItems) + where + getGenesisValues era config = + let genesis = shelleyLedgerGenesis $ shelleyLedgerConfig config + in BIShelley $ BasicInfoShelleyBased { + bisEra = era + , bisSystemStartTime = SL.sgSystemStart genesis + , bisSlotLength = WCT.getSlotLength . WCT.mkSlotLength + $ SL.sgSlotLength genesis + , bisEpochLength = unEpochSize . SL.sgEpochLength $ genesis + , bisSlotsPerKESPeriod = SL.sgSlotsPerKESPeriod genesis + } + getGenesisValuesByron cfg config = + let genesis = byronLedgerConfig config + in BIByron $ BasicInfoByron { + bibSystemStartTime = WCT.getSystemStart . getSystemStart + $ Consensus.configBlock cfg + , bibSlotLength = WCT.getSlotLength . fromByronSlotLength + $ genesisSlotLength genesis + , bibEpochLength = unEpochSize . fromByronEpochSlots + $ Gen.configEpochSlots genesis + } diff --git a/cardano-node/src/Cardano/TraceDispatcher/BasicInfo/Types.hs b/cardano-node/src/Cardano/TraceDispatcher/BasicInfo/Types.hs new file mode 100644 index 00000000000..7dba3bd2b02 --- /dev/null +++ b/cardano-node/src/Cardano/TraceDispatcher/BasicInfo/Types.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE RecordWildCards #-} + +module Cardano.TraceDispatcher.BasicInfo.Types + ( + BasicInfo(..) + , BasicInfoCommon (..) + , BasicInfoShelleyBased (..) + , BasicInfoByron (..) + , BasicInfoNetwork (..) + ) where + + +import Data.Aeson (Value (String), (.=)) +import Data.Time.Clock (NominalDiffTime, UTCTime) +import Network.Socket (SockAddr) +import Data.Text (pack) + +import Cardano.Api (NetworkMagic (..)) +import Cardano.Logging +import Cardano.Node.Configuration.Socket (SocketOrSocketInfo (..)) +import Cardano.Prelude hiding (trace) + +import Ouroboros.Consensus.Node (DnsSubscriptionTarget (..), + IPSubscriptionTarget (..)) +import Ouroboros.Network.NodeToNode (DiffusionMode (..)) + + +data BasicInfo = + BICommon BasicInfoCommon + | BIShelley BasicInfoShelleyBased + | BIByron BasicInfoByron + | BINetwork BasicInfoNetwork + +data BasicInfoCommon = BasicInfoCommon { + biConfigPath :: FilePath + , biNetworkMagic :: NetworkMagic + , biProtocol :: Text + , biVersion :: Text + , biCommit :: Text + , biNodeStartTime :: UTCTime + } + +data BasicInfoShelleyBased = BasicInfoShelleyBased { + bisEra :: Text + , bisSystemStartTime :: UTCTime + , bisSlotLength :: NominalDiffTime + , bisEpochLength :: Word64 + , bisSlotsPerKESPeriod :: Word64 +} + +data BasicInfoByron = BasicInfoByron { + bibSystemStartTime :: UTCTime + , bibSlotLength :: NominalDiffTime + , bibEpochLength :: Word64 +} + +data BasicInfoNetwork = BasicInfoNetwork { + niAddresses :: [SocketOrSocketInfo SockAddr SockAddr] + , niDiffusionMode :: DiffusionMode + , niDnsProducers :: [DnsSubscriptionTarget] + , niIpProducers :: IPSubscriptionTarget + } + +instance LogFormatting BasicInfo where + forHuman (BINetwork (BasicInfoNetwork {..})) = + "Addresses " <> show niAddresses + <> ", DiffusionMode " <> show niDiffusionMode + <> ", DnsProducers " <> show niDnsProducers + <> ", IpProducers " <> show niIpProducers + forHuman (BIByron (BasicInfoByron {..})) = + "Era Byron" + <> ", Slot length " <> show bibSlotLength + <> ", Epoch length " <> show bibEpochLength + forHuman (BIShelley (BasicInfoShelleyBased {..})) = + "Era " <> bisEra + <> ", Slot length " <> show bisSlotLength + <> ", Epoch length " <> show bisEpochLength + <> ", Slots per KESPeriod " <> show bisSlotsPerKESPeriod + forHuman (BICommon (BasicInfoCommon {..})) = + "Config path " <> pack biConfigPath + <> ", Network magic " <> show biNetworkMagic + <> ", Protocol " <> show biProtocol + <> ", Version " <> show biVersion + <> ", Commit " <> show biCommit + <> ", Node start time " <> show biNodeStartTime + + forMachine _dtal (BINetwork (BasicInfoNetwork {..})) = + mkObject [ "kind" .= String "BasicInfoNetwork" + , "addresses" .= String (show niAddresses) + , "diffusionMode" .= String (show niDiffusionMode) + , "dnsProducers" .= String (show niDnsProducers) + , "ipProducers" .= String (show niIpProducers) + ] + forMachine _dtal (BIByron (BasicInfoByron {..})) = + mkObject [ "kind" .= String "BasicInfoByron" + , "systemStartTime" .= String (show bibSystemStartTime) + , "slotLength" .= String (show bibSlotLength) + , "epochLength" .= String (show bibEpochLength) + ] + forMachine _dtal (BIShelley (BasicInfoShelleyBased {..})) = + mkObject [ "kind" .= String "BasicInfoShelleyBased" + , "era" .= String bisEra + , "systemStartTime" .= String (show bisSystemStartTime) + , "slotLength" .= String (show bisSlotLength) + , "epochLength" .= String (show bisEpochLength) + , "slotsPerKESPeriod" .= String (show bisSlotsPerKESPeriod) + ] + forMachine _dtal (BICommon (BasicInfoCommon {..})) = + mkObject [ "kind" .= String "BasicInfoCommon" + , "configPath" .= String (pack biConfigPath) + , "networkMagic" .= String (show biNetworkMagic) + , "protocol" .= String biProtocol + , "version" .= String biVersion + , "commit" .= String biCommit + , "nodeStartTime" .= biNodeStartTime + ] diff --git a/cardano-node/src/Cardano/TraceDispatcher/ChainDB/Combinators.hs b/cardano-node/src/Cardano/TraceDispatcher/ChainDB/Combinators.hs new file mode 100644 index 00000000000..f479be3c1f1 --- /dev/null +++ b/cardano-node/src/Cardano/TraceDispatcher/ChainDB/Combinators.hs @@ -0,0 +1,335 @@ + +module Cardano.TraceDispatcher.ChainDB.Combinators + ( severityChainDB + , namesForChainDBTraceEvents + ) where + +import Cardano.Logging +import Cardano.Prelude + +import Ouroboros.Consensus.Ledger.Inspect (LedgerEvent (..)) +import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB +import qualified Ouroboros.Consensus.Storage.ImmutableDB as ImmDB +import qualified Ouroboros.Consensus.Storage.ImmutableDB.Impl.Types as ImmDB +import qualified Ouroboros.Consensus.Storage.LedgerDB.OnDisk as LedgerDB +import qualified Ouroboros.Consensus.Storage.VolatileDB as VolDB +import qualified Ouroboros.Consensus.Storage.VolatileDB.Impl as VolDb + +severityChainDB :: ChainDB.TraceEvent blk -> SeverityS +severityChainDB (ChainDB.TraceAddBlockEvent v) = gsTraceAddBlockEvent v +severityChainDB (ChainDB.TraceFollowerEvent v) = gsTraceFollowerEvent v +severityChainDB (ChainDB.TraceCopyToImmutableDBEvent v) = gsTraceCopyToImmutableDBEvent v +severityChainDB (ChainDB.TraceGCEvent v) = gsTraceGCEvent v +severityChainDB (ChainDB.TraceInitChainSelEvent v) = gsTraceInitChainSelEvent v +severityChainDB (ChainDB.TraceOpenEvent v) = gsTraceOpenEvent v +severityChainDB (ChainDB.TraceIteratorEvent v) = gsTraceIteratorEvent v +severityChainDB (ChainDB.TraceLedgerEvent v) = gsTraceLedgerEvent v +severityChainDB (ChainDB.TraceLedgerReplayEvent v) = gsTraceLedgerReplayEvent v +severityChainDB (ChainDB.TraceImmutableDBEvent v) = gsTraceImmutableDBEvent v +severityChainDB (ChainDB.TraceVolatileDBEvent v) = gsTraceVolatileDBEvent v + +gsTraceAddBlockEvent :: ChainDB.TraceAddBlockEvent blk -> SeverityS +gsTraceAddBlockEvent ChainDB.IgnoreBlockOlderThanK {} = Info +gsTraceAddBlockEvent ChainDB.IgnoreBlockAlreadyInVolatileDB {} = Info +gsTraceAddBlockEvent ChainDB.IgnoreInvalidBlock {} = Info +gsTraceAddBlockEvent ChainDB.AddedBlockToQueue {} = Debug +gsTraceAddBlockEvent ChainDB.BlockInTheFuture {} = Info +gsTraceAddBlockEvent ChainDB.AddedBlockToVolatileDB {} = Debug +gsTraceAddBlockEvent ChainDB.TryAddToCurrentChain {} = Debug +gsTraceAddBlockEvent ChainDB.TrySwitchToAFork {} = Info +gsTraceAddBlockEvent ChainDB.StoreButDontChange {} = Debug +gsTraceAddBlockEvent (ChainDB.AddedToCurrentChain events _ _ _) = + maximumDef Notice (map gsLedgerEvent events) +gsTraceAddBlockEvent (ChainDB.SwitchedToAFork events _ _ _) = + maximumDef Notice (map gsLedgerEvent events) +gsTraceAddBlockEvent (ChainDB.AddBlockValidation ev') = gsTraceValidationEvent ev' +gsTraceAddBlockEvent ChainDB.ChainSelectionForFutureBlock{} = Debug + +gsTraceValidationEvent :: ChainDB.TraceValidationEvent blk -> SeverityS +gsTraceValidationEvent ChainDB.InvalidBlock {} = Error +gsTraceValidationEvent ChainDB.InvalidCandidate {} = Error +gsTraceValidationEvent ChainDB.ValidCandidate {} = Info +gsTraceValidationEvent ChainDB.CandidateContainsFutureBlocks {} = Debug +gsTraceValidationEvent ChainDB.CandidateContainsFutureBlocksExceedingClockSkew{} = Error + +gsTraceFollowerEvent :: ChainDB.TraceFollowerEvent blk -> SeverityS +gsTraceFollowerEvent ChainDB.NewFollower {} = Debug +gsTraceFollowerEvent ChainDB.FollowerNoLongerInMem {} = Debug +gsTraceFollowerEvent ChainDB.FollowerSwitchToMem {} = Debug +gsTraceFollowerEvent ChainDB.FollowerNewImmIterator {} = Debug + +gsLedgerEvent :: LedgerEvent blk -> SeverityS +gsLedgerEvent (LedgerUpdate _) = Notice +gsLedgerEvent (LedgerWarning _) = Critical + +gsTraceCopyToImmutableDBEvent :: ChainDB.TraceCopyToImmutableDBEvent blk -> SeverityS +gsTraceCopyToImmutableDBEvent ChainDB.CopiedBlockToImmutableDB {} = Debug +gsTraceCopyToImmutableDBEvent ChainDB.NoBlocksToCopyToImmutableDB = Debug + +gsTraceGCEvent :: ChainDB.TraceGCEvent blk -> SeverityS +gsTraceGCEvent ChainDB.PerformedGC {} = Debug +gsTraceGCEvent ChainDB.ScheduledGC {} = Debug + +gsTraceInitChainSelEvent :: ChainDB.TraceInitChainSelEvent blk -> SeverityS +gsTraceInitChainSelEvent ChainDB.InitChainSelValidation {} = Debug + +gsTraceOpenEvent :: ChainDB.TraceOpenEvent blk -> SeverityS +gsTraceOpenEvent ChainDB.OpenedDB {} = Info +gsTraceOpenEvent ChainDB.ClosedDB {} = Info +gsTraceOpenEvent ChainDB.OpenedImmutableDB {} = Info +gsTraceOpenEvent ChainDB.OpenedVolatileDB = Info +gsTraceOpenEvent ChainDB.OpenedLgrDB = Info + +gsTraceIteratorEvent :: ChainDB.TraceIteratorEvent blk -> SeverityS +gsTraceIteratorEvent ChainDB.StreamFromVolatileDB {} = Debug +gsTraceIteratorEvent _ = Debug + +gsTraceLedgerEvent :: LedgerDB.TraceEvent blk -> SeverityS +gsTraceLedgerEvent LedgerDB.TookSnapshot {} = Info +gsTraceLedgerEvent LedgerDB.DeletedSnapshot {} = Debug +gsTraceLedgerEvent LedgerDB.InvalidSnapshot {} = Error + +gsTraceLedgerReplayEvent :: LedgerDB.TraceReplayEvent blk replayTo -> SeverityS +gsTraceLedgerReplayEvent LedgerDB.ReplayFromGenesis {} = Info +gsTraceLedgerReplayEvent LedgerDB.ReplayFromSnapshot {} = Info +gsTraceLedgerReplayEvent LedgerDB.ReplayedBlock {} = Info + +gsTraceImmutableDBEvent :: ImmDB.TraceEvent blk -> SeverityS +gsTraceImmutableDBEvent _ = Debug + +gsTraceVolatileDBEvent :: VolDB.TraceEvent blk -> SeverityS +gsTraceVolatileDBEvent _ = Debug + +namesForChainDBTraceEvents :: ChainDB.TraceEvent blk -> [Text] +namesForChainDBTraceEvents (ChainDB.TraceAddBlockEvent + (ChainDB.IgnoreBlockOlderThanK _)) = + ["AddBlockEvent","IgnoreBlockOlderThanK"] +namesForChainDBTraceEvents (ChainDB.TraceAddBlockEvent + (ChainDB.IgnoreBlockAlreadyInVolatileDB _)) = + ["AddBlockEvent", "IgnoreBlockAlreadyInVolatileDB"] +namesForChainDBTraceEvents (ChainDB.TraceAddBlockEvent + (ChainDB.IgnoreInvalidBlock {})) = + ["AddBlockEvent", "IgnoreBlockAlreadyInVolatileDB"] +namesForChainDBTraceEvents (ChainDB.TraceAddBlockEvent + (ChainDB.AddedBlockToQueue {})) = + ["AddBlockEvent", "AddedBlockToQueue"] +namesForChainDBTraceEvents (ChainDB.TraceAddBlockEvent + (ChainDB.BlockInTheFuture {})) = + ["AddBlockEvent","BlockInTheFuture"] +namesForChainDBTraceEvents (ChainDB.TraceAddBlockEvent + (ChainDB.AddedBlockToVolatileDB {})) = + ["AddBlockEvent", "AddedBlockToVolatileDB"] +namesForChainDBTraceEvents (ChainDB.TraceAddBlockEvent + (ChainDB.TryAddToCurrentChain {})) = + ["AddBlockEvent", "TryAddToCurrentChain"] +namesForChainDBTraceEvents (ChainDB.TraceAddBlockEvent + (ChainDB.TrySwitchToAFork {})) = + ["AddBlockEvent", "TrySwitchToAFork"] +namesForChainDBTraceEvents (ChainDB.TraceAddBlockEvent + (ChainDB.StoreButDontChange {})) = + ["AddBlockEvent", "StoreButDontChange"] +namesForChainDBTraceEvents (ChainDB.TraceAddBlockEvent + (ChainDB.AddedToCurrentChain {})) = + ["AddBlockEvent", "AddedToCurrentChain"] +namesForChainDBTraceEvents (ChainDB.TraceAddBlockEvent + (ChainDB.SwitchedToAFork {})) = + ["AddBlockEvent", "SwitchedToAFork"] +namesForChainDBTraceEvents (ChainDB.TraceAddBlockEvent + (ChainDB.AddBlockValidation (ChainDB.InvalidBlock {}))) = + ["AddBlockEvent", "AddBlockValidation", "InvalidBlock"] +namesForChainDBTraceEvents (ChainDB.TraceAddBlockEvent + (ChainDB.AddBlockValidation (ChainDB.InvalidCandidate {}))) = + ["AddBlockEvent", "AddBlockValidation", "InvalidCandidate"] +namesForChainDBTraceEvents (ChainDB.TraceAddBlockEvent + (ChainDB.AddBlockValidation (ChainDB.ValidCandidate {}))) = + ["AddBlockEvent", "AddBlockValidation", "ValidCandidate"] +namesForChainDBTraceEvents (ChainDB.TraceAddBlockEvent + (ChainDB.AddBlockValidation (ChainDB.CandidateContainsFutureBlocks {}))) = + ["AddBlockEvent", "AddBlockValidation", "CandidateContainsFutureBlocks"] +namesForChainDBTraceEvents (ChainDB.TraceAddBlockEvent + (ChainDB.AddBlockValidation + (ChainDB.CandidateContainsFutureBlocksExceedingClockSkew {}))) = + ["AddBlockEvent", "AddBlockValidation", + "CandidateContainsFutureBlocksExceedingClockSkew"] +namesForChainDBTraceEvents (ChainDB.TraceAddBlockEvent + (ChainDB.ChainSelectionForFutureBlock {})) = + ["AddBlockEvent", "ChainSelectionForFutureBlock"] +namesForChainDBTraceEvents (ChainDB.TraceFollowerEvent + ChainDB.NewFollower) = + ["FollowerEvent", "NewFollower"] +namesForChainDBTraceEvents (ChainDB.TraceFollowerEvent + (ChainDB.FollowerNoLongerInMem {})) = + ["FollowerEvent", "FollowerNoLongerInMem"] +namesForChainDBTraceEvents (ChainDB.TraceFollowerEvent + (ChainDB.FollowerSwitchToMem {})) = + ["FollowerEvent", "FollowerSwitchToMem"] +namesForChainDBTraceEvents (ChainDB.TraceFollowerEvent + (ChainDB.FollowerNewImmIterator {})) = + ["FollowerEvent", "FollowerNewImmIterator"] +namesForChainDBTraceEvents (ChainDB.TraceCopyToImmutableDBEvent + (ChainDB.CopiedBlockToImmutableDB {})) = + ["CopyToImmutableDBEvent", "CopiedBlockToImmutableDB"] +namesForChainDBTraceEvents (ChainDB.TraceCopyToImmutableDBEvent + (ChainDB.NoBlocksToCopyToImmutableDB)) = + ["CopyToImmutableDBEvent", "NoBlocksToCopyToImmutableDB"] +namesForChainDBTraceEvents (ChainDB.TraceGCEvent + (ChainDB.ScheduledGC {})) = + ["GCEvent", "NoBlocksToCopyToImmutableDB"] +namesForChainDBTraceEvents (ChainDB.TraceGCEvent + (ChainDB.PerformedGC {})) = + ["GCEvent", "NoBlocksToCopyToImmutableDB"] +namesForChainDBTraceEvents (ChainDB.TraceInitChainSelEvent + (ChainDB.InitChainSelValidation (ChainDB.InvalidBlock {}))) = + ["InitChainSelEvent", "InitChainSelValidation", "InvalidBlock"] +namesForChainDBTraceEvents (ChainDB.TraceInitChainSelEvent + (ChainDB.InitChainSelValidation (ChainDB.InvalidCandidate {}))) = + ["InitChainSelEvent", "InitChainSelValidation", "InvalidCandidate"] +namesForChainDBTraceEvents (ChainDB.TraceInitChainSelEvent + (ChainDB.InitChainSelValidation (ChainDB.ValidCandidate {}))) = + ["InitChainSelEvent", "InitChainSelValidation", "ValidCandidate"] +namesForChainDBTraceEvents (ChainDB.TraceInitChainSelEvent + (ChainDB.InitChainSelValidation (ChainDB.CandidateContainsFutureBlocks {}))) = + ["InitChainSelEvent", "InitChainSelValidation", + "CandidateContainsFutureBlocks"] +namesForChainDBTraceEvents (ChainDB.TraceInitChainSelEvent + (ChainDB.InitChainSelValidation + (ChainDB.CandidateContainsFutureBlocksExceedingClockSkew {}))) = + ["InitChainSelEvent", "InitChainSelValidation", + "CandidateContainsFutureBlocksExceedingClockSkew"] +namesForChainDBTraceEvents (ChainDB.TraceOpenEvent + (ChainDB.OpenedDB {})) = + ["OpenEvent", "OpenedDB"] +namesForChainDBTraceEvents (ChainDB.TraceOpenEvent + (ChainDB.ClosedDB {})) = + ["OpenEvent", "ClosedDB"] +namesForChainDBTraceEvents (ChainDB.TraceOpenEvent + (ChainDB.OpenedImmutableDB {})) = + ["OpenEvent", "OpenedImmutableDB"] +namesForChainDBTraceEvents (ChainDB.TraceOpenEvent + ChainDB.OpenedVolatileDB) = + ["OpenEvent", "OpenedVolatileDB"] +namesForChainDBTraceEvents (ChainDB.TraceOpenEvent + ChainDB.OpenedLgrDB) = + ["OpenEvent", "OpenedLgrDB"] +namesForChainDBTraceEvents (ChainDB.TraceIteratorEvent + (ChainDB.UnknownRangeRequested {})) = + ["IteratorEvent", "UnknownRangeRequested"] +namesForChainDBTraceEvents (ChainDB.TraceIteratorEvent + (ChainDB.StreamFromVolatileDB {})) = + ["IteratorEvent", "StreamFromVolatileDB"] +namesForChainDBTraceEvents (ChainDB.TraceIteratorEvent + (ChainDB.StreamFromImmutableDB {})) = + ["IteratorEvent", "StreamFromImmutableDB"] +namesForChainDBTraceEvents (ChainDB.TraceIteratorEvent + (ChainDB.StreamFromBoth {})) = + ["IteratorEvent", "StreamFromBoth"] +namesForChainDBTraceEvents (ChainDB.TraceIteratorEvent + (ChainDB.BlockMissingFromVolatileDB {})) = + ["IteratorEvent", "BlockMissingFromVolatileDB"] +namesForChainDBTraceEvents (ChainDB.TraceIteratorEvent + (ChainDB.BlockWasCopiedToImmutableDB {})) = + ["IteratorEvent", "BlockWasCopiedToImmutableDB"] +namesForChainDBTraceEvents (ChainDB.TraceIteratorEvent + (ChainDB.BlockGCedFromVolatileDB {})) = + ["IteratorEvent", "BlockGCedFromVolatileDB"] +namesForChainDBTraceEvents (ChainDB.TraceIteratorEvent + ChainDB.SwitchBackToVolatileDB) = + ["IteratorEvent", "SwitchBackToVolatileDB"] +namesForChainDBTraceEvents (ChainDB.TraceLedgerEvent + (LedgerDB.InvalidSnapshot {})) = + ["TraceLedgerEvent", "InvalidSnapshot"] +namesForChainDBTraceEvents (ChainDB.TraceLedgerEvent + (LedgerDB.TookSnapshot {})) = + ["TraceLedgerEvent", "TookSnapshot"] +namesForChainDBTraceEvents (ChainDB.TraceLedgerEvent + (LedgerDB.DeletedSnapshot {})) = + ["TraceLedgerEvent", "DeletedSnapshot"] +namesForChainDBTraceEvents (ChainDB.TraceLedgerReplayEvent + (LedgerDB.ReplayFromGenesis {})) = + ["TraceLedgerEvent", "ReplayFromGenesis"] +namesForChainDBTraceEvents (ChainDB.TraceLedgerReplayEvent + (LedgerDB.ReplayFromSnapshot {})) = + ["TraceLedgerEvent", "ReplayFromSnapshot"] +namesForChainDBTraceEvents (ChainDB.TraceLedgerReplayEvent + (LedgerDB.ReplayedBlock {})) = + ["TraceLedgerEvent", "ReplayedBlock"] +namesForChainDBTraceEvents (ChainDB.TraceImmutableDBEvent + ImmDB.NoValidLastLocation) = + ["ImmutableDBEvent", "NoValidLastLocation"] +namesForChainDBTraceEvents (ChainDB.TraceImmutableDBEvent + (ImmDB.ValidatedLastLocation {})) = + ["ImmutableDBEvent", "ValidatedLastLocation"] +namesForChainDBTraceEvents (ChainDB.TraceImmutableDBEvent + (ImmDB.ValidatingChunk {})) = + ["ImmutableDBEvent", "ValidatingChunk"] +namesForChainDBTraceEvents (ChainDB.TraceImmutableDBEvent + (ImmDB.MissingChunkFile {})) = + ["ImmutableDBEvent", "MissingChunkFile"] +namesForChainDBTraceEvents (ChainDB.TraceImmutableDBEvent + (ImmDB.InvalidChunkFile {})) = + ["ImmutableDBEvent", "InvalidChunkFile"] +namesForChainDBTraceEvents (ChainDB.TraceImmutableDBEvent + (ImmDB.ChunkFileDoesntFit {})) = + ["ImmutableDBEvent", "ChunkFileDoesntFit"] +namesForChainDBTraceEvents (ChainDB.TraceImmutableDBEvent + (ImmDB.MissingPrimaryIndex {})) = + ["ImmutableDBEvent", "MissingPrimaryIndex"] +namesForChainDBTraceEvents (ChainDB.TraceImmutableDBEvent + (ImmDB.MissingSecondaryIndex {})) = + ["ImmutableDBEvent", "MissingSecondaryIndex"] +namesForChainDBTraceEvents (ChainDB.TraceImmutableDBEvent + (ImmDB.InvalidPrimaryIndex {})) = + ["ImmutableDBEvent", "InvalidPrimaryIndex"] +namesForChainDBTraceEvents (ChainDB.TraceImmutableDBEvent + (ImmDB.InvalidSecondaryIndex {})) = + ["ImmutableDBEvent", "InvalidSecondaryIndex"] +namesForChainDBTraceEvents (ChainDB.TraceImmutableDBEvent + (ImmDB.RewritePrimaryIndex {})) = + ["ImmutableDBEvent", "RewritePrimaryIndex"] +namesForChainDBTraceEvents (ChainDB.TraceImmutableDBEvent + (ImmDB.RewriteSecondaryIndex {})) = + ["ImmutableDBEvent", "RewriteSecondaryIndex"] +namesForChainDBTraceEvents (ChainDB.TraceImmutableDBEvent + (ImmDB.Migrating {})) = + ["ImmutableDBEvent", "Migrating"] +namesForChainDBTraceEvents (ChainDB.TraceImmutableDBEvent + (ImmDB.DeletingAfter {})) = + ["ImmutableDBEvent", "DeletingAfter"] +namesForChainDBTraceEvents (ChainDB.TraceImmutableDBEvent + ImmDB.DBAlreadyClosed) = + ["ImmutableDBEvent", "DBAlreadyClosed"] +namesForChainDBTraceEvents (ChainDB.TraceImmutableDBEvent ImmDB.DBClosed) = + ["ImmutableDBEvent", "DBClosed"] +namesForChainDBTraceEvents (ChainDB.TraceImmutableDBEvent + (ImmDB.TraceCacheEvent (ImmDB.TraceCurrentChunkHit {}))) = + ["ImmutableDBEvent", "CacheEvent", "TraceCurrentChunkHit"] +namesForChainDBTraceEvents (ChainDB.TraceImmutableDBEvent + (ImmDB.TraceCacheEvent (ImmDB.TracePastChunkHit {}))) = + ["ImmutableDBEvent", "CacheEvent", "TracePastChunkHit"] +namesForChainDBTraceEvents (ChainDB.TraceImmutableDBEvent + (ImmDB.TraceCacheEvent (ImmDB.TracePastChunkMiss {}))) = + ["ImmutableDBEvent", "CacheEvent", "TracePastChunkMiss"] +namesForChainDBTraceEvents (ChainDB.TraceImmutableDBEvent + (ImmDB.TraceCacheEvent (ImmDB.TracePastChunkEvict {}))) = + ["ImmutableDBEvent", "CacheEvent", "TracePastChunkEvict"] +namesForChainDBTraceEvents (ChainDB.TraceImmutableDBEvent + (ImmDB.TraceCacheEvent (ImmDB.TracePastChunksExpired {}))) = + ["ImmutableDBEvent", "CacheEvent", "TracePastChunkEvict"] +namesForChainDBTraceEvents (ChainDB.TraceVolatileDBEvent + VolDb.DBAlreadyClosed) = + ["VolatileDbEvent", "DBAlreadyClosed"] +namesForChainDBTraceEvents (ChainDB.TraceVolatileDBEvent + VolDb.DBAlreadyOpen) = + ["VolatileDbEvent", "TruncateCurrentFile"] +namesForChainDBTraceEvents (ChainDB.TraceVolatileDBEvent + (VolDb.Truncate {})) = + ["VolatileDbEvent", "Truncate"] +namesForChainDBTraceEvents (ChainDB.TraceVolatileDBEvent + (VolDb.InvalidFileNames {})) = + ["VolatileDBEvent", "InvalidFileNames"] +namesForChainDBTraceEvents (ChainDB.TraceVolatileDBEvent + (VolDb.BlockAlreadyHere {})) = + ["VolatileDBEvent", "BlockAlreadyHere"] +namesForChainDBTraceEvents (ChainDB.TraceVolatileDBEvent + (VolDb.TruncateCurrentFile {})) = + ["VolatileDBEvent", "TruncateCurrentFile"] diff --git a/cardano-node/src/Cardano/TraceDispatcher/ChainDB/Docu.hs b/cardano-node/src/Cardano/TraceDispatcher/ChainDB/Docu.hs new file mode 100644 index 00000000000..ee10d890067 --- /dev/null +++ b/cardano-node/src/Cardano/TraceDispatcher/ChainDB/Docu.hs @@ -0,0 +1,581 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE AllowAmbiguousTypes #-} + + +{-# OPTIONS_GHC -Wno-deprecations #-} + +module Cardano.TraceDispatcher.ChainDB.Docu + ( docChainDBTraceEvent + ) where + + +import Control.Monad.Class.MonadTime (Time (..)) + +import Cardano.Logging +import Cardano.Prelude hiding (Show, show) +import Cardano.TraceDispatcher.Era.Byron () +import Cardano.TraceDispatcher.Era.Shelley () + +import Ouroboros.Consensus.Block +import Ouroboros.Consensus.Fragment.Diff (ChainDiff (..)) +import Ouroboros.Consensus.HeaderValidation +import Ouroboros.Consensus.Ledger.Extended (ExtValidationError (..)) +import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB +import qualified Ouroboros.Consensus.Storage.ChainDB.Impl.Types as ChainDB +import Ouroboros.Consensus.Storage.FS.API.Types (FsPath, mkFsPath) +import qualified Ouroboros.Consensus.Storage.ImmutableDB as ImmDB +import qualified Ouroboros.Consensus.Storage.ImmutableDB.Impl.Types as ImmDB +import qualified Ouroboros.Consensus.Storage.LedgerDB.OnDisk as LedgerDB +import qualified Ouroboros.Consensus.Storage.VolatileDB as VolDB +import qualified Ouroboros.Consensus.Storage.VolatileDB.Impl.Types as VolDB +import qualified Ouroboros.Network.AnchoredFragment as AF + +----------- Prototype objects for docu generation + +protoRealPoint :: RealPoint blk +protoRealPoint = undefined + +protoPoint :: Point blk +protoPoint = undefined + +protoHeaderDiff :: ChainDiff (HeaderFields blk) +protoHeaderDiff = undefined + +protoValidationError :: ChainDB.InvalidBlockReason blk +protoValidationError = undefined + +protoNTI :: ChainDB.NewTipInfo blk +protoNTI = ChainDB.NewTipInfo protoRealPoint (EpochNo 1) 1 protoRealPoint + +protoAFH :: AF.AnchoredFragment (Header blk) +protoAFH = undefined + +protoExtValidationError :: ExtValidationError blk +protoExtValidationError = ExtValidationErrorHeader (HeaderEnvelopeError (UnexpectedSlotNo 1 2)) + +protoFollowerRollState :: ChainDB.FollowerRollState blk +protoFollowerRollState = undefined + +protoWoSlotNo :: WithOrigin SlotNo +protoWoSlotNo = undefined + +protoTime :: Time +protoTime = undefined + +protoChunkNo :: ImmDB.ChunkNo +protoChunkNo = undefined + +protoStreamFrom :: ChainDB.StreamFrom blk +protoStreamFrom = undefined + +protoStreamTo :: ChainDB.StreamTo blk +protoStreamTo = undefined + +protoUnknownRange :: ChainDB.UnknownRange blk +protoUnknownRange = undefined + +protoDiskSnapshot :: LedgerDB.DiskSnapshot +protoDiskSnapshot = undefined + +protoInitFailure :: LedgerDB.InitFailure blk +protoInitFailure = undefined + +protoTip :: ImmDB.Tip blk +protoTip = undefined + +protoChunkFileError :: ImmDB.ChunkFileError blk +protoChunkFileError = undefined + +protoChainHash :: ChainHash blk +protoChainHash = undefined + +protoWithOriginTip :: WithOrigin (ImmDB.Tip blk) +protoWithOriginTip = undefined + +protoParseError :: VolDB.ParseError blk +protoParseError = undefined + +protoFsPath :: FsPath +protoFsPath = mkFsPath [""] + +protoBlockOffset :: VolDB.BlockOffset +protoBlockOffset = undefined + +----------- Documentation + +docChainDBTraceEvent :: Documented (ChainDB.TraceEvent blk) +docChainDBTraceEvent = Documented [ + DocMsg + (ChainDB.TraceAddBlockEvent + (ChainDB.IgnoreBlockOlderThanK protoRealPoint)) + [] + "A block with a 'BlockNo' more than @k@ back than the current tip\ + \ was ignored." + , DocMsg + (ChainDB.TraceAddBlockEvent + (ChainDB.IgnoreBlockAlreadyInVolatileDB + protoRealPoint)) + [] + "A block that is already in the Volatile DB was ignored." + , DocMsg + (ChainDB.TraceAddBlockEvent + (ChainDB.IgnoreInvalidBlock + protoRealPoint protoValidationError)) + [] + "A block that is already in the Volatile DB was ignored." + , DocMsg + (ChainDB.TraceAddBlockEvent + (ChainDB.AddedBlockToQueue + protoRealPoint 1)) + [] + "The block was added to the queue and will be added to the ChainDB by\ + \ the background thread. The size of the queue is included.." + , DocMsg + (ChainDB.TraceAddBlockEvent + (ChainDB.BlockInTheFuture + protoRealPoint 1)) + [] + "The block is from the future, i.e., its slot number is greater than\ + \ the current slot (the second argument)." + , DocMsg + (ChainDB.TraceAddBlockEvent + (ChainDB.AddedBlockToVolatileDB + protoRealPoint 1 ChainDB.IsEBB)) + [] + "A block was added to the Volatile DB" + , DocMsg + (ChainDB.TraceAddBlockEvent + (ChainDB.TryAddToCurrentChain + protoRealPoint)) + [] + "The block fits onto the current chain, we'll try to use it to extend\ + \ our chain." + , DocMsg + (ChainDB.TraceAddBlockEvent + (ChainDB.TrySwitchToAFork + protoRealPoint protoHeaderDiff)) + [] + "The block fits onto some fork, we'll try to switch to that fork (if\ + \ it is preferable to our chain)" + , DocMsg + (ChainDB.TraceAddBlockEvent + (ChainDB.StoreButDontChange + protoRealPoint)) + [] + "The block fits onto some fork, we'll try to switch to that fork (if\ + \ it is preferable to our chain)." + , DocMsg + (ChainDB.TraceAddBlockEvent + (ChainDB.AddedToCurrentChain [] protoNTI protoAFH protoAFH)) + [(["density"], + "The actual number of blocks created over the maximum expected number\ + \ of blocks that could be created over the span of the last @k@ blocks.") + , (["slots"], + "Number of slots in this chain fragment.") + , (["blocks"], + "Number of blocks in this chain fragment.") + , (["slotInEpoch"], + "Relative slot number of the tip of the current chain within the\ + \epoch..") + , (["epoch"], + "In which epoch is the tip of the current chain.") + ] + "The new block fits onto the current chain (first\ + \ fragment) and we have successfully used it to extend our (new) current\ + \ chain (second fragment)." + , DocMsg + (ChainDB.TraceAddBlockEvent + (ChainDB.SwitchedToAFork [] protoNTI protoAFH protoAFH)) + [(["density"], + "The actual number of blocks created over the maximum expected number\ + \ of blocks that could be created over the span of the last @k@ blocks.") + , (["slots"], + "Number of slots in this chain fragment.") + , (["blocks"], + "Number of blocks in this chain fragment.") + , (["slotInEpoch"], + "Relative slot number of the tip of the current chain within the\ + \epoch..") + , (["epoch"], + "In which epoch is the tip of the current chain.") + ] + "The new block fits onto some fork and we have switched to that fork\ + \ (second fragment), as it is preferable to our (previous) current chain\ + \ (first fragment)." + , DocMsg + (ChainDB.TraceAddBlockEvent + (ChainDB.AddBlockValidation + (ChainDB.InvalidBlock protoExtValidationError protoRealPoint))) + [] + "An event traced during validating performed while adding a block.\ + \ A point was found to be invalid." + , DocMsg + (ChainDB.TraceAddBlockEvent + (ChainDB.AddBlockValidation + (ChainDB.InvalidCandidate protoAFH))) + [] + "An event traced during validating performed while adding a block.\ + \ A candidate chain was invalid." + , DocMsg + (ChainDB.TraceAddBlockEvent + (ChainDB.AddBlockValidation + (ChainDB.ValidCandidate protoAFH))) + [] + "An event traced during validating performed while adding a block.\ + \ A candidate chain was valid." + , DocMsg + (ChainDB.TraceAddBlockEvent + (ChainDB.AddBlockValidation + (ChainDB.CandidateContainsFutureBlocks protoAFH []))) + [] + "An event traced during validating performed while adding a block.\ + \ Candidate contains headers from the future which do no exceed the\ + \ clock skew." + , DocMsg + (ChainDB.TraceAddBlockEvent + (ChainDB.AddBlockValidation + (ChainDB.CandidateContainsFutureBlocksExceedingClockSkew protoAFH []))) + [] + "An event traced during validating performed while adding a block.\ + \ Candidate contains headers from the future which exceed the\ + \ clock skew." + , DocMsg + (ChainDB.TraceAddBlockEvent + (ChainDB.ChainSelectionForFutureBlock protoRealPoint)) + [] + "Run chain selection for a block that was previously from the future.\ + \ This is done for all blocks from the future each time a new block is\ + \ added." + , DocMsg + (ChainDB.TraceFollowerEvent ChainDB.NewFollower) + [] + "A new follower was created." + , DocMsg + (ChainDB.TraceFollowerEvent + (ChainDB.FollowerNoLongerInMem protoFollowerRollState)) + [] + "The follower was in the 'FollowerInImmutableDB' state and is switched to\ + \ the 'FollowerInMem' state." + , DocMsg + (ChainDB.TraceFollowerEvent + (ChainDB.FollowerSwitchToMem protoPoint protoWoSlotNo)) + [] + "The follower was in the 'FollowerInImmutableDB' state and is switched to\ + \ the 'FollowerInMem' state." + , DocMsg + (ChainDB.TraceFollowerEvent + (ChainDB.FollowerNewImmIterator protoPoint protoWoSlotNo)) + [] + "The follower is in the 'FollowerInImmutableDB' state but the iterator is\ + \ exhausted while the ImmDB has grown, so we open a new iterator to\ + \ stream these blocks too." + , DocMsg + (ChainDB.TraceCopyToImmutableDBEvent + (ChainDB.CopiedBlockToImmutableDB protoPoint)) + [] + "A block was successfully copied to the ImmDB." + , DocMsg + (ChainDB.TraceCopyToImmutableDBEvent + (ChainDB.NoBlocksToCopyToImmutableDB)) + [] + "There are no block to copy to the ImmDB." + , DocMsg + (ChainDB.TraceGCEvent + (ChainDB.ScheduledGC 1 protoTime)) + [] + "There are no block to copy to the ImmDB." + , DocMsg + (ChainDB.TraceGCEvent + (ChainDB.PerformedGC 1)) + [] + "There are no block to copy to the ImmDB." + , DocMsg + (ChainDB.TraceInitChainSelEvent + (ChainDB.InitChainSelValidation + (ChainDB.InvalidBlock protoExtValidationError protoRealPoint))) + [] + "A point was found to be invalid." + , DocMsg + (ChainDB.TraceInitChainSelEvent + (ChainDB.InitChainSelValidation + (ChainDB.InvalidCandidate protoAFH))) + [] + "A candidate chain was invalid." + , DocMsg + (ChainDB.TraceInitChainSelEvent + (ChainDB.InitChainSelValidation + (ChainDB.ValidCandidate protoAFH))) + [] + "A candidate chain was valid." + , DocMsg + (ChainDB.TraceInitChainSelEvent + (ChainDB.InitChainSelValidation + (ChainDB.CandidateContainsFutureBlocks protoAFH []))) + [] + "Candidate contains headers from the future which do not exceed the\ + \ clock skew." + , DocMsg + (ChainDB.TraceInitChainSelEvent + (ChainDB.InitChainSelValidation + (ChainDB.CandidateContainsFutureBlocksExceedingClockSkew protoAFH []))) + [] + "Candidate contains headers from the future which exceed the\ + \ clock skew, making them invalid." + + , DocMsg + (ChainDB.TraceOpenEvent + (ChainDB.OpenedDB protoPoint protoPoint)) + [] + "The ChainDB was opened." + , DocMsg + (ChainDB.TraceOpenEvent + (ChainDB.ClosedDB protoPoint protoPoint)) + [] + "The ChainDB was closed." + , DocMsg + (ChainDB.TraceOpenEvent + (ChainDB.OpenedImmutableDB protoPoint protoChunkNo)) + [] + "The ImmDB was opened." + , DocMsg + (ChainDB.TraceOpenEvent + ChainDB.OpenedVolatileDB) + [] + "The VolatileDB was opened." + , DocMsg + (ChainDB.TraceOpenEvent + ChainDB.OpenedLgrDB) + [] + "The LedgerDB was opened." + , DocMsg + (ChainDB.TraceIteratorEvent + (ChainDB.UnknownRangeRequested protoUnknownRange)) + [] + "An unknown range was requested, see 'UnknownRange'." + , DocMsg + (ChainDB.TraceIteratorEvent + (ChainDB.StreamFromVolatileDB protoStreamFrom protoStreamTo [protoRealPoint])) + [] + "Stream only from the VolatileDB." + , DocMsg + (ChainDB.TraceIteratorEvent + (ChainDB.StreamFromImmutableDB protoStreamFrom protoStreamTo)) + [] + "Stream only from the ImmDB." + , DocMsg + (ChainDB.TraceIteratorEvent + (ChainDB.StreamFromBoth protoStreamFrom protoStreamTo [protoRealPoint])) + [] + "Stream from both the VolatileDB and the ImmDB." + , DocMsg + (ChainDB.TraceIteratorEvent + (ChainDB.BlockMissingFromVolatileDB protoRealPoint)) + [] + "A block is no longer in the VolatileDB because it has been garbage\ + \ collected. It might now be in the ImmDB if it was part of the\ + \ current chain." + , DocMsg + (ChainDB.TraceIteratorEvent + (ChainDB.BlockWasCopiedToImmutableDB protoRealPoint)) + [] + "A block that has been garbage collected from the VolatileDB is now\ + \ found and streamed from the ImmDB." + , DocMsg + (ChainDB.TraceIteratorEvent + (ChainDB.BlockGCedFromVolatileDB protoRealPoint)) + [] + "A block is no longer in the VolatileDB and isn't in the ImmDB\ + \ either; it wasn't part of the current chain." + , DocMsg + (ChainDB.TraceIteratorEvent + ChainDB.SwitchBackToVolatileDB) + [] + "We have streamed one or more blocks from the ImmDB that were part\ + \ of the VolatileDB when initialising the iterator. Now, we have to look\ + \ back in the VolatileDB again because the ImmDB doesn't have the\ + \ next block we're looking for." + , DocMsg + (ChainDB.TraceLedgerEvent + (LedgerDB.InvalidSnapshot protoDiskSnapshot protoInitFailure)) + [] + "An on disk snapshot was skipped because it was invalid." + , DocMsg + (ChainDB.TraceLedgerEvent + (LedgerDB.TookSnapshot protoDiskSnapshot protoRealPoint)) + [] + "A snapshot was written to disk." + , DocMsg + (ChainDB.TraceLedgerEvent + (LedgerDB.DeletedSnapshot protoDiskSnapshot)) + [] + "An old or invalid on-disk snapshot was deleted." + + , DocMsg + (ChainDB.TraceLedgerReplayEvent + (LedgerDB.ReplayFromGenesis protoPoint)) + [] + "There were no LedgerDB snapshots on disk, so we're replaying all\ + \ blocks starting from Genesis against the initial ledger.\ + \ The @replayTo@ parameter corresponds to the block at the tip of the\ + \ ImmDB, i.e., the last block to replay." + , DocMsg + (ChainDB.TraceLedgerReplayEvent + (LedgerDB.ReplayFromSnapshot protoDiskSnapshot protoRealPoint protoPoint)) + [] + "There was a LedgerDB snapshot on disk corresponding to the given tip.\ + \ We're replaying more recent blocks against it.\ + \ The @replayTo@ parameter corresponds to the block at the tip of the\ + \ ImmDB, i.e., the last block to replay." + , DocMsg + (ChainDB.TraceLedgerReplayEvent + (LedgerDB.ReplayedBlock protoRealPoint [] protoPoint)) + [] + "We replayed the given block (reference) on the genesis snapshot\ + \ during the initialisation of the LedgerDB.\ + \ \ + \ The @blockInfo@ parameter corresponds replayed block and the @replayTo@\ + \ parameter corresponds to the block at the tip of the ImmDB, i.e.,\ + \ the last block to replay." + + , DocMsg + (ChainDB.TraceImmutableDBEvent ImmDB.NoValidLastLocation) + [] + "No valid last location was found" + , DocMsg + (ChainDB.TraceImmutableDBEvent + (ImmDB.ValidatedLastLocation protoChunkNo protoTip)) + [] + "The last location was validatet" + , DocMsg + (ChainDB.TraceImmutableDBEvent + (ImmDB.ValidatingChunk protoChunkNo)) + [] + "The chunk was validatet" + , DocMsg + (ChainDB.TraceImmutableDBEvent + (ImmDB.MissingChunkFile protoChunkNo)) + [] + "Chunk file is missing" + , DocMsg + (ChainDB.TraceImmutableDBEvent + (ImmDB.InvalidChunkFile protoChunkNo protoChunkFileError)) + [] + "Chunk file is invalid" + , DocMsg + (ChainDB.TraceImmutableDBEvent + (ImmDB.ChunkFileDoesntFit protoChainHash protoChainHash)) + [] + "The hash of the last block in the previous epoch doesn't match the\ + \ previous hash of the first block in the current epoch" + , DocMsg + (ChainDB.TraceImmutableDBEvent + (ImmDB.MissingPrimaryIndex protoChunkNo)) + [] + "The primary index is missing." + , DocMsg + (ChainDB.TraceImmutableDBEvent + (ImmDB.MissingSecondaryIndex protoChunkNo)) + [] + "The secondary index is missing." + , DocMsg + (ChainDB.TraceImmutableDBEvent + (ImmDB.InvalidPrimaryIndex protoChunkNo)) + [] + "The primary index is invalid." + , DocMsg + (ChainDB.TraceImmutableDBEvent + (ImmDB.InvalidSecondaryIndex protoChunkNo)) + [] + "The secondary index is invalid." + , DocMsg + (ChainDB.TraceImmutableDBEvent + (ImmDB.RewritePrimaryIndex protoChunkNo)) + [] + "The primary index gets rewritten." + , DocMsg + (ChainDB.TraceImmutableDBEvent + (ImmDB.RewriteSecondaryIndex protoChunkNo)) + [] + "The secondary index gets rewritten." + , DocMsg + (ChainDB.TraceImmutableDBEvent + (ImmDB.Migrating "")) + [] + "Performing a migration of the on-disk files." + , DocMsg + (ChainDB.TraceImmutableDBEvent + (ImmDB.DeletingAfter protoWithOriginTip)) + [] + "Delete after" + , DocMsg + (ChainDB.TraceImmutableDBEvent ImmDB.DBAlreadyClosed) + [] + "The immutable DB is already closed" + , DocMsg + (ChainDB.TraceImmutableDBEvent ImmDB.DBClosed) + [] + "Closing the immutable DB" + , DocMsg + (ChainDB.TraceImmutableDBEvent + (ImmDB.TraceCacheEvent + (ImmDB.TraceCurrentChunkHit protoChunkNo 1))) + [] + "Current chunk found in the cache." + , DocMsg + (ChainDB.TraceImmutableDBEvent + (ImmDB.TraceCacheEvent + (ImmDB.TracePastChunkHit protoChunkNo 1))) + [] + "Past chunk found in the cache" + , DocMsg + (ChainDB.TraceImmutableDBEvent + (ImmDB.TraceCacheEvent + (ImmDB.TracePastChunkMiss protoChunkNo 1))) + [] + "Past chunk was not found in the cache" + , DocMsg + (ChainDB.TraceImmutableDBEvent + (ImmDB.TraceCacheEvent + (ImmDB.TracePastChunkEvict protoChunkNo 1))) + [] + "The least recently used past chunk was evicted because the cache\ + \ was full." + , DocMsg + (ChainDB.TraceImmutableDBEvent + (ImmDB.TraceCacheEvent + (ImmDB.TracePastChunksExpired [protoChunkNo] 1))) + [] + "Past chunks were expired from the cache because they haven't been\ + \ used for a while." + + , DocMsg + (ChainDB.TraceVolatileDBEvent + (VolDB.DBAlreadyClosed)) + [] + "When closing the DB it was found itis closed already." + , DocMsg + (ChainDB.TraceVolatileDBEvent + (VolDB.DBAlreadyOpen)) + [] + "TODO Doc" + , DocMsg + (ChainDB.TraceVolatileDBEvent + (VolDB.Truncate protoParseError protoFsPath protoBlockOffset)) + [] + "Truncates a file up to offset because of the error." + , DocMsg + (ChainDB.TraceVolatileDBEvent + (VolDB.InvalidFileNames [protoFsPath])) + [] + "Reports a list of invalid file paths." + , DocMsg + (ChainDB.TraceVolatileDBEvent + (VolDB.BlockAlreadyHere undefined)) + [] + "A block was found to be already in the DB." + , DocMsg + (ChainDB.TraceVolatileDBEvent + (VolDB.TruncateCurrentFile protoFsPath)) + [] + "TODO Doc" + ] diff --git a/cardano-node/src/Cardano/TraceDispatcher/ChainDB/Formatting.hs b/cardano-node/src/Cardano/TraceDispatcher/ChainDB/Formatting.hs new file mode 100644 index 00000000000..236437a7494 --- /dev/null +++ b/cardano-node/src/Cardano/TraceDispatcher/ChainDB/Formatting.hs @@ -0,0 +1,806 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + + +{-# OPTIONS_GHC -Wno-orphans #-} + +module Cardano.TraceDispatcher.ChainDB.Formatting + ( + ) where + +import Data.Aeson (Value (String), toJSON, (.=)) +import qualified Data.Aeson as A +import Data.HashMap.Strict (insertWith) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import Text.Show + +import Cardano.Logging +import Cardano.Prelude hiding (Show, show) +import Cardano.TraceDispatcher.Era.Byron () +import Cardano.TraceDispatcher.Era.Shelley () +import Cardano.TraceDispatcher.Formatting () +import Cardano.TraceDispatcher.Render + +import Ouroboros.Consensus.Block +import Ouroboros.Consensus.HeaderValidation (HeaderEnvelopeError (..), + HeaderError (..), OtherHeaderEnvelopeError) +import Ouroboros.Consensus.Ledger.Abstract (LedgerError) +import Ouroboros.Consensus.Ledger.Extended (ExtValidationError (..)) +import Ouroboros.Consensus.Ledger.Inspect (InspectLedger, + LedgerEvent (..)) +import Ouroboros.Consensus.Ledger.SupportsProtocol + (LedgerSupportsProtocol) +import Ouroboros.Consensus.Protocol.Abstract (ValidationErr) +import qualified Ouroboros.Consensus.Protocol.PBFT as PBFT +import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB +import qualified Ouroboros.Consensus.Storage.ImmutableDB as ImmDB +import qualified Ouroboros.Consensus.Storage.ImmutableDB.Impl.Types as ImmDB +import qualified Ouroboros.Consensus.Storage.LedgerDB.OnDisk as LedgerDB +import qualified Ouroboros.Consensus.Storage.VolatileDB as VolDB +import Ouroboros.Consensus.Util.Condense (condense) + +import qualified Ouroboros.Network.AnchoredFragment as AF + + +addedHdrsNewChain :: HasHeader (Header blk) + => AF.AnchoredFragment (Header blk) + -> AF.AnchoredFragment (Header blk) + -> [Header blk] +addedHdrsNewChain fro to_ = + case AF.intersect fro to_ of + Just (_, _, _, s2 :: AF.AnchoredFragment (Header blk)) -> + AF.toOldestFirst s2 + Nothing -> [] -- No sense to do validation here. + +kindContext :: Text -> A.Object -> A.Object +kindContext toAdd = insertWith f "kind" (String toAdd) + where + f (String new) (String old) = String (new <> "." <> old) + f (String new) _ = String new + f _ o = o + + +instance ( StandardHash blk + , LogFormatting (ValidationErr (BlockProtocol blk)) + , LogFormatting (OtherHeaderEnvelopeError blk) + ) + => LogFormatting (HeaderError blk) where + forMachine dtal (HeaderProtocolError err) = + mkObject + [ "kind" .= String "HeaderProtocolError" + , "error" .= forMachine dtal err + ] + forMachine dtal (HeaderEnvelopeError err) = + mkObject + [ "kind" .= String "HeaderEnvelopeError" + , "error" .= forMachine dtal err + ] + +instance ( StandardHash blk + , LogFormatting (OtherHeaderEnvelopeError blk) + ) + => LogFormatting (HeaderEnvelopeError blk) where + forMachine _dtal (UnexpectedBlockNo expect act) = + mkObject + [ "kind" .= String "UnexpectedBlockNo" + , "expected" .= condense expect + , "actual" .= condense act + ] + forMachine _dtal (UnexpectedSlotNo expect act) = + mkObject + [ "kind" .= String "UnexpectedSlotNo" + , "expected" .= condense expect + , "actual" .= condense act + ] + forMachine _dtal (UnexpectedPrevHash expect act) = + mkObject + [ "kind" .= String "UnexpectedPrevHash" + , "expected" .= String (Text.pack $ show expect) + , "actual" .= String (Text.pack $ show act) + ] + forMachine dtal (OtherHeaderEnvelopeError err) = + forMachine dtal err + + +instance ( LogFormatting (LedgerError blk) + , LogFormatting (HeaderError blk)) + => LogFormatting (ExtValidationError blk) where + forMachine dtal (ExtValidationErrorLedger err) = forMachine dtal err + forMachine dtal (ExtValidationErrorHeader err) = forMachine dtal err + + forHuman (ExtValidationErrorLedger err) = forHuman err + forHuman (ExtValidationErrorHeader err) = forHuman err + + asMetrics (ExtValidationErrorLedger err) = asMetrics err + asMetrics (ExtValidationErrorHeader err) = asMetrics err + +instance LogFormatting LedgerDB.DiskSnapshot where + forMachine DDetailed snap = + mkObject [ "kind" .= String "snapshot" + , "snapshot" .= String (Text.pack $ show snap) ] + forMachine _ _snap = mkObject [ "kind" .= String "snapshot" ] + +instance ( LogFormatting (Header blk) + , LogFormatting (LedgerEvent blk) + , LogFormatting (RealPoint blk) + , ConvertRawHash blk + , ConvertRawHash (Header blk) + , HasHeader (Header blk) + , LedgerSupportsProtocol blk + , InspectLedger blk + ) => LogFormatting (ChainDB.TraceEvent blk) where + forHuman (ChainDB.TraceAddBlockEvent v) = forHuman v + forHuman (ChainDB.TraceFollowerEvent v) = forHuman v + forHuman (ChainDB.TraceCopyToImmutableDBEvent v) = forHuman v + forHuman (ChainDB.TraceGCEvent v) = forHuman v + forHuman (ChainDB.TraceInitChainSelEvent v) = forHuman v + forHuman (ChainDB.TraceOpenEvent v) = forHuman v + forHuman (ChainDB.TraceIteratorEvent v) = forHuman v + forHuman (ChainDB.TraceLedgerEvent v) = forHuman v + forHuman (ChainDB.TraceLedgerReplayEvent v) = forHuman v + forHuman (ChainDB.TraceImmutableDBEvent v) = forHuman v + forHuman (ChainDB.TraceVolatileDBEvent v) = forHuman v + + forMachine details (ChainDB.TraceAddBlockEvent v) = + kindContext "AddBlockEvent" $ forMachine details v + forMachine details (ChainDB.TraceFollowerEvent v) = + kindContext "FollowerEvent" $ forMachine details v + forMachine details (ChainDB.TraceCopyToImmutableDBEvent v) = + kindContext "CopyToImmutableDBEvent" $ forMachine details v + forMachine details (ChainDB.TraceGCEvent v) = + kindContext "TraceGCEvent" $ forMachine details v + forMachine details (ChainDB.TraceInitChainSelEvent v) = + kindContext "InitChainSelEvent" $ forMachine details v + forMachine details (ChainDB.TraceOpenEvent v) = + kindContext "OpenEvent" $ forMachine details v + forMachine details (ChainDB.TraceIteratorEvent v) = + kindContext "IteratorEvent" $ forMachine details v + forMachine details (ChainDB.TraceLedgerEvent v) = + kindContext "LedgerEvent" $ forMachine details v + forMachine details (ChainDB.TraceLedgerReplayEvent v) = + kindContext "LedgerReplayEvent" $ forMachine details v + forMachine details (ChainDB.TraceImmutableDBEvent v) = + kindContext "ImmutableDBEvent" $ forMachine details v + forMachine details (ChainDB.TraceVolatileDBEvent v) = + kindContext "VolatileDBEvent" $ forMachine details v + + asMetrics (ChainDB.TraceAddBlockEvent v) = asMetrics v + asMetrics (ChainDB.TraceFollowerEvent v) = asMetrics v + asMetrics (ChainDB.TraceCopyToImmutableDBEvent v) = asMetrics v + asMetrics (ChainDB.TraceGCEvent v) = asMetrics v + asMetrics (ChainDB.TraceInitChainSelEvent v) = asMetrics v + asMetrics (ChainDB.TraceOpenEvent v) = asMetrics v + asMetrics (ChainDB.TraceIteratorEvent v) = asMetrics v + asMetrics (ChainDB.TraceLedgerEvent v) = asMetrics v + asMetrics (ChainDB.TraceLedgerReplayEvent v) = asMetrics v + asMetrics (ChainDB.TraceImmutableDBEvent v) = asMetrics v + asMetrics (ChainDB.TraceVolatileDBEvent v) = asMetrics v + +instance ( LogFormatting (Header blk) + , LogFormatting (LedgerEvent blk) + , LogFormatting (RealPoint blk) + , ConvertRawHash blk + , ConvertRawHash (Header blk) + , HasHeader (Header blk) + , LedgerSupportsProtocol blk + , InspectLedger blk + ) => LogFormatting (ChainDB.TraceAddBlockEvent blk) where + forHuman (ChainDB.IgnoreBlockOlderThanK pt) = + "Ignoring block older than K: " <> renderRealPointAsPhrase pt + forHuman (ChainDB.IgnoreBlockAlreadyInVolatileDB pt) = + "Ignoring block already in DB: " <> renderRealPointAsPhrase pt + forHuman (ChainDB.IgnoreInvalidBlock pt _reason) = + "Ignoring previously seen invalid block: " <> renderRealPointAsPhrase pt + forHuman (ChainDB.AddedBlockToQueue pt sz) = + "Block added to queue: " <> renderRealPointAsPhrase pt <> " queue size " <> condenseT sz + forHuman (ChainDB.BlockInTheFuture pt slot) = + "Ignoring block from future: " <> renderRealPointAsPhrase pt <> ", slot " <> condenseT slot + forHuman (ChainDB.StoreButDontChange pt) = + "Ignoring block: " <> renderRealPointAsPhrase pt + forHuman (ChainDB.TryAddToCurrentChain pt) = + "Block fits onto the current chain: " <> renderRealPointAsPhrase pt + forHuman (ChainDB.TrySwitchToAFork pt _) = + "Block fits onto some fork: " <> renderRealPointAsPhrase pt + forHuman (ChainDB.AddedToCurrentChain es _ _ c) = + "Chain extended, new tip: " <> renderPointAsPhrase (AF.headPoint c) <> + Text.concat [ "\nEvent: " <> showT e | e <- es ] + forHuman (ChainDB.SwitchedToAFork es _ _ c) = + "Switched to a fork, new tip: " <> renderPointAsPhrase (AF.headPoint c) <> + Text.concat [ "\nEvent: " <> showT e | e <- es ] + forHuman (ChainDB.AddBlockValidation ev') = forHuman ev' + forHuman (ChainDB.AddedBlockToVolatileDB pt _ _) = + "Chain added block " <> renderRealPointAsPhrase pt + forHuman (ChainDB.ChainSelectionForFutureBlock pt) = + "Chain selection run for block previously from future: " <> renderRealPointAsPhrase pt + + forMachine dtal (ChainDB.IgnoreBlockOlderThanK pt) = + mkObject [ "kind" .= String "IgnoreBlockOlderThanK" + , "block" .= forMachine dtal pt ] + forMachine dtal (ChainDB.IgnoreBlockAlreadyInVolatileDB pt) = + mkObject [ "kind" .= String "IgnoreBlockAlreadyInVolatileDB" + , "block" .= forMachine dtal pt ] + forMachine dtal (ChainDB.IgnoreInvalidBlock pt reason) = + mkObject [ "kind" .= String "IgnoreInvalidBlock" + , "block" .= forMachine dtal pt + , "reason" .= showT reason ] + forMachine dtal (ChainDB.AddedBlockToQueue pt sz) = + mkObject [ "kind" .= String "AddedBlockToQueue" + , "block" .= forMachine dtal pt + , "queueSize" .= toJSON sz ] + forMachine dtal (ChainDB.BlockInTheFuture pt slot) = + mkObject [ "kind" .= String "BlockInTheFuture" + , "block" .= forMachine dtal pt + , "slot" .= forMachine dtal slot ] + forMachine dtal (ChainDB.StoreButDontChange pt) = + mkObject [ "kind" .= String "StoreButDontChange" + , "block" .= forMachine dtal pt ] + forMachine dtal (ChainDB.TryAddToCurrentChain pt) = + mkObject [ "kind" .= String "TryAddToCurrentChain" + , "block" .= forMachine dtal pt ] + forMachine dtal (ChainDB.TrySwitchToAFork pt _) = + mkObject [ "kind" .= String "TraceAddBlockEvent.TrySwitchToAFork" + , "block" .= forMachine dtal pt ] + forMachine dtal (ChainDB.AddedToCurrentChain events _ base extended) = + mkObject $ + [ "kind" .= String "AddedToCurrentChain" + , "newtip" .= renderPointForDetails dtal (AF.headPoint extended) + ] + ++ [ "headers" .= toJSON (forMachine dtal `map` addedHdrsNewChain base extended) + | dtal == DDetailed ] + ++ [ "events" .= toJSON (map (forMachine dtal) events) + | not (null events) ] + forMachine dtal (ChainDB.SwitchedToAFork events _ old new) = + mkObject $ + [ "kind" .= String "TraceAddBlockEvent.SwitchedToAFork" + , "newtip" .= renderPointForDetails dtal (AF.headPoint new) + ] + ++ [ "headers" .= toJSON (forMachine dtal `map` addedHdrsNewChain old new) + | dtal == DDetailed ] + ++ [ "events" .= toJSON (map (forMachine dtal) events) + | not (null events) ] + forMachine dtal (ChainDB.AddBlockValidation ev') = + kindContext "AddBlockEvent" $ forMachine dtal ev' + forMachine dtal (ChainDB.AddedBlockToVolatileDB pt (BlockNo bn) _) = + mkObject [ "kind" .= String "AddedBlockToVolatileDB" + , "block" .= forMachine dtal pt + , "blockNo" .= showT bn ] + forMachine dtal (ChainDB.ChainSelectionForFutureBlock pt) = + mkObject [ "kind" .= String "TChainSelectionForFutureBlock" + , "block" .= forMachine dtal pt ] + + asMetrics (ChainDB.SwitchedToAFork _warnings newTipInfo _oldChain newChain) = + let ChainInformation { slots, blocks, density, epoch, slotInEpoch } = + chainInformation newTipInfo newChain 0 + in [ DoubleM ["density"] (fromRational density) + , IntM ["slots"] (fromIntegral slots) + , IntM ["blocks"] (fromIntegral blocks) + , IntM ["slotInEpoch"] (fromIntegral slotInEpoch) + , IntM ["epoch"] (fromIntegral (unEpochNo epoch)) + ] + asMetrics (ChainDB.AddedToCurrentChain _warnings newTipInfo _oldChain newChain) = + let ChainInformation { slots, blocks, density, epoch, slotInEpoch } = + chainInformation newTipInfo newChain 0 + in [ DoubleM ["density"] (fromRational density) + , IntM ["slotNum"] (fromIntegral slots) + , IntM ["blockNum"] (fromIntegral blocks) + , IntM ["slotInEpoch"] (fromIntegral slotInEpoch) + , IntM ["epoch"] (fromIntegral (unEpochNo epoch)) + ] + asMetrics _ = [] + +data ChainInformation = ChainInformation + { slots :: Word64 + , blocks :: Word64 + , density :: Rational + -- ^ the actual number of blocks created over the maximum expected number + -- of blocks that could be created over the span of the last @k@ blocks. + , epoch :: EpochNo + -- ^ In which epoch is the tip of the current chain + , slotInEpoch :: Word64 + -- ^ Relative slot number of the tip of the current chain within the + -- epoch. + , blocksUncoupledDelta :: Int64 + -- ^ The net change in number of blocks forged since last restart not on the + -- current chain. + } + +chainInformation + :: forall blk. HasHeader (Header blk) + => ChainDB.NewTipInfo blk + -> AF.AnchoredFragment (Header blk) + -> Int64 + -> ChainInformation +chainInformation newTipInfo frag blocksUncoupledDelta = ChainInformation + { slots = unSlotNo $ fromWithOrigin 0 (AF.headSlot frag) + , blocks = unBlockNo $ fromWithOrigin (BlockNo 1) (AF.headBlockNo frag) + , density = fragmentChainDensity frag + , epoch = ChainDB.newTipEpoch newTipInfo + , slotInEpoch = ChainDB.newTipSlotInEpoch newTipInfo + , blocksUncoupledDelta = blocksUncoupledDelta + } + +fragmentChainDensity :: + HasHeader (Header blk) + => AF.AnchoredFragment (Header blk) -> Rational +fragmentChainDensity frag = calcDensity blockD slotD + where + calcDensity :: Word64 -> Word64 -> Rational + calcDensity bl sl + | sl > 0 = toRational bl / toRational sl + | otherwise = 0 + slotN = unSlotNo $ fromWithOrigin 0 (AF.headSlot frag) + -- Slot of the tip - slot @k@ blocks back. Use 0 as the slot for genesis + -- includes EBBs + slotD = slotN + - unSlotNo (fromWithOrigin 0 (AF.lastSlot frag)) + -- Block numbers start at 1. We ignore the genesis EBB, which has block number 0. + blockD = blockN - firstBlock + blockN = unBlockNo $ fromWithOrigin (BlockNo 1) (AF.headBlockNo frag) + firstBlock = case unBlockNo . blockNo <$> AF.last frag of + -- Empty fragment, no blocks. We have that @blocks = 1 - 1 = 0@ + Left _ -> 1 + -- The oldest block is the genesis EBB with block number 0, + -- don't let it contribute to the number of blocks + Right 0 -> 1 + Right b -> b + + +instance ( HasHeader (Header blk) + , LedgerSupportsProtocol blk + , ConvertRawHash (Header blk) + , ConvertRawHash blk + , LogFormatting (RealPoint blk)) + => LogFormatting (ChainDB.TraceValidationEvent blk) where + forHuman (ChainDB.InvalidBlock err pt) = + "Invalid block " <> renderRealPointAsPhrase pt <> ": " <> showT err + forHuman (ChainDB.InvalidCandidate c) = + "Invalid candidate " <> renderPointAsPhrase (AF.headPoint c) + forHuman (ChainDB.ValidCandidate c) = + "Valid candidate " <> renderPointAsPhrase (AF.headPoint c) + forHuman (ChainDB.CandidateContainsFutureBlocks c hdrs) = + "Candidate contains blocks from near future: " <> + renderPointAsPhrase (AF.headPoint c) <> ", slots " <> + Text.intercalate ", " (map (renderPoint . headerPoint) hdrs) + forHuman (ChainDB.CandidateContainsFutureBlocksExceedingClockSkew c hdrs) = + "Candidate contains blocks from future exceeding clock skew limit: " <> + renderPointAsPhrase (AF.headPoint c) <> ", slots " <> + Text.intercalate ", " (map (renderPoint . headerPoint) hdrs) + + forMachine dtal (ChainDB.InvalidBlock err pt) = + mkObject [ "kind" .= String "InvalidBlock" + , "block" .= forMachine dtal pt + , "error" .= showT err ] + forMachine dtal (ChainDB.InvalidCandidate c) = + mkObject [ "kind" .= String "InvalidCandidate" + , "block" .= renderPointForDetails dtal (AF.headPoint c) ] + forMachine dtal (ChainDB.ValidCandidate c) = + mkObject [ "kind" .= String "ValidCandidate" + , "block" .= renderPointForDetails dtal (AF.headPoint c) ] + forMachine dtal (ChainDB.CandidateContainsFutureBlocks c hdrs) = + mkObject [ "kind" .= String "CandidateContainsFutureBlocks" + , "block" .= renderPointForDetails dtal (AF.headPoint c) + , "headers" .= map (renderPointForDetails dtal . headerPoint) hdrs ] + forMachine dtal (ChainDB.CandidateContainsFutureBlocksExceedingClockSkew c hdrs) = + mkObject [ "kind" .= String "CandidateContainsFutureBlocksExceedingClockSkew" + , "block" .= renderPointForDetails dtal (AF.headPoint c) + , "headers" .= map (renderPointForDetails dtal . headerPoint) hdrs ] + + + +instance (StandardHash blk, ConvertRawHash blk) + => LogFormatting (LedgerDB.TraceReplayEvent blk (Point blk)) where + forHuman (LedgerDB.ReplayFromGenesis _replayTo) = + "Replaying ledger from genesis" + forHuman (LedgerDB.ReplayFromSnapshot snap tip' _replayTo) = + "Replaying ledger from snapshot " <> showT snap <> " at " <> + renderRealPointAsPhrase tip' + forHuman (LedgerDB.ReplayedBlock pt _ledgerEvents replayTo) = + "Replayed block: slot " <> showT (realPointSlot pt) <> " of " <> showT (pointSlot replayTo) + + forMachine _dtal (LedgerDB.ReplayFromGenesis _replayTo) = + mkObject [ "kind" .= String "ReplayFromGenesis" ] + forMachine dtal (LedgerDB.ReplayFromSnapshot snap tip' _replayTo) = + mkObject [ "kind" .= String "ReplayFromSnapshot" + , "snapshot" .= forMachine dtal snap + , "tip" .= show tip' ] + forMachine _dtal (LedgerDB.ReplayedBlock pt _ledgerEvents replayTo) = + mkObject [ "kind" .= String "ReplayedBlock" + , "slot" .= unSlotNo (realPointSlot pt) + , "tip" .= withOrigin 0 unSlotNo (pointSlot replayTo) ] + +instance ( StandardHash blk + , ConvertRawHash blk) + => LogFormatting (LedgerDB.TraceEvent blk) where + forHuman (LedgerDB.TookSnapshot snap pt) = + "Took ledger snapshot " <> showT snap <> + " at " <> renderRealPointAsPhrase pt + forHuman (LedgerDB.DeletedSnapshot snap) = + "Deleted old snapshot " <> showT snap + forHuman (LedgerDB.InvalidSnapshot snap failure) = + "Invalid snapshot " <> showT snap <> showT failure + + forMachine dtals (LedgerDB.TookSnapshot snap pt) = + mkObject [ "kind" .= String "TookSnapshot" + , "snapshot" .= forMachine dtals snap + , "tip" .= show pt ] + forMachine dtals (LedgerDB.DeletedSnapshot snap) = + mkObject [ "kind" .= String "DeletedSnapshot" + , "snapshot" .= forMachine dtals snap ] + forMachine dtals (LedgerDB.InvalidSnapshot snap failure) = + mkObject [ "kind" .= String "TraceLedgerEvent.InvalidSnapshot" + , "snapshot" .= forMachine dtals snap + , "failure" .= show failure ] + + +instance ConvertRawHash blk + => LogFormatting (ChainDB.TraceCopyToImmutableDBEvent blk) where + forHuman (ChainDB.CopiedBlockToImmutableDB pt) = + "Copied block " <> renderPointAsPhrase pt <> " to the ImmDB" + forHuman ChainDB.NoBlocksToCopyToImmutableDB = + "There are no blocks to copy to the ImmDB" + + forMachine dtals (ChainDB.CopiedBlockToImmutableDB pt) = + mkObject [ "kind" .= String "CopiedBlockToImmutableDB" + , "slot" .= forMachine dtals pt ] + forMachine _dtals ChainDB.NoBlocksToCopyToImmutableDB = + mkObject [ "kind" .= String "NoBlocksToCopyToImmutableDB" ] + +instance LogFormatting (ChainDB.TraceGCEvent blk) where + forHuman (ChainDB.PerformedGC slot) = + "Performed a garbage collection for " <> condenseT slot + forHuman (ChainDB.ScheduledGC slot _difft) = + "Scheduled a garbage collection for " <> condenseT slot + + forMachine dtals (ChainDB.PerformedGC slot) = + mkObject [ "kind" .= String "PerformedGC" + , "slot" .= forMachine dtals slot ] + forMachine dtals (ChainDB.ScheduledGC slot difft) = + mkObject $ [ "kind" .= String "TraceGCEvent.ScheduledGC" + , "slot" .= forMachine dtals slot ] <> + [ "difft" .= String ((Text.pack . show) difft) | dtals >= DDetailed] + +instance ConvertRawHash blk + => LogFormatting (ChainDB.TraceOpenEvent blk) where + forHuman (ChainDB.OpenedDB immTip tip') = + "Opened db with immutable tip at " <> renderPointAsPhrase immTip <> + " and tip " <> renderPointAsPhrase tip' + forHuman (ChainDB.ClosedDB immTip tip') = + "Closed db with immutable tip at " <> renderPointAsPhrase immTip <> + " and tip " <> renderPointAsPhrase tip' + forHuman (ChainDB.OpenedImmutableDB immTip chunk) = + "Opened imm db with immutable tip at " <> renderPointAsPhrase immTip <> + " and chunk " <> showT chunk + forHuman ChainDB.OpenedVolatileDB = "Opened vol db" + forHuman ChainDB.OpenedLgrDB = "Opened lgr db" + + forMachine dtal (ChainDB.OpenedDB immTip tip')= + mkObject [ "kind" .= String "OpenedDB" + , "immtip" .= forMachine dtal immTip + , "tip" .= forMachine dtal tip' ] + forMachine dtal (ChainDB.ClosedDB immTip tip') = + mkObject [ "kind" .= String "TraceOpenEvent.ClosedDB" + , "immtip" .= forMachine dtal immTip + , "tip" .= forMachine dtal tip' ] + forMachine dtal (ChainDB.OpenedImmutableDB immTip epoch) = + mkObject [ "kind" .= String "OpenedImmutableDB" + , "immtip" .= forMachine dtal immTip + , "epoch" .= String ((Text.pack . show) epoch) ] + forMachine _dtal ChainDB.OpenedVolatileDB = + mkObject [ "kind" .= String "OpenedVolatileDB" ] + forMachine _dtal ChainDB.OpenedLgrDB = + mkObject [ "kind" .= String "OpenedLgrDB" ] + + + +instance ( StandardHash blk + , ConvertRawHash blk + ) => LogFormatting (ChainDB.TraceIteratorEvent blk) where + forHuman (ChainDB.UnknownRangeRequested ev') = forHuman ev' + forHuman (ChainDB.BlockMissingFromVolatileDB realPt) = + "This block is no longer in the VolatileDB because it has been garbage\ + \ collected. It might now be in the ImmDB if it was part of the\ + \ current chain. Block: " <> renderRealPoint realPt + forHuman (ChainDB.StreamFromImmutableDB sFrom sTo) = + "Stream only from the ImmDB. StreamFrom:" <> showT sFrom <> + " StreamTo: " <> showT sTo + forHuman (ChainDB.StreamFromBoth sFrom sTo pts) = + "Stream from both the VolatileDB and the ImmDB." + <> " StreamFrom: " <> showT sFrom <> " StreamTo: " <> showT sTo + <> " Points: " <> showT (map renderRealPoint pts) + forHuman (ChainDB.StreamFromVolatileDB sFrom sTo pts) = + "Stream only from the VolatileDB." + <> " StreamFrom: " <> showT sFrom <> " StreamTo: " <> showT sTo + <> " Points: " <> showT (map renderRealPoint pts) + forHuman (ChainDB.BlockWasCopiedToImmutableDB pt) = + "This block has been garbage collected from the VolatileDB is now\ + \ found and streamed from the ImmDB. Block: " <> renderRealPoint pt + forHuman (ChainDB.BlockGCedFromVolatileDB pt) = + "This block no longer in the VolatileDB and isn't in the ImmDB\ + \ either; it wasn't part of the current chain. Block: " <> renderRealPoint pt + forHuman ChainDB.SwitchBackToVolatileDB = "SwitchBackToVolatileDB" + + forMachine _dtal (ChainDB.UnknownRangeRequested unkRange) = + mkObject [ "kind" .= String "UnknownRangeRequested" + , "range" .= String (showT unkRange) + ] + forMachine _dtal (ChainDB.StreamFromVolatileDB streamFrom streamTo realPt) = + mkObject [ "kind" .= String "StreamFromVolatileDB" + , "from" .= String (showT streamFrom) + , "to" .= String (showT streamTo) + , "point" .= String (Text.pack . show $ map renderRealPoint realPt) + ] + forMachine _dtal (ChainDB.StreamFromImmutableDB streamFrom streamTo) = + mkObject [ "kind" .= String "StreamFromImmutableDB" + , "from" .= String (showT streamFrom) + , "to" .= String (showT streamTo) + ] + forMachine _dtal (ChainDB.StreamFromBoth streamFrom streamTo realPt) = + mkObject [ "kind" .= String "StreamFromBoth" + , "from" .= String (showT streamFrom) + , "to" .= String (showT streamTo) + , "point" .= String (Text.pack . show $ map renderRealPoint realPt) + ] + forMachine _dtal (ChainDB.BlockMissingFromVolatileDB realPt) = + mkObject [ "kind" .= String "BlockMissingFromVolatileDB" + , "point" .= String (renderRealPoint realPt) + ] + forMachine _dtal (ChainDB.BlockWasCopiedToImmutableDB realPt) = + mkObject [ "kind" .= String "BlockWasCopiedToImmutableDB" + , "point" .= String (renderRealPoint realPt) + ] + forMachine _dtal (ChainDB.BlockGCedFromVolatileDB realPt) = + mkObject [ "kind" .= String "BlockGCedFromVolatileDB" + , "point" .= String (renderRealPoint realPt) + ] + forMachine _dtal ChainDB.SwitchBackToVolatileDB = + mkObject ["kind" .= String "SwitchBackToVolatileDB" + ] + +instance ( StandardHash blk + , ConvertRawHash blk + ) => LogFormatting (ChainDB.UnknownRange blk) where + forHuman (ChainDB.MissingBlock realPt) = + "The block at the given point was not found in the ChainDB." + <> renderRealPoint realPt + forHuman (ChainDB.ForkTooOld streamFrom) = + "The requested range forks off too far in the past" + <> showT streamFrom + + forMachine _dtal (ChainDB.MissingBlock realPt) = + mkObject [ "kind" .= String "MissingBlock" + , "point" .= String (renderRealPoint realPt) + ] + forMachine _dtal (ChainDB.ForkTooOld streamFrom) = + mkObject [ "kind" .= String "ForkTooOld" + , "from" .= String (showT streamFrom) + ] + +instance (Show (PBFT.PBftVerKeyHash c)) + => LogFormatting (PBFT.PBftValidationErr c) where + forMachine _dtal (PBFT.PBftInvalidSignature text) = + mkObject + [ "kind" .= String "PBftInvalidSignature" + , "error" .= String text + ] + forMachine _dtal (PBFT.PBftNotGenesisDelegate vkhash _ledgerView) = + mkObject + [ "kind" .= String "PBftNotGenesisDelegate" + , "vk" .= String (Text.pack $ show vkhash) + ] + forMachine _dtal (PBFT.PBftExceededSignThreshold vkhash numForged) = + mkObject + [ "kind" .= String "PBftExceededSignThreshold" + , "vk" .= String (Text.pack $ show vkhash) + , "numForged" .= String (Text.pack (show numForged)) + ] + forMachine _dtal PBFT.PBftInvalidSlot = + mkObject + [ "kind" .= String "PBftInvalidSlot" + ] + +instance (Show (PBFT.PBftVerKeyHash c)) + => LogFormatting (PBFT.PBftCannotForge c) where + forMachine _dtal (PBFT.PBftCannotForgeInvalidDelegation vkhash) = + mkObject + [ "kind" .= String "PBftCannotForgeInvalidDelegation" + , "vk" .= String (Text.pack $ show vkhash) + ] + forMachine _dtal (PBFT.PBftCannotForgeThresholdExceeded numForged) = + mkObject + [ "kind" .= String "PBftCannotForgeThresholdExceeded" + , "numForged" .= numForged + ] + +instance (ConvertRawHash blk, LedgerSupportsProtocol blk) + => LogFormatting (ChainDB.TraceInitChainSelEvent blk) where + forHuman (ChainDB.InitChainSelValidation v) = forHuman v + + forMachine dtal (ChainDB.InitChainSelValidation v) = + kindContext "InitChainSelValidation" $ forMachine dtal v + + asMetrics (ChainDB.InitChainSelValidation v) = asMetrics v + +instance (ConvertRawHash blk, StandardHash blk) => LogFormatting (ChainDB.TraceFollowerEvent blk) where + forHuman ChainDB.NewFollower = "A new Follower was created" + forHuman (ChainDB.FollowerNoLongerInMem _rrs) = + "The follower was in the 'FollowerInMem' state but its point is no longer on\ + \ the in-memory chain fragment, so it has to switch to the\ + \ 'FollowerInImmutableDB' state" + forHuman (ChainDB.FollowerSwitchToMem point slot) = + "The follower was in the 'FollowerInImmutableDB' state and is switched to\ + \ the 'FollowerInMem' state. Point: " <> showT point <> " slot: " <> showT slot + forHuman (ChainDB.FollowerNewImmIterator point slot) = + "The follower is in the 'FollowerInImmutableDB' state but the iterator is\ + \ exhausted while the ImmDB has grown, so we open a new iterator to\ + \ stream these blocks too. Point: " <> showT point <> " slot: " <> showT slot + + forMachine _dtal ChainDB.NewFollower = + mkObject [ "kind" .= String "NewFollower" ] + forMachine _dtal (ChainDB.FollowerNoLongerInMem _) = + mkObject [ "kind" .= String "FollowerNoLongerInMem" ] + forMachine _dtal (ChainDB.FollowerSwitchToMem _ _) = + mkObject [ "kind" .= String "FollowerSwitchToMem" ] + forMachine _dtal (ChainDB.FollowerNewImmIterator _ _) = + mkObject [ "kind" .= String "FollowerNewImmIterator" ] + +instance (ConvertRawHash blk, StandardHash blk) + => LogFormatting (ImmDB.TraceEvent blk) where + forMachine _dtal ImmDB.NoValidLastLocation = + mkObject [ "kind" .= String "NoValidLastLocation" ] + forMachine _dtal (ImmDB.ValidatedLastLocation chunkNo immTip) = + mkObject [ "kind" .= String "ValidatedLastLocation" + , "chunkNo" .= String (renderChunkNo chunkNo) + , "immTip" .= String (renderTipHash immTip) + , "blockNo" .= String (renderTipBlockNo immTip) + ] + forMachine _dtal (ImmDB.ValidatingChunk chunkNo) = + mkObject [ "kind" .= String "ValidatingChunk" + , "chunkNo" .= String (renderChunkNo chunkNo) + ] + forMachine _dtal (ImmDB.MissingChunkFile chunkNo) = + mkObject [ "kind" .= String "MissingChunkFile" + , "chunkNo" .= String (renderChunkNo chunkNo) + ] + forMachine _dtal (ImmDB.InvalidChunkFile chunkNo (ImmDB.ChunkErrRead readIncErr)) = + mkObject [ "kind" .= String "ChunkErrRead" + , "chunkNo" .= String (renderChunkNo chunkNo) + , "error" .= String (showT readIncErr) + ] + forMachine _dtal (ImmDB.InvalidChunkFile chunkNo + (ImmDB.ChunkErrHashMismatch hashPrevBlock prevHashOfBlock)) = + mkObject [ "kind" .= String "ChunkErrHashMismatch" + , "chunkNo" .= String (renderChunkNo chunkNo) + , "hashPrevBlock" .= String (Text.decodeLatin1 + . toRawHash (Proxy @blk) $ hashPrevBlock) + , "prevHashOfBlock" .= String (renderChainHash (Text.decodeLatin1 + . toRawHash (Proxy @blk)) prevHashOfBlock) + ] + forMachine dtal (ImmDB.InvalidChunkFile chunkNo (ImmDB.ChunkErrCorrupt pt)) = + mkObject [ "kind" .= String "ChunkErrCorrupt" + , "chunkNo" .= String (renderChunkNo chunkNo) + , "block" .= String (renderPointForDetails dtal pt) + ] + forMachine _dtal (ImmDB.ChunkFileDoesntFit expectPrevHash actualPrevHash) = + mkObject [ "kind" .= String "ChunkFileDoesntFit" + , "expectedPrevHash" .= String (renderChainHash (Text.decodeLatin1 + . toRawHash (Proxy @blk)) expectPrevHash) + , "actualPrevHash" .= String (renderChainHash (Text.decodeLatin1 + . toRawHash (Proxy @blk)) actualPrevHash) + ] + forMachine _dtal (ImmDB.MissingPrimaryIndex chunkNo) = + mkObject [ "kind" .= String "MissingPrimaryIndex" + , "chunkNo" .= String (renderChunkNo chunkNo) + ] + forMachine _dtal (ImmDB.MissingSecondaryIndex chunkNo) = + mkObject [ "kind" .= String "MissingSecondaryIndex" + , "chunkNo" .= String (renderChunkNo chunkNo) + ] + forMachine _dtal (ImmDB.InvalidPrimaryIndex chunkNo) = + mkObject [ "kind" .= String "InvalidPrimaryIndex" + , "chunkNo" .= String (renderChunkNo chunkNo) + ] + forMachine _dtal (ImmDB.InvalidSecondaryIndex chunkNo) = + mkObject [ "kind" .= String "InvalidSecondaryIndex" + , "chunkNo" .= String (renderChunkNo chunkNo) + ] + forMachine _dtal (ImmDB.RewritePrimaryIndex chunkNo) = + mkObject [ "kind" .= String "RewritePrimaryIndex" + , "chunkNo" .= String (renderChunkNo chunkNo) + ] + forMachine _dtal (ImmDB.RewriteSecondaryIndex chunkNo) = + mkObject [ "kind" .= String "RewriteSecondaryIndex" + , "chunkNo" .= String (renderChunkNo chunkNo) + ] + forMachine _dtal (ImmDB.Migrating txt) = + mkObject [ "kind" .= String "Migrating" + , "info" .= String txt + ] + forMachine _dtal (ImmDB.DeletingAfter immTipWithInfo) = + mkObject [ "kind" .= String "DeletingAfter" + , "immTipHash" .= String (renderWithOrigin renderTipHash immTipWithInfo) + , "immTipBlockNo" .= String (renderWithOrigin renderTipBlockNo immTipWithInfo) + ] + forMachine _dtal ImmDB.DBAlreadyClosed = + mkObject [ "kind" .= String "DBAlreadyClosed" ] + forMachine _dtal ImmDB.DBClosed = + mkObject [ "kind" .= String "DBClosed" ] + forMachine dtal (ImmDB.TraceCacheEvent cacheEv) = + kindContext "TraceCacheEvent" $ forMachine dtal cacheEv + + +instance LogFormatting ImmDB.TraceCacheEvent where + forMachine _dtal (ImmDB.TraceCurrentChunkHit chunkNo nbPastChunksInCache) = + mkObject [ "kind" .= String "TraceCurrentChunkHit" + , "chunkNo" .= String (renderChunkNo chunkNo) + , "noPastChunks" .= String (showT nbPastChunksInCache) + ] + forMachine _dtal (ImmDB.TracePastChunkHit chunkNo nbPastChunksInCache) = + mkObject [ "kind" .= String "TracePastChunkHit" + , "chunkNo" .= String (renderChunkNo chunkNo) + , "noPastChunks" .= String (showT nbPastChunksInCache) + ] + forMachine _dtal (ImmDB.TracePastChunkMiss chunkNo nbPastChunksInCache) = + mkObject [ "kind" .= String "TracePastChunkMiss" + , "chunkNo" .= String (renderChunkNo chunkNo) + , "noPastChunks" .= String (showT nbPastChunksInCache) + ] + forMachine _dtal (ImmDB.TracePastChunkEvict chunkNo nbPastChunksInCache) = + mkObject [ "kind" .= String "TracePastChunkEvict" + , "chunkNo" .= String (renderChunkNo chunkNo) + , "noPastChunks" .= String (showT nbPastChunksInCache) + ] + forMachine _dtal (ImmDB.TracePastChunksExpired chunkNos nbPastChunksInCache) = + mkObject [ "kind" .= String "TracePastChunksExpired" + , "chunkNos" .= String (Text.pack . show $ map renderChunkNo chunkNos) + , "noPastChunks" .= String (showT nbPastChunksInCache) + ] + +instance StandardHash blk => LogFormatting (VolDB.TraceEvent blk) where + forMachine _dtal VolDB.DBAlreadyClosed = + mkObject [ "kind" .= String "DBAlreadyClosed"] + forMachine _dtal VolDB.DBAlreadyOpen = + mkObject [ "kind" .= String "DBAlreadyOpen"] + forMachine _dtal (VolDB.BlockAlreadyHere blockId) = + mkObject [ "kind" .= String "BlockAlreadyHere" + , "blockId" .= String (showT blockId) + ] + forMachine _dtal (VolDB.TruncateCurrentFile fsPath) = + mkObject [ "kind" .= String "TruncateCurrentFile" + , "file" .= String (showT fsPath) + ] + forMachine _dtal (VolDB.Truncate pErr fsPath blockOffset) = + mkObject [ "kind" .= String "Truncate" + , "parserError" .= String (showT pErr) + , "file" .= String (showT fsPath) + , "blockOffset" .= String (showT blockOffset) + ] + forMachine _dtal (VolDB.InvalidFileNames fsPaths) = + mkObject [ "kind" .= String "InvalidFileNames" + , "files" .= String (Text.pack . show $ map show fsPaths) + ] + +instance ( ConvertRawHash blk + , StandardHash blk + , LogFormatting (LedgerError blk) + , LogFormatting (RealPoint blk) + , LogFormatting (OtherHeaderEnvelopeError blk) + , LogFormatting (ExtValidationError blk) + , LogFormatting (ValidationErr (BlockProtocol blk)) + ) + => LogFormatting (ChainDB.InvalidBlockReason blk) where + forMachine dtal (ChainDB.ValidationError extvalerr) = + mkObject + [ "kind" .= String "ValidationError" + , "error" .= forMachine dtal extvalerr + ] + forMachine dtal (ChainDB.InFutureExceedsClockSkew point) = + mkObject + [ "kind" .= String "InFutureExceedsClockSkew" + , "point" .= forMachine dtal point + ] diff --git a/cardano-node/src/Cardano/TraceDispatcher/Consensus/Combinators.hs b/cardano-node/src/Cardano/TraceDispatcher/Consensus/Combinators.hs new file mode 100644 index 00000000000..02a588d029d --- /dev/null +++ b/cardano-node/src/Cardano/TraceDispatcher/Consensus/Combinators.hs @@ -0,0 +1,345 @@ + +module Cardano.TraceDispatcher.Consensus.Combinators + ( + severityChainSyncClientEvent + , namesForChainSyncClientEvent + + , severityChainSyncServerEvent + , namesForChainSyncServerEvent + + , severityBlockFetchDecision + , namesForBlockFetchDecision + + , severityBlockFetchClient + , namesForBlockFetchClient + + , severityBlockFetchServer + , namesForBlockFetchServer + + , severityTxInbound + , namesForTxInbound + + , severityTxOutbound + , namesForTxOutbound + + , severityLocalTxSubmissionServer + , namesForLocalTxSubmissionServer + + , severityMempool + , namesForMempool + + , TraceStartLeadershipCheckPlus (..) + , ForgeTracerType + , forgeTracerTransform + , severityForge + , namesForForge + + , namesForBlockchainTime + , severityBlockchainTime + + , namesForKeepAliveClient + , severityKeepAliveClient + + ) where + + +import Cardano.Logging +import Cardano.Prelude +import Cardano.TraceDispatcher.Consensus.StartLeadershipCheck + +import qualified Ouroboros.Network.BlockFetch.ClientState as BlockFetch +import Ouroboros.Network.BlockFetch.Decision +import Ouroboros.Network.KeepAlive (TraceKeepAliveClient (..)) +import Ouroboros.Network.TxSubmission.Inbound +import Ouroboros.Network.TxSubmission.Outbound + +import Ouroboros.Consensus.Block (Point) +import Ouroboros.Consensus.BlockchainTime.WallClock.Util + (TraceBlockchainTimeEvent (..)) +import Ouroboros.Consensus.HardFork.Combinator +import Ouroboros.Consensus.Ledger.SupportsMempool (GenTxId) +import Ouroboros.Consensus.Mempool.API (TraceEventMempool (..)) +import Ouroboros.Consensus.MiniProtocol.BlockFetch.Server + (TraceBlockFetchServerEvent (..)) +import Ouroboros.Consensus.MiniProtocol.ChainSync.Client +import Ouroboros.Consensus.MiniProtocol.ChainSync.Server +import Ouroboros.Consensus.MiniProtocol.LocalTxSubmission.Server + (TraceLocalTxSubmissionServerEvent (..)) +import Ouroboros.Consensus.Node.Tracers + +severityChainSyncClientEvent :: + BlockFetch.TraceLabelPeer peer (TraceChainSyncClientEvent blk) -> SeverityS +severityChainSyncClientEvent (BlockFetch.TraceLabelPeer _ e) = + severityChainSyncClientEvent' e + +namesForChainSyncClientEvent :: + BlockFetch.TraceLabelPeer peer (TraceChainSyncClientEvent blk) -> [Text] +namesForChainSyncClientEvent (BlockFetch.TraceLabelPeer _ e) = + namesForChainSyncClientEvent' e + + +severityChainSyncClientEvent' :: TraceChainSyncClientEvent blk -> SeverityS +severityChainSyncClientEvent' TraceDownloadedHeader {} = Info +severityChainSyncClientEvent' TraceFoundIntersection {} = Info +severityChainSyncClientEvent' TraceRolledBack {} = Notice +severityChainSyncClientEvent' TraceException {} = Warning +severityChainSyncClientEvent' TraceTermination {} = Notice + +namesForChainSyncClientEvent' :: TraceChainSyncClientEvent blk -> [Text] +namesForChainSyncClientEvent' TraceDownloadedHeader {} = + ["DownloadedHeader"] +namesForChainSyncClientEvent' TraceFoundIntersection {} = + ["FoundIntersection"] +namesForChainSyncClientEvent' TraceRolledBack {} = + ["RolledBack"] +namesForChainSyncClientEvent' TraceException {} = + ["Exception"] +namesForChainSyncClientEvent' TraceTermination {} = + ["Termination"] + +severityChainSyncServerEvent :: TraceChainSyncServerEvent blk -> SeverityS +severityChainSyncServerEvent TraceChainSyncServerRead {} = Info +severityChainSyncServerEvent TraceChainSyncServerReadBlocked {} = Info +severityChainSyncServerEvent TraceChainSyncRollForward {} = Info +severityChainSyncServerEvent TraceChainSyncRollBackward {} = Info + +namesForChainSyncServerEvent :: TraceChainSyncServerEvent blk -> [Text] +namesForChainSyncServerEvent TraceChainSyncServerRead {} = + ["ServerRead"] +namesForChainSyncServerEvent TraceChainSyncServerReadBlocked {} = + ["ServerReadBlocked"] +namesForChainSyncServerEvent TraceChainSyncRollForward {} = + ["RollForward"] +namesForChainSyncServerEvent TraceChainSyncRollBackward {} = + ["RollBackward"] + +severityBlockFetchDecision :: + [BlockFetch.TraceLabelPeer peer (FetchDecision [Point header])] + -> SeverityS +severityBlockFetchDecision [] = Info +severityBlockFetchDecision l = maximum $ + map (\(BlockFetch.TraceLabelPeer _ a) -> fetchDecisionSeverity a) l + where + fetchDecisionSeverity :: FetchDecision a -> SeverityS + fetchDecisionSeverity fd = + case fd of + Left FetchDeclineChainNotPlausible -> Debug + Left FetchDeclineChainNoIntersection -> Notice + Left FetchDeclineAlreadyFetched -> Debug + Left FetchDeclineInFlightThisPeer -> Debug + Left FetchDeclineInFlightOtherPeer -> Debug + Left FetchDeclinePeerShutdown -> Info + Left FetchDeclinePeerSlow -> Info + Left FetchDeclineReqsInFlightLimit {} -> Info + Left FetchDeclineBytesInFlightLimit {} -> Info + Left FetchDeclinePeerBusy {} -> Info + Left FetchDeclineConcurrencyLimit {} -> Info + Right _ -> Info + +namesForBlockFetchDecision :: + [BlockFetch.TraceLabelPeer peer (FetchDecision [Point header])] + -> [Text] +namesForBlockFetchDecision _ = [] + +severityBlockFetchClient :: + BlockFetch.TraceLabelPeer peer (BlockFetch.TraceFetchClientState header) + -> SeverityS +severityBlockFetchClient (BlockFetch.TraceLabelPeer _p bf) = severityBlockFetchClient' bf + +severityBlockFetchClient' :: + (BlockFetch.TraceFetchClientState header) + -> SeverityS +severityBlockFetchClient' BlockFetch.AddedFetchRequest {} = Info +severityBlockFetchClient' BlockFetch.AcknowledgedFetchRequest {} = Info +severityBlockFetchClient' BlockFetch.SendFetchRequest {} = Info +severityBlockFetchClient' BlockFetch.StartedFetchBatch {} = Info +severityBlockFetchClient' BlockFetch.CompletedBlockFetch {} = Info +severityBlockFetchClient' BlockFetch.CompletedFetchBatch {} = Info +severityBlockFetchClient' BlockFetch.RejectedFetchBatch {} = Info +severityBlockFetchClient' BlockFetch.ClientTerminating {} = Notice + +namesForBlockFetchClient :: + BlockFetch.TraceLabelPeer peer (BlockFetch.TraceFetchClientState header) + -> [Text] +namesForBlockFetchClient (BlockFetch.TraceLabelPeer _p bf) = namesForBlockFetchClient' bf + +namesForBlockFetchClient' :: + BlockFetch.TraceFetchClientState header + -> [Text] +namesForBlockFetchClient' BlockFetch.AddedFetchRequest {} = + ["AddedFetchRequest"] +namesForBlockFetchClient' BlockFetch.AcknowledgedFetchRequest {} = + ["AcknowledgedFetchRequest"] +namesForBlockFetchClient' BlockFetch.SendFetchRequest {} = + ["SendFetchRequest"] +namesForBlockFetchClient' BlockFetch.StartedFetchBatch {} = + ["StartedFetchBatch"] +namesForBlockFetchClient' BlockFetch.CompletedBlockFetch {} = + ["CompletedBlockFetch"] +namesForBlockFetchClient' BlockFetch.CompletedFetchBatch {} = + ["CompletedFetchBatch"] +namesForBlockFetchClient' BlockFetch.RejectedFetchBatch {} = + ["RejectedFetchBatch"] +namesForBlockFetchClient' BlockFetch.ClientTerminating {} = + ["ClientTerminating"] + +severityBlockFetchServer :: + (TraceBlockFetchServerEvent blk) + -> SeverityS +severityBlockFetchServer _ = Info + +namesForBlockFetchServer :: + (TraceBlockFetchServerEvent blk) + -> [Text] +namesForBlockFetchServer TraceBlockFetchServerSendBlock {} = ["SendBlock"] + +severityTxInbound :: + BlockFetch.TraceLabelPeer peer (TraceTxSubmissionInbound (GenTxId blk) (GenTx blk)) + -> SeverityS +severityTxInbound (BlockFetch.TraceLabelPeer _p ti) = severityTxInbound' ti + +severityTxInbound' :: + TraceTxSubmissionInbound (GenTxId blk) (GenTx blk) + -> SeverityS +severityTxInbound' _ti = Info + +namesForTxInbound :: + BlockFetch.TraceLabelPeer peer (TraceTxSubmissionInbound (GenTxId blk) (GenTx blk)) + -> [Text] +namesForTxInbound (BlockFetch.TraceLabelPeer _p ti) = namesForTxInbound' ti + +namesForTxInbound' :: + TraceTxSubmissionInbound (GenTxId blk) (GenTx blk) + -> [Text] +namesForTxInbound' TraceTxSubmissionCollected {} = + ["TxSubmissionCollected"] +namesForTxInbound' TraceTxSubmissionProcessed {} = + ["TxSubmissionProcessed"] +namesForTxInbound' TraceTxInboundTerminated {} = + ["TxInboundTerminated"] +namesForTxInbound' TraceTxInboundCanRequestMoreTxs {} = + ["TxInboundCanRequestMoreTxs"] +namesForTxInbound' TraceTxInboundCannotRequestMoreTxs {} = + ["TxInboundCannotRequestMoreTxs"] + +severityTxOutbound :: + BlockFetch.TraceLabelPeer peer (TraceTxSubmissionOutbound (GenTxId blk) (GenTx blk)) + -> SeverityS +severityTxOutbound (BlockFetch.TraceLabelPeer _p ti) = severityTxOutbound' ti + +severityTxOutbound' :: + TraceTxSubmissionOutbound (GenTxId blk) (GenTx blk) + -> SeverityS +severityTxOutbound' _ti = Info + +namesForTxOutbound :: + BlockFetch.TraceLabelPeer peer (TraceTxSubmissionOutbound (GenTxId blk) (GenTx blk)) + -> [Text] +namesForTxOutbound (BlockFetch.TraceLabelPeer _p ti) = namesForTxOutbound' ti + +namesForTxOutbound' :: + TraceTxSubmissionOutbound (GenTxId blk) (GenTx blk) + -> [Text] +namesForTxOutbound' TraceTxSubmissionOutboundRecvMsgRequestTxs {} = + ["TxSubmissionOutboundRecvMsgRequest"] +namesForTxOutbound' TraceTxSubmissionOutboundSendMsgReplyTxs {} = + ["TxSubmissionOutboundSendMsgReply"] +namesForTxOutbound' TraceControlMessage {} = + ["ControlMessage"] + +severityLocalTxSubmissionServer :: + (TraceLocalTxSubmissionServerEvent blk) + -> SeverityS +severityLocalTxSubmissionServer _ = Info + +namesForLocalTxSubmissionServer :: + (TraceLocalTxSubmissionServerEvent blk) + -> [Text] +namesForLocalTxSubmissionServer TraceReceivedTx {} = ["ReceivedTx"] + +severityMempool :: + (TraceEventMempool blk) + -> SeverityS +severityMempool _ = Info + +-- TODO: not working with undefines because of bang patterns +namesForMempool :: TraceEventMempool blk -> [Text] +-- namesForMempool (TraceMempoolAddedTx _ _ _) = ["AddedTx"] +-- namesForMempool TraceMempoolRejectedTx {} = ["RejectedTx"] +-- namesForMempool TraceMempoolRemoveTxs {} = ["RemoveTxs"] +-- namesForMempool TraceMempoolManuallyRemovedTxs {} = ["ManuallyRemovedTxs"] +namesForMempool _ = [] + +severityForge :: ForgeTracerType blk -> SeverityS +severityForge (Left t) = severityForge' t +severityForge (Right t) = severityForge''' t + +severityForge' :: TraceLabelCreds (TraceForgeEvent blk) -> SeverityS +severityForge' (TraceLabelCreds _t e) = severityForge'' e + +severityForge'' :: TraceForgeEvent blk -> SeverityS +severityForge'' TraceStartLeadershipCheck {} = Info +severityForge'' TraceSlotIsImmutable {} = Error +severityForge'' TraceBlockFromFuture {} = Error +severityForge'' TraceBlockContext {} = Debug +severityForge'' TraceNoLedgerState {} = Error +severityForge'' TraceLedgerState {} = Debug +severityForge'' TraceNoLedgerView {} = Error +severityForge'' TraceLedgerView {} = Debug +severityForge'' TraceForgeStateUpdateError {} = Error +severityForge'' TraceNodeCannotForge {} = Error +severityForge'' TraceNodeNotLeader {} = Info +severityForge'' TraceNodeIsLeader {} = Info +severityForge'' TraceForgedBlock {} = Info +severityForge'' TraceDidntAdoptBlock {} = Error +severityForge'' TraceForgedInvalidBlock {} = Error +severityForge'' TraceAdoptedBlock {} = Info + +severityForge''' :: TraceLabelCreds TraceStartLeadershipCheckPlus -> SeverityS +severityForge''' _ = Info + +namesForForge :: ForgeTracerType blk -> [Text] +namesForForge (Left t) = namesForForge' t +namesForForge (Right t) = namesForForge''' t + +namesForForge' :: TraceLabelCreds (TraceForgeEvent blk) -> [Text] +namesForForge' (TraceLabelCreds _t e) = namesForForge'' e + +namesForForge'' :: TraceForgeEvent blk -> [Text] +namesForForge'' TraceStartLeadershipCheck {} = ["StartLeadershipCheck"] +namesForForge'' TraceSlotIsImmutable {} = ["SlotIsImmutable"] +namesForForge'' TraceBlockFromFuture {} = ["BlockFromFuture"] +namesForForge'' TraceBlockContext {} = ["BlockContext"] +namesForForge'' TraceNoLedgerState {} = ["NoLedgerState"] +namesForForge'' TraceLedgerState {} = ["LedgerState"] +namesForForge'' TraceNoLedgerView {} = ["NoLedgerView"] +namesForForge'' TraceLedgerView {} = ["LedgerView"] +namesForForge'' TraceForgeStateUpdateError {} = ["ForgeStateUpdateError"] +namesForForge'' TraceNodeCannotForge {} = ["NodeCannotForge"] +namesForForge'' TraceNodeNotLeader {} = ["NodeNotLeader"] +namesForForge'' TraceNodeIsLeader {} = ["NodeIsLeader"] +namesForForge'' TraceForgedBlock {} = ["ForgedBlock"] +namesForForge'' TraceDidntAdoptBlock {} = ["DidntAdoptBlock"] +namesForForge'' TraceForgedInvalidBlock {} = ["ForgedInvalidBlock"] +namesForForge'' TraceAdoptedBlock {} = ["AdoptedBlock"] + +namesForForge''' :: TraceLabelCreds TraceStartLeadershipCheckPlus -> [Text] +namesForForge''' (TraceLabelCreds _ (TraceStartLeadershipCheckPlus {})) = + ["StartLeadershipCheckPlus"] + +namesForBlockchainTime :: TraceBlockchainTimeEvent t -> [Text] +namesForBlockchainTime TraceStartTimeInTheFuture {} = ["StartTimeInTheFuture"] +namesForBlockchainTime TraceCurrentSlotUnknown {} = ["CurrentSlotUnknown"] +namesForBlockchainTime TraceSystemClockMovedBack {} = ["SystemClockMovedBack"] + +-- TODO JNF: Confirm the severities +severityBlockchainTime :: TraceBlockchainTimeEvent t -> SeverityS +severityBlockchainTime TraceStartTimeInTheFuture {} = Warning +severityBlockchainTime TraceCurrentSlotUnknown {} = Warning +severityBlockchainTime TraceSystemClockMovedBack {} = Warning + +namesForKeepAliveClient :: TraceKeepAliveClient peer -> [Text] +namesForKeepAliveClient _ = ["KeepAliveClient"] + +severityKeepAliveClient :: TraceKeepAliveClient peer -> SeverityS +severityKeepAliveClient _ = Info diff --git a/cardano-node/src/Cardano/TraceDispatcher/Consensus/Docu.hs b/cardano-node/src/Cardano/TraceDispatcher/Consensus/Docu.hs new file mode 100644 index 00000000000..606b109cde5 --- /dev/null +++ b/cardano-node/src/Cardano/TraceDispatcher/Consensus/Docu.hs @@ -0,0 +1,688 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} + + +{-# OPTIONS_GHC -Wno-deprecations #-} + +module Cardano.TraceDispatcher.Consensus.Docu + ( docChainSyncClientEvent + , docChainSyncServerEvent + , docBlockFetchDecision + , docBlockFetchClient + , docBlockFetchServer + , docTxInbound + , docTxOutbound + , docLocalTxSubmissionServer + , docMempool + , docForge + , docForgeStateInfo + , docBlockchainTime + , docKeepAliveClient + ) where + +import Cardano.Logging +import Cardano.Prelude +import Data.Time.Calendar.OrdinalDate (fromOrdinalDate) +import Data.Time.Clock + +import Ouroboros.Consensus.Block +import Ouroboros.Consensus.BlockchainTime.WallClock.Types + (SystemStart (..)) +import Ouroboros.Consensus.BlockchainTime.WallClock.Util + (TraceBlockchainTimeEvent (..)) +import Ouroboros.Consensus.Forecast (OutsideForecastRange) +import Ouroboros.Consensus.HardFork.History (PastHorizonException) +import Ouroboros.Consensus.Ledger.SupportsMempool (ApplyTxErr, GenTx, + GenTxId, Validated) +import Ouroboros.Consensus.Mempool.API (MempoolSize (..), + TraceEventMempool (..)) +import Ouroboros.Consensus.MiniProtocol.BlockFetch.Server + (TraceBlockFetchServerEvent (..)) +import Ouroboros.Consensus.MiniProtocol.ChainSync.Client +import Ouroboros.Consensus.MiniProtocol.ChainSync.Server +import Ouroboros.Consensus.MiniProtocol.LocalTxSubmission.Server + (TraceLocalTxSubmissionServerEvent (..)) +import Ouroboros.Consensus.Node.Tracers +import qualified Ouroboros.Consensus.Shelley.Protocol.HotKey as HotKey + +import Ouroboros.Network.Block +import qualified Ouroboros.Network.BlockFetch.ClientState as BlockFetch +import Ouroboros.Network.BlockFetch.Decision (FetchDecision, + FetchDecline (..)) +import Ouroboros.Network.BlockFetch.DeltaQ + (PeerFetchInFlightLimits (..), PeerGSV) +import Ouroboros.Network.KeepAlive (TraceKeepAliveClient (..)) +import Ouroboros.Network.Mux (ControlMessage) +import Ouroboros.Network.TxSubmission.Inbound +import Ouroboros.Network.TxSubmission.Outbound + +import Cardano.TraceDispatcher.Consensus.Combinators + (TraceStartLeadershipCheckPlus (..)) +import Cardano.TraceDispatcher.Era.Byron () +import Cardano.TraceDispatcher.Era.Shelley () + + + +protoHeader :: Header blk +protoHeader = undefined + +protoPoint :: Point blk +protoPoint = Point Origin + +protoPointH :: Point (Header blk) +protoPointH = Point Origin + +protoOurTipBlock :: Our (Tip blk) +protoOurTipBlock = undefined + +protoTheirTipBlock :: Their (Tip blk) +protoTheirTipBlock = undefined + +protoChainSyncClientException :: ChainSyncClientException +protoChainSyncClientException = undefined + +protoChainSyncClientResult :: ChainSyncClientResult +protoChainSyncClientResult = undefined + +protoChainUpdate :: ChainUpdate blk a +protoChainUpdate = undefined + +protoTip :: Tip blk +protoTip = undefined + +protoRemotePeer :: remotePeer +protoRemotePeer = undefined + +protoFetchDecline :: FetchDecision [Point (Header blk)] +protoFetchDecline = Left FetchDeclineChainNotPlausible + +_protoFetchResult :: FetchDecision [Point (Header blk)] +_protoFetchResult = Right [protoPointH] + +protoFetchRequest :: BlockFetch.FetchRequest (Header blk) +protoFetchRequest = undefined + +protoPeerFetchInFlight :: BlockFetch.PeerFetchInFlight (Header blk) +protoPeerFetchInFlight = undefined + +protoPeerFetchInFlightLimits :: PeerFetchInFlightLimits +protoPeerFetchInFlightLimits = PeerFetchInFlightLimits 10 10 + +protoPeerFetchStatus :: BlockFetch.PeerFetchStatus (Header blk) +protoPeerFetchStatus = undefined + +protoChainRange :: BlockFetch.ChainRange (Point header) +protoChainRange = undefined + +protoNominalDiffTime :: NominalDiffTime +protoNominalDiffTime = nominalDay + +protoDiffTime :: DiffTime +protoDiffTime = secondsToDiffTime 100 + +protoProcessedTxCount :: ProcessedTxCount +protoProcessedTxCount = ProcessedTxCount 2 1 + +protoTx :: tx +protoTx = undefined + +protoTxId :: txId +protoTxId = undefined + +protoGenTxId :: GenTxId txId +protoGenTxId = undefined + +protoControlMessage :: ControlMessage +protoControlMessage = undefined + +protoGenTx :: GenTx blk +protoGenTx = undefined + +protoValidatedGenTx :: Validated (GenTx blk) +protoValidatedGenTx = undefined + +protoMempoolSize :: MempoolSize +protoMempoolSize = undefined + +protoTxt :: Text +protoTxt = "info" + +protoSlotNo :: SlotNo +protoSlotNo = SlotNo 1 + +protoBlockNo :: BlockNo +protoBlockNo = BlockNo 2 + +protoBlk :: blk +protoBlk = undefined + +protoOutsideForecastRange :: OutsideForecastRange +protoOutsideForecastRange = undefined + +protoInvalidBlockReason :: InvalidBlockReason blk +protoInvalidBlockReason = undefined + +protoKESInfo :: HotKey.KESInfo +protoKESInfo = HotKey.KESInfo undefined undefined undefined + +protoUTCTime :: UTCTime +protoUTCTime = UTCTime (fromOrdinalDate 2021 100) protoDiffTime + +protoSystemStart :: SystemStart +protoSystemStart = SystemStart protoUTCTime + +protoPastHorizonException :: PastHorizonException +protoPastHorizonException = undefined + +protoPeerGSV :: PeerGSV +protoPeerGSV = undefined + +-- Not working because of non-injective type families +-- protoApplyTxErr :: ApplyTxErr blk +-- protoApplyTxErr = undefined + +-- protoForgeStateUpdateError :: ForgeStateUpdateError blk +-- protoForgeStateUpdateError = undefined + +-- protoCannotForge :: CannotForge blk +-- protoCannotForge = undefined + +-------------------- + +docChainSyncClientEvent :: + Documented (BlockFetch.TraceLabelPeer peer (TraceChainSyncClientEvent blk)) +docChainSyncClientEvent = Documented [ + DocMsg + (BlockFetch.TraceLabelPeer protoRemotePeer + (TraceDownloadedHeader protoHeader)) + [] + "While following a candidate chain, we rolled forward by downloading a\ + \ header." + , DocMsg + (BlockFetch.TraceLabelPeer protoRemotePeer + (TraceRolledBack protoPoint)) + [] + "While following a candidate chain, we rolled back to the given point." + , DocMsg + (BlockFetch.TraceLabelPeer protoRemotePeer + (TraceFoundIntersection protoPoint protoOurTipBlock protoTheirTipBlock)) + [] + "We found an intersection between our chain fragment and the\ + \ candidate's chain." + , DocMsg + (BlockFetch.TraceLabelPeer protoRemotePeer + (TraceException protoChainSyncClientException)) + [] + "An exception was thrown by the Chain Sync Client." + , DocMsg + (BlockFetch.TraceLabelPeer protoRemotePeer + (TraceTermination protoChainSyncClientResult)) + [] + "The client has terminated." + ] + +docChainSyncServerEvent :: Documented (TraceChainSyncServerEvent blk) +docChainSyncServerEvent = Documented [ + DocMsg + (TraceChainSyncServerRead protoTip protoChainUpdate) + [] + "A server read has occured, either for an add block or a rollback" + , DocMsg + (TraceChainSyncServerReadBlocked protoTip protoChainUpdate) + [] + "A server read has blocked, either for an add block or a rollback" + , DocMsg + (TraceChainSyncRollForward protoPoint) + [(["ChainSync","RollForward"], "TODO Doc")] + "Roll forward to the given point." + , DocMsg + (TraceChainSyncRollBackward protoPoint) + [] + "TODO Doc" + ] + +docBlockFetchDecision :: + Documented ([BlockFetch.TraceLabelPeer remotePeer (FetchDecision [Point (Header blk)])]) +docBlockFetchDecision = Documented [ + DocMsg + [BlockFetch.TraceLabelPeer protoRemotePeer protoFetchDecline] + [(["connectedPeers"], "Number of connected peers")] + "Throughout the decision making process we accumulate reasons to decline\ + \ to fetch any blocks. This message carries the intermediate and final\ + \ results." + ] + + +docBlockFetchClient :: + Documented (BlockFetch.TraceLabelPeer remotePeer (BlockFetch.TraceFetchClientState (Header blk))) +docBlockFetchClient = Documented [ + DocMsg + (BlockFetch.TraceLabelPeer protoRemotePeer + (BlockFetch.AddedFetchRequest + protoFetchRequest + protoPeerFetchInFlight + protoPeerFetchInFlightLimits + protoPeerFetchStatus)) + [] + "The block fetch decision thread has added a new fetch instruction\ + \ consisting of one or more individual request ranges." + , + DocMsg + (BlockFetch.TraceLabelPeer protoRemotePeer + (BlockFetch.AcknowledgedFetchRequest + protoFetchRequest)) + [] + "Mark the point when the fetch client picks up the request added\ + \ by the block fetch decision thread. Note that this event can happen\ + \ fewer times than the 'AddedFetchRequest' due to fetch request merging." + , + DocMsg + (BlockFetch.TraceLabelPeer protoRemotePeer + (BlockFetch.StartedFetchBatch + protoChainRange + protoPeerFetchInFlight + protoPeerFetchInFlightLimits + protoPeerFetchStatus)) + [] + "Mark the start of receiving a streaming batch of blocks. This will\ + \ be followed by one or more 'CompletedBlockFetch' and a final\ + \ 'CompletedFetchBatch'" + , + DocMsg + (BlockFetch.TraceLabelPeer protoRemotePeer + (BlockFetch.CompletedBlockFetch + protoPointH + protoPeerFetchInFlight + protoPeerFetchInFlightLimits + protoPeerFetchStatus + protoNominalDiffTime)) + [] + "Mark the completion of of receiving a single block within a\ + \ streaming batch of blocks." + , + DocMsg + (BlockFetch.TraceLabelPeer protoRemotePeer + (BlockFetch.CompletedFetchBatch + protoChainRange + protoPeerFetchInFlight + protoPeerFetchInFlightLimits + protoPeerFetchStatus)) + [] + "Mark the successful end of receiving a streaming batch of blocks." + , + DocMsg + (BlockFetch.TraceLabelPeer protoRemotePeer + (BlockFetch.RejectedFetchBatch + protoChainRange + protoPeerFetchInFlight + protoPeerFetchInFlightLimits + protoPeerFetchStatus)) + [] + "If the other peer rejects our request then we have this event\ + \ instead of 'StartedFetchBatch' and 'CompletedFetchBatch'." + , + DocMsg + (BlockFetch.TraceLabelPeer protoRemotePeer + (BlockFetch.ClientTerminating 1)) + [] + "The client is terminating. Log the number of outstanding\ + \ requests." + ] + +docBlockFetchServer :: + Documented (TraceBlockFetchServerEvent blk) +docBlockFetchServer = Documented [ + DocMsg + (TraceBlockFetchServerSendBlock protoPoint) + [(["served","block","count"], "TODO Doc")] + "The server sent a block to the peer." + ] + + +docTxInbound :: + Documented (BlockFetch.TraceLabelPeer remotePeer + (TraceTxSubmissionInbound txid tx)) +docTxInbound = Documented [ + DocMsg + (BlockFetch.TraceLabelPeer protoRemotePeer + (TraceTxSubmissionCollected 1)) + [ (["submissions", "submitted", "count"], "TODO Doc")] + "Number of transactions just about to be inserted." + , + DocMsg + (BlockFetch.TraceLabelPeer protoRemotePeer + (TraceTxSubmissionProcessed protoProcessedTxCount)) + [ (["submissions", "accepted", "count"], "TODO Doc") + , (["submissions", "rejected", "count"], "TODO Doc") + ] + "Just processed transaction pass/fail breakdown." + , + DocMsg + (BlockFetch.TraceLabelPeer protoRemotePeer + TraceTxInboundTerminated) + [] + "Server received 'MsgDone'." + , + DocMsg + (BlockFetch.TraceLabelPeer protoRemotePeer + (TraceTxInboundCanRequestMoreTxs 1)) + [] + "There are no replies in flight, but we do know some more txs we\ + \ can ask for, so lets ask for them and more txids." + , + DocMsg + (BlockFetch.TraceLabelPeer protoRemotePeer + (TraceTxInboundCannotRequestMoreTxs 1)) + [] + "There's no replies in flight, and we have no more txs we can\ + \ ask for so the only remaining thing to do is to ask for more\ + \ txids. Since this is the only thing to do now, we make this a\ + \ blocking call." + ] + +docTxOutbound :: forall remotePeer txid tx. + Documented (BlockFetch.TraceLabelPeer remotePeer + (TraceTxSubmissionOutbound txid tx)) +docTxOutbound = Documented [ + DocMsg + (BlockFetch.TraceLabelPeer protoRemotePeer + (TraceTxSubmissionOutboundRecvMsgRequestTxs [protoTxId])) + [] + "The IDs of the transactions requested." + , + DocMsg + (BlockFetch.TraceLabelPeer protoRemotePeer + (TraceTxSubmissionOutboundSendMsgReplyTxs [protoTx])) + [] + "The transactions to be sent in the response." + , + DocMsg + (BlockFetch.TraceLabelPeer protoRemotePeer + (TraceControlMessage protoControlMessage)) + [] + "TODO Doc" + ] + +docLocalTxSubmissionServer :: Documented (TraceLocalTxSubmissionServerEvent blk) +docLocalTxSubmissionServer = Documented [ + DocMsg + (TraceReceivedTx protoGenTx) + [] + "A transaction was received." + ] + +docMempool :: forall blk. Documented (TraceEventMempool blk) +docMempool = Documented [ + DocMsg + (TraceMempoolAddedTx protoValidatedGenTx protoMempoolSize protoMempoolSize) + [ (["txsInMempool"],"Transactions in mempool") + , (["mempoolBytes"], "Byte size of the mempool") + ] + "New, valid transaction that was added to the Mempool." + , DocMsg + (TraceMempoolRejectedTx protoGenTx (undefined :: ApplyTxErr blk) protoMempoolSize) + [ (["txsInMempool"],"Transactions in mempool") + , (["mempoolBytes"], "Byte size of the mempool") + ] + "New, invalid transaction thas was rejected and thus not added to\ + \ the Mempool." + , DocMsg + (TraceMempoolRemoveTxs [protoValidatedGenTx] protoMempoolSize) + [ (["txsInMempool"],"Transactions in mempool") + , (["mempoolBytes"], "Byte size of the mempool") + ] + "Previously valid transactions that are no longer valid because of\ + \ changes in the ledger state. These transactions have been removed\ + \ from the Mempool." + , DocMsg + (TraceMempoolManuallyRemovedTxs [protoGenTxId] [protoValidatedGenTx] protoMempoolSize) + [ (["txsInMempool"],"Transactions in mempool") + , (["mempoolBytes"], "Byte size of the mempool") + , (["txsProcessedNum"], "TODO Doc") + ] + "Transactions that have been manually removed from the Mempool." + ] + + +docForge :: Documented (Either (TraceLabelCreds (TraceForgeEvent blk)) + (TraceLabelCreds TraceStartLeadershipCheckPlus)) +docForge = Documented [ + DocMsg + (Left (TraceLabelCreds protoTxt + (TraceStartLeadershipCheck protoSlotNo))) + [(["aboutToLeadSlotLast"], "TODO Doc")] + "Start of the leadership check." + , DocMsg + (Left (TraceLabelCreds protoTxt + (TraceSlotIsImmutable protoSlotNo protoPoint protoBlockNo))) + [(["slotIsImmutable"], "TODO Doc")] + "Leadership check failed: the tip of the ImmutableDB inhabits the\ + \ current slot\ + \ \ + \ This might happen in two cases.\ + \ \ + \ 1. the clock moved backwards, on restart we ignored everything from the\ + \ VolatileDB since it's all in the future, and now the tip of the\ + \ ImmutableDB points to a block produced in the same slot we're trying\ + \ to produce a block in\ + \ \ + \ 2. k = 0 and we already adopted a block from another leader of the same\ + \ slot.\ + \ \ + \ We record both the current slot number as well as the tip of the\ + \ ImmutableDB.\ + \ \ + \ See also " + , DocMsg + (Left (TraceLabelCreds protoTxt + (TraceBlockFromFuture protoSlotNo protoSlotNo))) + [(["blockFromFuture"], "TODO Doc")] + "Leadership check failed: the current chain contains a block from a slot\ + \ /after/ the current slot\ + \ \ + \ This can only happen if the system is under heavy load.\ + \ \ + \ We record both the current slot number as well as the slot number of the\ + \ block at the tip of the chain.\ + \ \ + \ See also " + , DocMsg + (Left (TraceLabelCreds protoTxt + (TraceBlockContext protoSlotNo protoBlockNo protoPoint))) + [(["blockContext"], "TODO Doc")] + "We found out to which block we are going to connect the block we are about\ + \ to forge.\ + \ \ + \ We record the current slot number, the block number of the block to\ + \ connect to and its point.\ + \ \ + \ Note that block number of the block we will try to forge is one more than\ + \ the recorded block number." + , DocMsg + (Left (TraceLabelCreds protoTxt + (TraceNoLedgerState protoSlotNo protoPoint))) + [(["couldNotForgeSlotLast"], "TODO Doc")] + "Leadership check failed: we were unable to get the ledger state for the\ + \ point of the block we want to connect to\ + \ \ + \ This can happen if after choosing which block to connect to the node\ + \ switched to a different fork. We expect this to happen only rather\ + \ rarely, so this certainly merits a warning; if it happens a lot, that\ + \ merits an investigation.\ + \ \ + \ We record both the current slot number as well as the point of the block\ + \ we attempt to connect the new block to (that we requested the ledger\ + \ state for)." + , DocMsg + (Left (TraceLabelCreds protoTxt + (TraceLedgerState protoSlotNo protoPoint))) + [(["ledgerState"], "TODO Doc")] + "We obtained a ledger state for the point of the block we want to\ + \ connect to\ + \ \ + \ We record both the current slot number as well as the point of the block\ + \ we attempt to connect the new block to (that we requested the ledger\ + \ state for)." + , DocMsg + (Left (TraceLabelCreds protoTxt + (TraceNoLedgerView protoSlotNo protoOutsideForecastRange))) + [(["couldNotForgeSlotLast"], "TODO Doc")] + "Leadership check failed: we were unable to get the ledger view for the\ + \ current slot number\ + \ \ + \ This will only happen if there are many missing blocks between the tip of\ + \ our chain and the current slot.\ + \ \ + \ We record also the failure returned by 'forecastFor'." + , DocMsg + (Left (TraceLabelCreds protoTxt + (TraceLedgerView protoSlotNo))) + [(["ledgerView"], "TODO Doc")] + "We obtained a ledger view for the current slot number\ + \ \ + \ We record the current slot number." + , DocMsg + (Left (TraceLabelCreds protoTxt + (TraceForgeStateUpdateError protoSlotNo undefined))) + [ (["operationalCertificateStartKESPeriod"], "TODO Doc") + , (["operationalCertificateExpiryKESPeriod"], "TODO Doc") + , (["currentKESPeriod"], "TODO Doc") + , (["remainingKESPeriods"], "TODO Doc") + ] + "Updating the forge state failed.\ + \ \ + \ For example, the KES key could not be evolved anymore.\ + \ \ + \ We record the error returned by 'updateForgeState'." + , DocMsg + (Left (TraceLabelCreds protoTxt + (TraceNodeCannotForge protoSlotNo undefined))) + [(["nodeCannotForge"], "TODO Doc")] + "We did the leadership check and concluded that we should lead and forge\ + \ a block, but cannot.\ + \ \ + \ This should only happen rarely and should be logged with warning severity.\ + \ \ + \ Records why we cannot forge a block." + , DocMsg + (Left (TraceLabelCreds protoTxt + (TraceNodeNotLeader protoSlotNo))) + [(["nodeNotLeader"], "TODO Doc")] + "We did the leadership check and concluded we are not the leader\ + \ \ + \ We record the current slot number" + , DocMsg + (Left (TraceLabelCreds protoTxt + (TraceNodeIsLeader protoSlotNo))) + [(["nodeIsLeader"], "TODO Doc")] + "We did the leadership check and concluded we /are/ the leader\ + \ \ + \ The node will soon forge; it is about to read its transactions from the\ + \ Mempool. This will be followed by TraceForgedBlock." + , DocMsg + (Left (TraceLabelCreds protoTxt + (TraceForgedBlock protoSlotNo protoPoint protoBlk protoMempoolSize))) + [(["forgedSlotLast"], "TODO Doc")] + "We forged a block\ + \ \ + \ We record the current slot number, the point of the predecessor, the block\ + \ itself, and the total size of the mempool snapshot at the time we produced\ + \ the block (which may be significantly larger than the block, due to\ + \ maximum block size)\ + \ \ + \ This will be followed by one of three messages:\ + \ \ + \ * TraceAdoptedBlock (normally)\ + \ * TraceDidntAdoptBlock (rarely)\ + \ * TraceForgedInvalidBlock (hopefully never -- this would indicate a bug)" + , DocMsg + (Left (TraceLabelCreds protoTxt + (TraceDidntAdoptBlock protoSlotNo protoBlk))) + [(["notAdoptedSlotLast"], "TODO Doc")] + "We did not adopt the block we produced, but the block was valid. We\ + \ must have adopted a block that another leader of the same slot produced\ + \ before we got the chance of adopting our own block. This is very rare,\ + \ this warrants a warning." + , DocMsg + (Left (TraceLabelCreds protoTxt + (TraceForgedInvalidBlock protoSlotNo protoBlk protoInvalidBlockReason))) + [(["forgedInvalidSlotLast"], "TODO Doc")] + "We forged a block that is invalid according to the ledger in the\ + \ ChainDB. This means there is an inconsistency between the mempool\ + \ validation and the ledger validation. This is a serious error!" + , DocMsg + (Left (TraceLabelCreds protoTxt + (TraceAdoptedBlock protoSlotNo protoBlk [protoValidatedGenTx]))) + [(["adoptedSlotLast"], "TODO Doc")] + "We adopted the block we produced, we also trace the transactions\ + \ that were adopted." + , DocMsg + (Right (TraceLabelCreds protoTxt + (TraceStartLeadershipCheckPlus protoSlotNo 0 0 0.0))) + [ (["aboutToLeadSlotLast"], "TODO Doc") + , (["utxoSize"], "TODO Doc") + , (["delegMapSize"], "TODO Doc") + ] + "We adopted the block we produced, we also trace the transactions\ + \ that were adopted." + + ] + +docForgeStateInfo :: Documented (TraceLabelCreds (HotKey.KESInfo)) +docForgeStateInfo = Documented [ + DocMsg + (TraceLabelCreds protoTxt protoKESInfo) + [] + "kesStartPeriod \ + \\nkesEndPeriod is kesStartPeriod + tpraosMaxKESEvo\ + \\nkesEvolution is the current evolution or /relative period/." + ] + +docBlockchainTime :: Documented (TraceBlockchainTimeEvent t) +docBlockchainTime = Documented [ + DocMsg + (TraceStartTimeInTheFuture protoSystemStart protoNominalDiffTime) + [] + "The start time of the blockchain time is in the future\ + \\ + \ We have to block (for 'NominalDiffTime') until that time comes." + , DocMsg + (TraceCurrentSlotUnknown (undefined :: t) protoPastHorizonException) + [] + "Current slot is not yet known\ + \\ + \ This happens when the tip of our current chain is so far in the past that\ + \ we cannot translate the current wallclock to a slot number, typically\ + \ during syncing. Until the current slot number is known, we cannot\ + \ produce blocks. Seeing this message during syncing therefore is\ + \ normal and to be expected.\ + \\ + \ We record the current time (the time we tried to translate to a 'SlotNo')\ + \ as well as the 'PastHorizonException', which provides detail on the\ + \ bounds between which we /can/ do conversions. The distance between the\ + \ current time and the upper bound should rapidly decrease with consecutive\ + \ 'TraceCurrentSlotUnknown' messages during syncing." + , DocMsg + (TraceSystemClockMovedBack (undefined :: t) (undefined :: t)) + [] + "The system clock moved back an acceptable time span, e.g., because of\ + \ an NTP sync.\ + \\ + \ The system clock moved back such that the new current slot would be\ + \ smaller than the previous one. If this is within the configured limit, we\ + \ trace this warning but *do not change the current slot*. The current slot\ + \ never decreases, but the current slot may stay the same longer than\ + \ expected.\ + \\ + \ When the system clock moved back more than the configured limit, we shut\ + \ down with a fatal exception." + ] + +docKeepAliveClient :: Documented (TraceKeepAliveClient peer) +docKeepAliveClient = Documented [ + DocMsg + (AddSample (undefined :: peer) protoDiffTime protoPeerGSV) + [] + "TODO Doc" + ] diff --git a/cardano-node/src/Cardano/TraceDispatcher/Consensus/ForgingThreadStats.hs b/cardano-node/src/Cardano/TraceDispatcher/Consensus/ForgingThreadStats.hs new file mode 100644 index 00000000000..f8532544312 --- /dev/null +++ b/cardano-node/src/Cardano/TraceDispatcher/Consensus/ForgingThreadStats.hs @@ -0,0 +1,185 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +module Cardano.TraceDispatcher.Consensus.ForgingThreadStats + ( ForgingStats (..) + , ForgeThreadStats (..) + , forgeThreadStats + , docForgeStats + ) where + +import Cardano.Logging +import Cardano.Prelude hiding ((:.:), All, concat) +import Data.Aeson (Value (..), (.=)) + +import qualified Data.Map.Strict as Map + +import Cardano.Slotting.Slot (SlotNo (..)) +import Cardano.TraceDispatcher.Consensus.StartLeadershipCheck + (ForgeTracerType) +import Cardano.TraceDispatcher.Render (showT) +import Ouroboros.Consensus.Node.Tracers +import Ouroboros.Consensus.Shelley.Node () + + +-- | Per-forging-thread statistics. +data ForgeThreadStats = ForgeThreadStats + { ftsNodeCannotForgeNum :: !Int + , ftsNodeIsLeaderNum :: !Int + , ftsBlocksForgedNum :: !Int + , ftsSlotsMissedNum :: !Int + -- ^ Potentially missed slots. Note that this is not the same as the number + -- of missed blocks, since this includes all occurences of not reaching a + -- leadership check decision, whether or not leadership was possible or not. + -- + -- Also note that when the aggregate total for this metric is reported in the + -- multi-pool case, it can be much larger than the actual number of slots + -- occuring since node start, for it is a sum total for all threads. + , ftsLastSlot :: !Int + } + +instance LogFormatting ForgeThreadStats where + forHuman ForgeThreadStats {..} = + "Node cannot forge " <> showT ftsNodeCannotForgeNum + <> " node is leader " <> showT ftsNodeIsLeaderNum + <> " blocks forged " <> showT ftsBlocksForgedNum + <> " slots missed " <> showT ftsSlotsMissedNum + <> " last slot " <> showT ftsLastSlot + forMachine _dtal ForgeThreadStats {..} = + mkObject [ "kind" .= String "ForgeThreadStats" + , "nodeCannotForgeNum" .= String (show ftsNodeCannotForgeNum) + , "nodeIsLeaderNum" .= String (show ftsNodeIsLeaderNum) + , "blocksForgedNum" .= String (show ftsBlocksForgedNum) + , "slotsMissed" .= String (show ftsSlotsMissedNum) + , "lastSlot" .= String (show ftsLastSlot) + ] + asMetrics ForgeThreadStats {..} = + [ IntM ["nodeCannotForgeNum"] (fromIntegral ftsNodeCannotForgeNum) + , IntM ["nodeIsLeaderNum"] (fromIntegral ftsNodeIsLeaderNum) + , IntM ["blocksForgedNum"] (fromIntegral ftsBlocksForgedNum) + , IntM ["slotsMissed"] (fromIntegral ftsSlotsMissedNum) + , IntM ["lastSlot"] (fromIntegral ftsLastSlot) + ] + + +emptyForgeThreadStats :: ForgeThreadStats +emptyForgeThreadStats = ForgeThreadStats 0 0 0 0 0 + +-- | This structure stores counters of blockchain-related events, +-- per individual thread in fsStats. +data ForgingStats + = ForgingStats + { fsStats :: !(Map ThreadId ForgeThreadStats) + , fsNodeCannotForgeNum :: !Int + , fsNodeIsLeaderNum :: !Int + , fsBlocksForgedNum :: !Int + , fsSlotsMissedNum :: !Int + } + +instance LogFormatting ForgingStats where + forHuman ForgingStats {..} = + "Node cannot forge " <> showT fsNodeCannotForgeNum + <> " node is leader " <> showT fsNodeIsLeaderNum + <> " blocks forged " <> showT fsBlocksForgedNum + <> " slots missed " <> showT fsSlotsMissedNum + forMachine _dtal ForgingStats {..} = + mkObject [ "kind" .= String "ForgingStats" + , "nodeCannotForgeNum" .= String (show fsNodeCannotForgeNum) + , "nodeIsLeaderNum" .= String (show fsNodeIsLeaderNum) + , "blocksForgedNum" .= String (show fsBlocksForgedNum) + , "slotsMissed" .= String (show fsSlotsMissedNum) + ] + asMetrics ForgingStats {..} = + [ IntM ["nodeCannotForgeNum"] (fromIntegral fsNodeCannotForgeNum) + , IntM ["nodeIsLeaderNum"] (fromIntegral fsNodeIsLeaderNum) + , IntM ["blocksForgedNum"] (fromIntegral fsBlocksForgedNum) + , IntM ["slotsMissed"] (fromIntegral fsSlotsMissedNum) + ] + +emptyForgingStats :: ForgingStats +emptyForgingStats = ForgingStats mempty 0 0 0 0 + +forgeThreadStats :: Trace IO (Folding (ForgeTracerType blk) ForgingStats) + -> IO (Trace IO (ForgeTracerType blk)) +forgeThreadStats = foldMTraceM calculateThreadStats emptyForgingStats + +calculateThreadStats :: MonadIO m + => ForgingStats + -> LoggingContext + -> ForgeTracerType blk + -> m ForgingStats +calculateThreadStats stats _context + (Left (TraceLabelCreds _ (TraceNodeCannotForge {}))) = do + mapThreadStats + stats + (\fts -> (fts { ftsNodeCannotForgeNum = ftsNodeCannotForgeNum fts + 1} + , Nothing)) + (\fs _ -> (fs { fsNodeCannotForgeNum = fsNodeCannotForgeNum fs + 1 })) +calculateThreadStats stats _context + (Left (TraceLabelCreds _ (TraceNodeIsLeader (SlotNo slot')))) = do + let slot = fromIntegral slot' + mapThreadStats + stats + (\fts -> (fts { ftsNodeIsLeaderNum = ftsNodeIsLeaderNum fts + 1 + , ftsLastSlot = slot}, Nothing)) + (\fs _ -> (fs { fsNodeIsLeaderNum = fsNodeIsLeaderNum fs + 1 })) +calculateThreadStats stats _context + (Left (TraceLabelCreds _ (TraceForgedBlock {}))) = do + mapThreadStats + stats + (\fts -> (fts { ftsBlocksForgedNum = ftsBlocksForgedNum fts + 1} + , Nothing)) + (\fs _ -> (fs { fsBlocksForgedNum = fsBlocksForgedNum fs + 1 })) +calculateThreadStats stats _context + (Left (TraceLabelCreds _ (TraceNodeNotLeader (SlotNo slot')))) = do + let slot = fromIntegral slot' + mapThreadStats + stats + (\fts -> + if ftsLastSlot fts == 0 || succ (ftsLastSlot fts) == slot + then (fts { ftsLastSlot = slot }, Nothing) + else + let missed = (slot - ftsLastSlot fts) + in (fts { ftsLastSlot = slot + , ftsSlotsMissedNum = ftsSlotsMissedNum fts + missed} + , Just missed)) + (\fs mbMissed -> case mbMissed of + Nothing -> fs + Just missed -> (fs { fsSlotsMissedNum = + fsSlotsMissedNum fs + missed})) +calculateThreadStats stats _context _message = pure stats + +mapThreadStats :: + MonadIO m + => ForgingStats + -> (ForgeThreadStats -> (ForgeThreadStats, Maybe a)) + -> (ForgingStats -> Maybe a -> ForgingStats) + -> m ForgingStats +mapThreadStats fs@ForgingStats { fsStats } f1 f2 = do + tid <- liftIO $ myThreadId + let threadStats = case Map.lookup tid fsStats of + Nothing -> emptyForgeThreadStats + Just vs -> vs + (newStats, w) = f1 threadStats + pure $ f2 (fs {fsStats = Map.insert tid newStats fsStats}) w + +docForgeStats :: Documented ForgeThreadStats +docForgeStats = Documented [ + DocMsg + emptyForgeThreadStats + [(["nodeCannotForgeNum"], + "How many times this node could not forge?") + ,(["nodeIsLeaderNum"], + "How many times this node was leader?") + ,(["blocksForgedNum"], + "How many blocks did forge in this node?") + ,(["slotsMissed"], + "How many slots were missed in this node?") + ] + "nodeCannotForgeNum shows how many times this node could not forge.\ + \\nnodeIsLeaderNum shows how many times this node was leader.\ + \\nblocksForgedNum shows how many blocks did forge in this node.\ + \\nslotsMissed shows how many slots were missed in this node." + ] diff --git a/cardano-node/src/Cardano/TraceDispatcher/Consensus/Formatting.hs b/cardano-node/src/Cardano/TraceDispatcher/Consensus/Formatting.hs new file mode 100644 index 00000000000..c8187cc5b40 --- /dev/null +++ b/cardano-node/src/Cardano/TraceDispatcher/Consensus/Formatting.hs @@ -0,0 +1,708 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + + +{-# OPTIONS_GHC -Wno-orphans #-} + +module Cardano.TraceDispatcher.Consensus.Formatting + ( + HasKESInfoX(..) + , GetKESInfoX(..) + ) where + +import Control.Monad.Class.MonadTime (Time (..)) +import Data.Aeson (ToJSON, Value (Number, String), toJSON, (.=)) +import Data.SOP.Strict +import qualified Data.Text as Text +import Data.Time (DiffTime) +import Text.Show + +import Cardano.Logging +import Cardano.Prelude hiding (All, Show, show) +import Cardano.TraceDispatcher.Consensus.Combinators (ForgeTracerType, + TraceStartLeadershipCheckPlus (..)) +import Cardano.TraceDispatcher.Era.Byron () +import Cardano.TraceDispatcher.Era.Shelley () +import Cardano.TraceDispatcher.Formatting () +import Cardano.TraceDispatcher.Render + +import Ouroboros.Consensus.Block.Forging +import Ouroboros.Consensus.Byron.Ledger.Block (ByronBlock) +import Ouroboros.Consensus.HardFork.Combinator + (HardForkForgeStateInfo (..)) +import Ouroboros.Consensus.HardFork.Combinator.AcrossEras + (OneEraForgeStateInfo (..), + OneEraForgeStateUpdateError (..)) +import Ouroboros.Consensus.Shelley.Ledger.Block (ShelleyBlock) +import qualified Ouroboros.Consensus.Shelley.Protocol.HotKey as HotKey +import Ouroboros.Consensus.TypeFamilyWrappers + (WrapForgeStateInfo (..), WrapForgeStateUpdateError (..)) + +import Ouroboros.Consensus.Block +import Ouroboros.Consensus.BlockchainTime (SystemStart (..)) +import Ouroboros.Consensus.BlockchainTime.WallClock.Util + (TraceBlockchainTimeEvent (..)) +import Ouroboros.Consensus.Cardano.Block +import Ouroboros.Consensus.Ledger.Inspect (LedgerEvent (..), + LedgerUpdate, LedgerWarning) +import Ouroboros.Consensus.Ledger.SupportsMempool (ApplyTxErr, + GenTxId, LedgerSupportsMempool, txForgetValidated) +import Ouroboros.Consensus.Ledger.SupportsProtocol +import Ouroboros.Consensus.Mempool.API (MempoolSize (..), + TraceEventMempool (..)) +import Ouroboros.Consensus.MiniProtocol.BlockFetch.Server + (TraceBlockFetchServerEvent (..)) +import Ouroboros.Consensus.MiniProtocol.ChainSync.Client +import Ouroboros.Consensus.MiniProtocol.ChainSync.Server +import Ouroboros.Consensus.MiniProtocol.LocalTxSubmission.Server + (TraceLocalTxSubmissionServerEvent (..)) +import Ouroboros.Consensus.Node.Run (SerialiseNodeToNodeConstraints, + estimateBlockSize) +import Ouroboros.Consensus.Node.Tracers + +import Ouroboros.Network.Block +import Ouroboros.Network.BlockFetch.ClientState (TraceLabelPeer (..)) +import qualified Ouroboros.Network.BlockFetch.ClientState as BlockFetch +import Ouroboros.Network.BlockFetch.Decision +import Ouroboros.Network.DeltaQ (GSV (..), PeerGSV (..)) +import Ouroboros.Network.KeepAlive (TraceKeepAliveClient (..)) +import Ouroboros.Network.TxSubmission.Inbound +import Ouroboros.Network.TxSubmission.Outbound + +import Shelley.Spec.Ledger.OCert (KESPeriod (..)) + + +class HasKESInfoX blk where + getKESInfoX :: Proxy blk -> ForgeStateUpdateError blk -> Maybe HotKey.KESInfo + getKESInfoX _ _ = Nothing + +instance HasKESInfoX (ShelleyBlock era) where + getKESInfoX _ (HotKey.KESCouldNotEvolve ki _) = Just ki + getKESInfoX _ (HotKey.KESKeyAlreadyPoisoned ki _) = Just ki + +instance HasKESInfoX ByronBlock + +instance All HasKESInfoX xs => HasKESInfoX (HardForkBlock xs) where + getKESInfoX _ = + hcollapse + . hcmap (Proxy @HasKESInfoX) getOne + . getOneEraForgeStateUpdateError + where + getOne :: forall blk. HasKESInfoX blk + => WrapForgeStateUpdateError blk + -> K (Maybe HotKey.KESInfo) blk + getOne = K . getKESInfoX (Proxy @blk) . unwrapForgeStateUpdateError + + +class GetKESInfoX blk where + getKESInfoFromStateInfoX :: Proxy blk -> ForgeStateInfo blk -> Maybe HotKey.KESInfo + getKESInfoFromStateInfoX _ _ = Nothing + +instance GetKESInfoX (ShelleyBlock era) where + getKESInfoFromStateInfoX _ fsi = Just fsi + +instance GetKESInfoX ByronBlock + +instance All GetKESInfoX xs => GetKESInfoX (HardForkBlock xs) where + getKESInfoFromStateInfoX _ forgeStateInfo = + case forgeStateInfo of + CurrentEraLacksBlockForging _ -> Nothing + CurrentEraForgeStateUpdated currentEraForgeStateInfo -> + hcollapse + . hcmap (Proxy @GetKESInfoX) getOne + . getOneEraForgeStateInfo + $ currentEraForgeStateInfo + where + getOne :: forall blk. GetKESInfoX blk + => WrapForgeStateInfo blk + -> K (Maybe HotKey.KESInfo) blk + getOne = K . getKESInfoFromStateInfoX (Proxy @blk) . unwrapForgeStateInfo + +instance LogFormatting a => LogFormatting (TraceLabelCreds a) where + forMachine dtal (TraceLabelCreds creds a) = + mkObject [ "credentials" .= toJSON creds + , "val" .= forMachine dtal a + ] +-- TODO Trace lable creds as well + forHuman (TraceLabelCreds _t a) = forHuman a + asMetrics (TraceLabelCreds _t a) = asMetrics a + + +instance (LogFormatting (LedgerUpdate blk), LogFormatting (LedgerWarning blk)) + => LogFormatting (LedgerEvent blk) where + forMachine dtal = \case + LedgerUpdate update -> forMachine dtal update + LedgerWarning warning -> forMachine dtal warning + +instance (Show (Header blk), ConvertRawHash blk, LedgerSupportsProtocol blk) + => LogFormatting (TraceChainSyncClientEvent blk) where + forHuman (TraceDownloadedHeader pt) = + "While following a candidate chain, we rolled forward by downloading a\ + \ header. " <> showT (headerPoint pt) + forHuman (TraceRolledBack tip) = + "While following a candidate chain, we rolled back to the given point: " + <> showT tip + forHuman (TraceException exc) = + "An exception was thrown by the Chain Sync Client. " + <> showT exc + forHuman (TraceFoundIntersection _ _ _) = + "We found an intersection between our chain fragment and the\ + \ candidate's chain." + forHuman (TraceTermination res) = + "The client has terminated. " <> showT res + + forMachine dtal (TraceDownloadedHeader pt) = + mkObject [ "kind" .= String "DownloadedHeader" + , "block" .= forMachine dtal (headerPoint pt) ] + forMachine dtal (TraceRolledBack tip) = + mkObject [ "kind" .= String "RolledBack" + , "tip" .= forMachine dtal tip ] + forMachine _dtal (TraceException exc) = + mkObject [ "kind" .= String "Exception" + , "exception" .= String (Text.pack $ show exc) ] + forMachine _dtal (TraceFoundIntersection _ _ _) = + mkObject [ "kind" .= String "FoundIntersection" ] + forMachine _dtal (TraceTermination _) = + mkObject [ "kind" .= String "Termination" ] + + +instance ConvertRawHash blk + => LogFormatting (TraceChainSyncServerEvent blk) where + forMachine dtal (TraceChainSyncServerRead tip (AddBlock hdr)) = + mkObject [ "kind" .= String "ChainSyncServerRead.AddBlock" + , "tip" .= String (renderTipForDetails dtal tip) + , "addedBlock" .= String (renderPointForDetails dtal hdr) + ] + forMachine dtal (TraceChainSyncServerRead tip (RollBack pt)) = + mkObject [ "kind" .= String "ChainSyncServerRead.RollBack" + , "tip" .= String (renderTipForDetails dtal tip) + , "rolledBackBlock" .= String (renderPointForDetails dtal pt) + ] + forMachine dtal (TraceChainSyncServerReadBlocked tip (AddBlock hdr)) = + mkObject [ "kind" .= String "ChainSyncServerReadBlocked.RollForward" + , "tip" .= String (renderTipForDetails dtal tip) + , "addedBlock" .= String (renderPointForDetails dtal hdr) + ] + forMachine dtal (TraceChainSyncServerReadBlocked tip (RollBack pt)) = + mkObject [ "kind" .= String "ChainSyncServerReadBlocked.RollBack" + , "tip" .= String (renderTipForDetails dtal tip) + , "rolledBackBlock" .= String (renderPointForDetails dtal pt) + ] + forMachine dtal (TraceChainSyncRollForward point) = + mkObject [ "kind" .= String "ChainSyncRollForward" + , "point" .= forMachine dtal point + ] + forMachine dtal (TraceChainSyncRollBackward point) = + mkObject [ "kind" .= String "ChainSyncRollBackward" + , "point" .= forMachine dtal point + ] + + asMetrics (TraceChainSyncRollForward _point) = + [CounterM ["ChainSync","RollForward"] Nothing] + asMetrics _ = [] + + +instance (LogFormatting peer, Show peer) + => LogFormatting [TraceLabelPeer peer (FetchDecision [Point header])] where + forMachine DMinimal _ = emptyObject + forMachine _ [] = emptyObject + forMachine _ xs = mkObject + [ "kind" .= String "PeersFetch" + , "peers" .= toJSON + (foldl' (\acc x -> forMachine DDetailed x : acc) [] xs) ] + + asMetrics peers = [IntM ["connectedPeers"] (fromIntegral (length peers))] + + +instance (LogFormatting peer, Show peer, LogFormatting a) + => LogFormatting (TraceLabelPeer peer a) where + forMachine dtal (TraceLabelPeer peerid a) = + mkObject [ "peer" .= forMachine dtal peerid ] <> forMachine dtal a + forHuman (TraceLabelPeer peerid a) = "Peer is " <> showT peerid + <> ". " <> forHuman a + asMetrics (TraceLabelPeer _peerid a) = asMetrics a + +instance LogFormatting (FetchDecision [Point header]) where + forMachine _dtal (Left decline) = + mkObject [ "kind" .= String "FetchDecision declined" + , "declined" .= String (showT decline) + ] + forMachine _dtal (Right results) = + mkObject [ "kind" .= String "FetchDecision results" + , "length" .= String (showT $ length results) + ] + +instance LogFormatting (BlockFetch.TraceFetchClientState header) where + forMachine _dtal BlockFetch.AddedFetchRequest {} = + mkObject [ "kind" .= String "AddedFetchRequest" ] + forMachine _dtal BlockFetch.AcknowledgedFetchRequest {} = + mkObject [ "kind" .= String "AcknowledgedFetchRequest" ] + forMachine _dtal BlockFetch.SendFetchRequest {} = + mkObject [ "kind" .= String "SendFetchRequest" ] + forMachine _dtal BlockFetch.CompletedBlockFetch {} = + mkObject [ "kind" .= String "CompletedBlockFetch" ] + forMachine _dtal BlockFetch.CompletedFetchBatch {} = + mkObject [ "kind" .= String "CompletedFetchBatch" ] + forMachine _dtal BlockFetch.StartedFetchBatch {} = + mkObject [ "kind" .= String "StartedFetchBatch" ] + forMachine _dtal BlockFetch.RejectedFetchBatch {} = + mkObject [ "kind" .= String "RejectedFetchBatch" ] + forMachine _dtal BlockFetch.ClientTerminating {} = + mkObject [ "kind" .= String "ClientTerminating" ] + +instance LogFormatting (TraceBlockFetchServerEvent blk) where + forMachine _dtal (TraceBlockFetchServerSendBlock _p) = + mkObject [ "kind" .= String "BlockFetchServer" ] + + asMetrics (TraceBlockFetchServerSendBlock _p) = + [CounterM ["served","block","count"] Nothing] + +instance LogFormatting (TraceTxSubmissionInbound txid tx) where + forMachine _dtal (TraceTxSubmissionCollected count) = + mkObject + [ "kind" .= String "TraceTxSubmissionCollected" + , "count" .= toJSON count + ] + forMachine _dtal (TraceTxSubmissionProcessed processed) = + mkObject + [ "kind" .= String "TraceTxSubmissionProcessed" + , "accepted" .= toJSON (ptxcAccepted processed) + , "rejected" .= toJSON (ptxcRejected processed) + ] + forMachine _dtal TraceTxInboundTerminated = + mkObject + [ "kind" .= String "TraceTxInboundTerminated" + ] + forMachine _dtal (TraceTxInboundCanRequestMoreTxs count) = + mkObject + [ "kind" .= String "TraceTxInboundCanRequestMoreTxs" + , "count" .= toJSON count + ] + forMachine _dtal (TraceTxInboundCannotRequestMoreTxs count) = + mkObject + [ "kind" .= String "TraceTxInboundCannotRequestMoreTxs" + , "count" .= toJSON count + ] + + asMetrics (TraceTxSubmissionCollected count)= + [CounterM ["submissions", "submitted", "count"] (Just count)] + asMetrics (TraceTxSubmissionProcessed processed) = + [ CounterM ["submissions", "accepted", "count"] + (Just (ptxcAccepted processed)) + , CounterM ["submissions", "rejected", "count"] + (Just (ptxcRejected processed)) + ] + asMetrics _ = [] + +instance (Show txid, Show tx) + => LogFormatting (TraceTxSubmissionOutbound txid tx) where + forMachine DDetailed (TraceTxSubmissionOutboundRecvMsgRequestTxs txids) = + mkObject + [ "kind" .= String "TraceTxSubmissionOutboundRecvMsgRequestTxs" + , "txIds" .= String (Text.pack $ show txids) + ] + forMachine _dtal (TraceTxSubmissionOutboundRecvMsgRequestTxs _txids) = + mkObject + [ "kind" .= String "TraceTxSubmissionOutboundRecvMsgRequestTxs" + ] + forMachine DDetailed (TraceTxSubmissionOutboundSendMsgReplyTxs txs) = + mkObject + [ "kind" .= String "TraceTxSubmissionOutboundSendMsgReplyTxs" + , "txs" .= String (Text.pack $ show txs) + ] + forMachine _dtal (TraceTxSubmissionOutboundSendMsgReplyTxs _txs) = + mkObject + [ "kind" .= String "TraceTxSubmissionOutboundSendMsgReplyTxs" + ] + forMachine _dtal (TraceControlMessage _msg) = + mkObject + [ "kind" .= String "TraceControlMessage" + ] + +instance LogFormatting (TraceLocalTxSubmissionServerEvent blk) where + forMachine _dtal (TraceReceivedTx _gtx) = + mkObject [ "kind" .= String "ReceivedTx" ] + +instance + ( Show (ApplyTxErr blk) + , LogFormatting (ApplyTxErr blk) + , LogFormatting (GenTx blk) + , ToJSON (GenTxId blk) + , LedgerSupportsMempool blk + ) => LogFormatting (TraceEventMempool blk) where + forMachine dtal (TraceMempoolAddedTx tx _mpSzBefore mpSzAfter) = + mkObject + [ "kind" .= String "TraceMempoolAddedTx" + , "tx" .= forMachine dtal (txForgetValidated tx) + , "mempoolSize" .= forMachine dtal mpSzAfter + ] + forMachine dtal (TraceMempoolRejectedTx tx txApplyErr mpSz) = + mkObject + [ "kind" .= String "TraceMempoolRejectedTx" + , "err" .= forMachine dtal txApplyErr + , "tx" .= forMachine dtal tx + , "mempoolSize" .= forMachine dtal mpSz + ] + forMachine dtal (TraceMempoolRemoveTxs txs mpSz) = + mkObject + [ "kind" .= String "TraceMempoolRemoveTxs" + , "txs" .= map (forMachine dtal . txForgetValidated) txs + , "mempoolSize" .= forMachine dtal mpSz + ] + forMachine dtal (TraceMempoolManuallyRemovedTxs txs0 txs1 mpSz) = + mkObject + [ "kind" .= String "TraceMempoolManuallyRemovedTxs" + , "txsRemoved" .= txs0 + , "txsInvalidated" .= map (forMachine dtal . txForgetValidated) txs1 + , "mempoolSize" .= forMachine dtal mpSz + ] + + asMetrics (TraceMempoolAddedTx _tx _mpSzBefore mpSz) = + [ IntM ["txsInMempool"] (fromIntegral $ msNumTxs mpSz) + , IntM ["mempoolBytes"] (fromIntegral $ msNumBytes mpSz) + ] + asMetrics (TraceMempoolRejectedTx _tx _txApplyErr mpSz) = + [ IntM ["txsInMempool"] (fromIntegral $ msNumTxs mpSz) + , IntM ["mempoolBytes"] (fromIntegral $ msNumBytes mpSz) + ] + asMetrics (TraceMempoolRemoveTxs _txs mpSz) = + [ IntM ["txsInMempool"] (fromIntegral $ msNumTxs mpSz) + , IntM ["mempoolBytes"] (fromIntegral $ msNumBytes mpSz) + ] + asMetrics (TraceMempoolManuallyRemovedTxs [] _txs1 mpSz) = + [ IntM ["txsInMempool"] (fromIntegral $ msNumTxs mpSz) + , IntM ["mempoolBytes"] (fromIntegral $ msNumBytes mpSz) + ] + asMetrics (TraceMempoolManuallyRemovedTxs txs _txs1 mpSz) = + [ IntM ["txsInMempool"] (fromIntegral $ msNumTxs mpSz) + , IntM ["mempoolBytes"] (fromIntegral $ msNumBytes mpSz) + , CounterM ["txsProcessedNum"] (Just (fromIntegral $ length txs)) + ] + +instance LogFormatting MempoolSize where + forMachine _dtal MempoolSize{msNumTxs, msNumBytes} = + mkObject + [ "numTxs" .= msNumTxs + , "bytes" .= msNumBytes + ] + +instance ( tx ~ GenTx blk + , ConvertRawHash blk + , GetHeader blk + , HasHeader blk + , HasKESInfoX blk + , LedgerSupportsProtocol blk + , SerialiseNodeToNodeConstraints blk + , Show (ForgeStateUpdateError blk) + , Show (CannotForge blk) + , LogFormatting (InvalidBlockReason blk) + , LogFormatting (CannotForge blk) + , LogFormatting (ForgeStateUpdateError blk)) + => LogFormatting (ForgeTracerType blk) where + forMachine dtal (Left i) = forMachine dtal i + forMachine dtal (Right i) = forMachine dtal i + forHuman (Left i) = forHuman i + forHuman (Right i) = forHuman i + asMetrics (Left i) = asMetrics i + asMetrics (Right i) = asMetrics i + +instance ( tx ~ GenTx blk + , ConvertRawHash blk + , GetHeader blk + , HasHeader blk + , HasKESInfoX blk + , LedgerSupportsProtocol blk + , SerialiseNodeToNodeConstraints blk + , Show (ForgeStateUpdateError blk) + , Show (CannotForge blk) + , LogFormatting (InvalidBlockReason blk) + , LogFormatting (CannotForge blk) + , LogFormatting (ForgeStateUpdateError blk)) + => LogFormatting (TraceForgeEvent blk) where + forMachine _dtal (TraceStartLeadershipCheck slotNo) = + mkObject + [ "kind" .= String "TraceStartLeadershipCheck" + , "slot" .= toJSON (unSlotNo slotNo) + ] + forMachine dtal (TraceSlotIsImmutable slotNo tipPoint tipBlkNo) = + mkObject + [ "kind" .= String "TraceSlotIsImmutable" + , "slot" .= toJSON (unSlotNo slotNo) + , "tip" .= renderPointForDetails dtal tipPoint + , "tipBlockNo" .= toJSON (unBlockNo tipBlkNo) + ] + forMachine _dtal (TraceBlockFromFuture currentSlot tip) = + mkObject + [ "kind" .= String "TraceBlockFromFuture" + , "current slot" .= toJSON (unSlotNo currentSlot) + , "tip" .= toJSON (unSlotNo tip) + ] + forMachine dtal (TraceBlockContext currentSlot tipBlkNo tipPoint) = + mkObject + [ "kind" .= String "TraceBlockContext" + , "current slot" .= toJSON (unSlotNo currentSlot) + , "tip" .= renderPointForDetails dtal tipPoint + , "tipBlockNo" .= toJSON (unBlockNo tipBlkNo) + ] + forMachine _dtal (TraceNoLedgerState slotNo _pt) = + mkObject + [ "kind" .= String "TraceNoLedgerState" + , "slot" .= toJSON (unSlotNo slotNo) + ] + forMachine _dtal (TraceLedgerState slotNo _pt) = + mkObject + [ "kind" .= String "TraceLedgerState" + , "slot" .= toJSON (unSlotNo slotNo) + ] + forMachine _dtal (TraceNoLedgerView slotNo _) = + mkObject + [ "kind" .= String "TraceNoLedgerView" + , "slot" .= toJSON (unSlotNo slotNo) + ] + forMachine _dtal (TraceLedgerView slotNo) = + mkObject + [ "kind" .= String "TraceLedgerView" + , "slot" .= toJSON (unSlotNo slotNo) + ] + forMachine dtal (TraceForgeStateUpdateError slotNo reason) = + mkObject + [ "kind" .= String "TraceForgeStateUpdateError" + , "slot" .= toJSON (unSlotNo slotNo) + , "reason" .= forMachine dtal reason + ] + forMachine dtal (TraceNodeCannotForge slotNo reason) = + mkObject + [ "kind" .= String "TraceNodeCannotForge" + , "slot" .= toJSON (unSlotNo slotNo) + , "reason" .= forMachine dtal reason + ] + forMachine _dtal (TraceNodeNotLeader slotNo) = + mkObject + [ "kind" .= String "TraceNodeNotLeader" + , "slot" .= toJSON (unSlotNo slotNo) + ] + forMachine _dtal (TraceNodeIsLeader slotNo) = + mkObject + [ "kind" .= String "TraceNodeIsLeader" + , "slot" .= toJSON (unSlotNo slotNo) + ] + forMachine _dtal (TraceForgedBlock slotNo _ _ _) = + mkObject + [ "kind" .= String "TraceForgedBlock" + , "slot" .= toJSON (unSlotNo slotNo) + ] + forMachine _dtal (TraceDidntAdoptBlock slotNo _) = + mkObject + [ "kind" .= String "TraceDidntAdoptBlock" + , "slot" .= toJSON (unSlotNo slotNo) + ] + forMachine dtal (TraceForgedInvalidBlock slotNo _ reason) = + mkObject + [ "kind" .= String "TraceForgedInvalidBlock" + , "slot" .= toJSON (unSlotNo slotNo) + , "reason" .= forMachine dtal reason + ] + forMachine DDetailed (TraceAdoptedBlock slotNo blk _txs) = + mkObject + [ "kind" .= String "TraceAdoptedBlock" + , "slot" .= toJSON (unSlotNo slotNo) + , "blockHash" .= renderHeaderHashForDetails + (Proxy @blk) + DDetailed + (blockHash blk) + , "blockSize" .= toJSON (estimateBlockSize (getHeader blk)) +-- , "txIds" .= toJSON (map (show . txId) txs) TODO JNF + ] + forMachine dtal (TraceAdoptedBlock slotNo blk _txs) = + mkObject + [ "kind" .= String "TraceAdoptedBlock" + , "slot" .= toJSON (unSlotNo slotNo) + , "blockHash" .= renderHeaderHashForDetails + (Proxy @blk) + dtal + (blockHash blk) + , "blockSize" .= toJSON (estimateBlockSize (getHeader blk)) + ] + + forHuman (TraceStartLeadershipCheck slotNo) = + "Checking for leadership in slot " <> showT (unSlotNo slotNo) + forHuman (TraceSlotIsImmutable slotNo immutableTipPoint immutableTipBlkNo) = + "Couldn't forge block because current slot is immutable: " + <> "immutable tip: " <> renderPointAsPhrase immutableTipPoint + <> ", immutable tip block no: " <> showT (unBlockNo immutableTipBlkNo) + <> ", current slot: " <> showT (unSlotNo slotNo) + forHuman (TraceBlockFromFuture currentSlot tipSlot) = + "Couldn't forge block because current tip is in the future: " + <> "current tip slot: " <> showT (unSlotNo tipSlot) + <> ", current slot: " <> showT (unSlotNo currentSlot) + forHuman (TraceBlockContext currentSlot tipBlockNo tipPoint) = + "New block will fit onto: " + <> "tip: " <> renderPointAsPhrase tipPoint + <> ", tip block no: " <> showT (unBlockNo tipBlockNo) + <> ", current slot: " <> showT (unSlotNo currentSlot) + forHuman (TraceNoLedgerState slotNo pt) = + "Could not obtain ledger state for point " + <> renderPointAsPhrase pt + <> ", current slot: " + <> showT (unSlotNo slotNo) + forHuman (TraceLedgerState slotNo pt) = + "Obtained a ledger state for point " + <> renderPointAsPhrase pt + <> ", current slot: " + <> showT (unSlotNo slotNo) + forHuman (TraceNoLedgerView slotNo _) = + "Could not obtain ledger view for slot " <> showT (unSlotNo slotNo) + forHuman (TraceLedgerView slotNo) = + "Obtained a ledger view for slot " <> showT (unSlotNo slotNo) + forHuman (TraceForgeStateUpdateError slotNo reason) = + "Updating the forge state in slot " + <> showT (unSlotNo slotNo) + <> " failed because: " + <> showT reason + forHuman (TraceNodeCannotForge slotNo reason) = + "We are the leader in slot " + <> showT (unSlotNo slotNo) + <> ", but we cannot forge because: " + <> showT reason + forHuman (TraceNodeNotLeader slotNo) = + "Not leading slot " <> showT (unSlotNo slotNo) + forHuman (TraceNodeIsLeader slotNo) = + "Leading slot " <> showT (unSlotNo slotNo) + forHuman (TraceForgedBlock slotNo _ _ _) = + "Forged block in slot " <> showT (unSlotNo slotNo) + forHuman (TraceDidntAdoptBlock slotNo _) = + "Didn't adopt forged block in slot " <> showT (unSlotNo slotNo) + forHuman (TraceForgedInvalidBlock slotNo _ reason) = + "Forged invalid block in slot " + <> showT (unSlotNo slotNo) + <> ", reason: " <> showT reason + forHuman (TraceAdoptedBlock slotNo blk _txs) = + "Adopted block forged in slot " + <> showT (unSlotNo slotNo) + <> ": " <> renderHeaderHash (Proxy @blk) (blockHash blk) + -- <> ", TxIds: " <> showT (map txId txs) TODO Fix + + asMetrics (TraceForgeStateUpdateError slot reason) = + IntM ["forgeStateUpdateError"] (fromIntegral $ unSlotNo slot) : + (case getKESInfoX (Proxy @blk) reason of + Nothing -> [] + Just kesInfo -> + [ IntM + ["operationalCertificateStartKESPeriod"] + (fromIntegral . unKESPeriod . HotKey.kesStartPeriod $ kesInfo) + , IntM + ["operationalCertificateExpiryKESPeriod"] + (fromIntegral . unKESPeriod . HotKey.kesEndPeriod $ kesInfo) + , IntM + ["currentKESPeriod"] + 0 + , IntM + ["remainingKESPeriods"] + 0 + ]) + + asMetrics (TraceStartLeadershipCheck slot) = + [IntM ["aboutToLeadSlotLast"] (fromIntegral $ unSlotNo slot)] + asMetrics (TraceSlotIsImmutable slot _tipPoint _tipBlkNo) = + [IntM ["slotIsImmutable"] (fromIntegral $ unSlotNo slot)] + asMetrics (TraceBlockFromFuture slot _slotNo) = + [IntM ["blockFromFuture"] (fromIntegral $ unSlotNo slot)] + asMetrics (TraceBlockContext slot _tipBlkNo _tipPoint) = + [IntM ["blockContext"] (fromIntegral $ unSlotNo slot)] + asMetrics (TraceNoLedgerState slot _) = + [IntM ["couldNotForgeSlotLast"] (fromIntegral $ unSlotNo slot)] + asMetrics (TraceLedgerState slot _) = + [IntM ["ledgerState"] (fromIntegral $ unSlotNo slot)] + asMetrics (TraceNoLedgerView slot _) = + [IntM ["couldNotForgeSlotLast"] (fromIntegral $ unSlotNo slot)] + asMetrics (TraceLedgerView slot) = + [IntM ["ledgerView"] (fromIntegral $ unSlotNo slot)] + -- see above + asMetrics (TraceNodeCannotForge slot _reason) = + [IntM ["nodeCannotForge"] (fromIntegral $ unSlotNo slot)] + asMetrics (TraceNodeNotLeader slot) = + [IntM ["nodeNotLeader"] (fromIntegral $ unSlotNo slot)] + asMetrics (TraceNodeIsLeader slot) = + [IntM ["nodeIsLeader"] (fromIntegral $ unSlotNo slot)] + asMetrics (TraceForgedBlock slot _ _ _) = + [IntM ["forgedSlotLast"] (fromIntegral $ unSlotNo slot)] + asMetrics (TraceDidntAdoptBlock slot _) = + [IntM ["notAdoptedSlotLast"] (fromIntegral $ unSlotNo slot)] + asMetrics (TraceForgedInvalidBlock slot _ _) = + [IntM ["forgedInvalidSlotLast"] (fromIntegral $ unSlotNo slot)] + asMetrics (TraceAdoptedBlock slot _ _) = + [IntM ["adoptedSlotLast"] (fromIntegral $ unSlotNo slot)] + +instance LogFormatting TraceStartLeadershipCheckPlus where + forMachine _dtal TraceStartLeadershipCheckPlus {..} = + mkObject [ "kind" .= String "TraceStartLeadershipCheckPlus" + , "slotNo" .= toJSON (unSlotNo tsSlotNo) + , "utxoSize" .= Number (fromIntegral tsUtxoSize) + , "delegMapSize" .= Number (fromIntegral tsUtxoSize) + , "chainDensity" .= Number (fromRational (toRational tsChainDensity)) + ] + forHuman TraceStartLeadershipCheckPlus {..} = + "Checking for leadership in slot " <> showT (unSlotNo tsSlotNo) + <> " utxoSize " <> showT tsUtxoSize + <> " delegMapSize " <> showT tsDelegMapSize + <> " chainDensity " <> showT tsChainDensity + asMetrics TraceStartLeadershipCheckPlus {..} = + [IntM ["utxoSize"] (fromIntegral tsUtxoSize), + IntM ["delegMapSize"] (fromIntegral tsDelegMapSize)] + -- TODO JNF: Why not deleg map size? + +instance Show t => LogFormatting (TraceBlockchainTimeEvent t) where + forMachine _dtal (TraceStartTimeInTheFuture (SystemStart start) toWait) = + mkObject [ "kind" .= String "TStartTimeInTheFuture" + , "systemStart" .= String (showT start) + , "toWait" .= String (showT toWait) + ] + forMachine _dtal (TraceCurrentSlotUnknown time _) = + mkObject [ "kind" .= String "CurrentSlotUnknown" + , "time" .= String (showT time) + ] + forMachine _dtal (TraceSystemClockMovedBack prevTime newTime) = + mkObject [ "kind" .= String "SystemClockMovedBack" + , "prevTime" .= String (showT prevTime) + , "newTime" .= String (showT newTime) + ] + forHuman (TraceStartTimeInTheFuture (SystemStart start) toWait) = + "Waiting " + <> (Text.pack . show) toWait + <> " until genesis start time at " + <> (Text.pack . show) start + forHuman (TraceCurrentSlotUnknown time _) = + "Too far from the chain tip to determine the current slot number for the time " + <> (Text.pack . show) time + forHuman (TraceSystemClockMovedBack prevTime newTime) = + "The system wall clock time moved backwards, but within our tolerance " + <> "threshold. Previous 'current' time: " + <> (Text.pack . show) prevTime + <> ". New 'current' time: " + <> (Text.pack . show) newTime + +instance Show remotePeer => LogFormatting (TraceKeepAliveClient remotePeer) where + forMachine _dtal (AddSample peer rtt pgsv) = + mkObject + [ "kind" .= String "AddSample" + , "address" .= show peer + , "rtt" .= rtt + , "sampleTime" .= show (dTime $ sampleTime pgsv) + , "outboundG" .= (realToFrac $ gGSV (outboundGSV pgsv) :: Double) + , "inboundG" .= (realToFrac $ gGSV (inboundGSV pgsv) :: Double) + ] + where + gGSV :: GSV -> DiffTime + gGSV (GSV g _ _) = g + + dTime :: Time -> Double + dTime (Time d) = realToFrac d + + forHuman msg = showT msg diff --git a/cardano-node/src/Cardano/TraceDispatcher/Consensus/StartLeadershipCheck.hs b/cardano-node/src/Cardano/TraceDispatcher/Consensus/StartLeadershipCheck.hs new file mode 100644 index 00000000000..5f7d525ba6d --- /dev/null +++ b/cardano-node/src/Cardano/TraceDispatcher/Consensus/StartLeadershipCheck.hs @@ -0,0 +1,193 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE RecordWildCards #-} + +module Cardano.TraceDispatcher.Consensus.StartLeadershipCheck + ( + TraceStartLeadershipCheckPlus (..) + , ForgeTracerType + , forgeTracerTransform + , LedgerQueriesX (..) + ) where + + +import Cardano.Logging +import Cardano.Prelude +import qualified "trace-dispatcher" Control.Tracer as T +import Data.IORef (readIORef) +import qualified Data.Map.Strict as Map + +import qualified Ouroboros.Network.AnchoredFragment as AF +import Ouroboros.Network.Block (BlockNo (..), blockNo, unBlockNo) +import Ouroboros.Network.NodeToClient (LocalConnectionId) +import Ouroboros.Network.NodeToNode (RemoteConnectionId) + +import Ouroboros.Consensus.Block (SlotNo (..)) +import qualified Ouroboros.Consensus.Byron.Ledger.Block as Byron +import qualified Ouroboros.Consensus.Byron.Ledger.Ledger as Byron +import qualified Ouroboros.Consensus.Cardano as Cardano +import qualified Ouroboros.Consensus.Cardano.Block as Cardano +import Ouroboros.Consensus.HardFork.Combinator +import Ouroboros.Consensus.HardFork.Combinator.Embed.Unary +import Ouroboros.Consensus.Ledger.Abstract (IsLedger) +import Ouroboros.Consensus.Ledger.Extended (ExtLedgerState, + ledgerState) +import Ouroboros.Consensus.Node (NodeKernel (..)) +import Ouroboros.Consensus.Node.Tracers +import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB + +import qualified Cardano.Chain.Block as Byron +import qualified Cardano.Chain.UTxO as Byron +import Cardano.Slotting.Slot (fromWithOrigin) + +import Cardano.Ledger.BaseTypes (StrictMaybe (..), fromSMaybe) +import qualified Ouroboros.Consensus.Shelley.Ledger as Shelley +import qualified Shelley.Spec.Ledger.LedgerState as Shelley +import qualified Shelley.Spec.Ledger.UTxO as Shelley + +import Cardano.Tracing.Kernel (NodeKernelData (..)) + + +type ForgeTracerType blk = Either (TraceLabelCreds (TraceForgeEvent blk)) + (TraceLabelCreds TraceStartLeadershipCheckPlus) + +data TraceStartLeadershipCheckPlus = + TraceStartLeadershipCheckPlus { + tsSlotNo :: SlotNo + , tsUtxoSize :: Int + , tsDelegMapSize :: Int + , tsChainDensity :: Double + } + +-- newtype NodeKernelData blk = +-- NodeKernelData +-- { _unNodeKernelData :: IORef (StrictMaybe (NodeKernel IO RemoteConnectionId LocalConnectionId blk)) +-- } + +forgeTracerTransform :: + ( IsLedger (LedgerState blk) + , LedgerQueriesX blk + , AF.HasHeader (Header blk)) + => NodeKernelData blk + -> Trace IO (ForgeTracerType blk) + -> IO (Trace IO (ForgeTracerType blk)) +forgeTracerTransform nodeKern (Trace tr) = pure $ Trace $ T.arrow $ T.emit $ + \case + (lc, Nothing, (Left (TraceLabelCreds creds + (TraceStartLeadershipCheck slotNo)))) -> do + query <- mapNodeKernelDataIO + (\nk -> + (,,) + <$> nkQueryLedger (ledgerUtxoSizeX . ledgerState) nk + <*> nkQueryLedger (ledgerDelegMapSizeX . ledgerState) nk + <*> nkQueryChain fragmentChainDensity nk) + nodeKern + fromSMaybe (pure ()) + (query <&> + \(utxoSize, delegMapSize, chainDensity) -> + let msg = TraceStartLeadershipCheckPlus + slotNo + utxoSize + delegMapSize + (fromRational chainDensity) + in T.traceWith tr (lc, Nothing, Right (TraceLabelCreds creds msg))) + (lc, Nothing, a) -> + T.traceWith tr (lc, Nothing, a) + (lc, Just control, a) -> + T.traceWith tr (lc, Just control, a) + +nkQueryLedger :: + IsLedger (LedgerState blk) + => (ExtLedgerState blk -> a) + -> NodeKernel IO RemoteConnectionId LocalConnectionId blk + -> IO a +nkQueryLedger f NodeKernel{getChainDB} = + f <$> atomically (ChainDB.getCurrentLedger getChainDB) + +fragmentChainDensity :: + AF.HasHeader (Header blk) + => AF.AnchoredFragment (Header blk) -> Rational +fragmentChainDensity frag = calcDensity blockD slotD + where + calcDensity :: Word64 -> Word64 -> Rational + calcDensity bl sl + | sl > 0 = toRational bl / toRational sl + | otherwise = 0 + slotN = unSlotNo $ fromWithOrigin 0 (AF.headSlot frag) + -- Slot of the tip - slot @k@ blocks back. Use 0 as the slot for genesis + -- includes EBBs + slotD = slotN + - unSlotNo (fromWithOrigin 0 (AF.lastSlot frag)) + -- Block numbers start at 1. We ignore the genesis EBB, which has block number 0. + blockD = blockN - firstBlock + blockN = unBlockNo $ fromWithOrigin (BlockNo 1) (AF.headBlockNo frag) + firstBlock = case unBlockNo . blockNo <$> AF.last frag of + -- Empty fragment, no blocks. We have that @blocks = 1 - 1 = 0@ + Left _ -> 1 + -- The oldest block is the genesis EBB with block number 0, + -- don't let it contribute to the number of blocks + Right 0 -> 1 + Right b -> b + +nkQueryChain :: + (AF.AnchoredFragment (Header blk) -> a) + -> NodeKernel IO RemoteConnectionId LocalConnectionId blk + -> IO a +nkQueryChain f NodeKernel{getChainDB} = + f <$> atomically (ChainDB.getCurrentChain getChainDB) + +class LedgerQueriesX blk where + ledgerUtxoSizeX :: LedgerState blk -> Int + ledgerDelegMapSizeX :: LedgerState blk -> Int + +instance LedgerQueriesX Byron.ByronBlock where + ledgerUtxoSizeX = Map.size . Byron.unUTxO . Byron.cvsUtxo . Byron.byronLedgerState + ledgerDelegMapSizeX _ = 0 + +instance LedgerQueriesX (Shelley.ShelleyBlock era) where + ledgerUtxoSizeX = + (\(Shelley.UTxO xs)-> Map.size xs) + . Shelley._utxo + . Shelley._utxoState + . Shelley.esLState + . Shelley.nesEs + . Shelley.shelleyLedgerState + ledgerDelegMapSizeX = + Map.size + . Shelley._delegations + . Shelley._dstate + . Shelley._delegationState + . Shelley.esLState + . Shelley.nesEs + . Shelley.shelleyLedgerState + +instance (LedgerQueriesX x, NoHardForks x) + => LedgerQueriesX (HardForkBlock '[x]) where + ledgerUtxoSizeX = ledgerUtxoSizeX . project + ledgerDelegMapSizeX = ledgerDelegMapSizeX . project + +instance LedgerQueriesX (Cardano.CardanoBlock c) where + ledgerUtxoSizeX = \case + Cardano.LedgerStateByron ledgerByron -> ledgerUtxoSizeX ledgerByron + Cardano.LedgerStateShelley ledgerShelley -> ledgerUtxoSizeX ledgerShelley + Cardano.LedgerStateAllegra ledgerAllegra -> ledgerUtxoSizeX ledgerAllegra + Cardano.LedgerStateMary ledgerMary -> ledgerUtxoSizeX ledgerMary + Cardano.LedgerStateAlonzo ledgerAlonzo -> ledgerUtxoSizeX ledgerAlonzo + ledgerDelegMapSizeX = \case + Cardano.LedgerStateByron ledgerByron -> ledgerDelegMapSizeX ledgerByron + Cardano.LedgerStateShelley ledgerShelley -> ledgerDelegMapSizeX ledgerShelley + Cardano.LedgerStateAllegra ledgerAllegra -> ledgerDelegMapSizeX ledgerAllegra + Cardano.LedgerStateMary ledgerMary -> ledgerDelegMapSizeX ledgerMary + Cardano.LedgerStateAlonzo ledgerAlonzo -> ledgerDelegMapSizeX ledgerAlonzo + + +mapNodeKernelDataIO :: + (NodeKernel IO RemoteConnectionId LocalConnectionId blk -> IO a) + -> NodeKernelData blk + -> IO (StrictMaybe a) +mapNodeKernelDataIO f (NodeKernelData ref) = + readIORef ref >>= traverse f diff --git a/cardano-node/src/Cardano/TraceDispatcher/Consensus/StateInfo.hs b/cardano-node/src/Cardano/TraceDispatcher/Consensus/StateInfo.hs new file mode 100644 index 00000000000..29955df8412 --- /dev/null +++ b/cardano-node/src/Cardano/TraceDispatcher/Consensus/StateInfo.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-deprecations #-} + +module Cardano.TraceDispatcher.Consensus.StateInfo + ( + severityStateInfo + , namesForStateInfo + , traceAsKESInfo + ) where + +import Data.SOP.Strict + +import Cardano.Logging +import Cardano.Prelude hiding (All, Show, show) +import Cardano.TraceDispatcher.Consensus.Formatting + +import Ouroboros.Consensus.Block.Forging +import Ouroboros.Consensus.Node.Tracers (TraceLabelCreds (..)) +import qualified Ouroboros.Consensus.Shelley.Protocol.HotKey as HotKey +import Shelley.Spec.Ledger.OCert (KESPeriod (..)) + + + +traceAsKESInfo + :: forall m blk . (GetKESInfoX blk, MonadIO m) + => Proxy blk + -> Trace m (TraceLabelCreds (HotKey.KESInfo)) + -> Trace m (TraceLabelCreds (ForgeStateInfo blk)) +traceAsKESInfo pr tr = traceAsMaybeKESInfo pr (filterTraceMaybe tr) + +traceAsMaybeKESInfo + :: forall m blk . (GetKESInfoX blk, MonadIO m) + => Proxy blk + -> Trace m (Maybe (TraceLabelCreds (HotKey.KESInfo))) + -> Trace m (TraceLabelCreds (ForgeStateInfo blk)) +traceAsMaybeKESInfo pr (Trace tr) = Trace $ + contramap + (\(lc, mbC, (TraceLabelCreds c e)) -> + case getKESInfoFromStateInfoX pr e of + Just kesi -> (lc, mbC, Just (TraceLabelCreds c kesi)) + Nothing -> (lc, mbC, Nothing)) + tr + +severityStateInfo :: TraceLabelCreds HotKey.KESInfo -> SeverityS +severityStateInfo (TraceLabelCreds _creds a) = severityStateInfo' a + +severityStateInfo' :: HotKey.KESInfo -> SeverityS +severityStateInfo' forgeStateInfo = + let maxKesEvos = endKesPeriod - startKesPeriod + oCertExpiryKesPeriod = startKesPeriod + maxKesEvos + kesPeriodsUntilExpiry = max 0 (oCertExpiryKesPeriod - currKesPeriod) + in if kesPeriodsUntilExpiry > 7 + then Info + else if kesPeriodsUntilExpiry <= 1 + then Alert + else Warning + where + HotKey.KESInfo + { HotKey.kesStartPeriod = KESPeriod startKesPeriod + , HotKey.kesEvolution = currKesPeriod + , HotKey.kesEndPeriod = KESPeriod endKesPeriod + } = forgeStateInfo + +namesForStateInfo :: TraceLabelCreds HotKey.KESInfo -> [Text] +namesForStateInfo (TraceLabelCreds _creds a) = namesForStateInfo' a + +namesForStateInfo' :: HotKey.KESInfo -> [Text] +namesForStateInfo' _fsi = [] diff --git a/cardano-node/src/Cardano/TraceDispatcher/Era/Byron.hs b/cardano-node/src/Cardano/TraceDispatcher/Era/Byron.hs new file mode 100644 index 00000000000..8f3c9bb5eba --- /dev/null +++ b/cardano-node/src/Cardano/TraceDispatcher/Era/Byron.hs @@ -0,0 +1,223 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} + +module Cardano.TraceDispatcher.Era.Byron () where + +-- TODO: Temporary hack for toJSON instances +import Cardano.Tracing.OrphanInstances.Byron () + +import Cardano.Logging +import Cardano.Prelude +import Data.Aeson (Value (String), (.=)) + +import qualified Data.Set as Set +import qualified Data.Text as Text + +import Ouroboros.Consensus.Block (Header) +import Ouroboros.Network.Block (blockHash, blockNo, blockSlot) + +import Ouroboros.Consensus.Byron.Ledger (ByronBlock (..), + ByronOtherHeaderEnvelopeError (..), TxId (..), + byronHeaderRaw) +import Ouroboros.Consensus.Byron.Ledger.Inspect + (ByronLedgerUpdate (..), ProtocolUpdate (..), + UpdateState (..)) +import Ouroboros.Consensus.Ledger.SupportsMempool (GenTx, txId) +import Ouroboros.Consensus.Util.Condense (condense) + +import Cardano.Chain.Block (ABlockOrBoundaryHdr (..), AHeader (..), + ChainValidationError (..), delegationCertificate) +import Cardano.Chain.Byron.API (ApplyMempoolPayloadErr (..)) +import Cardano.Chain.Delegation (delegateVK) +import Cardano.Crypto.Signing (VerificationKey) + +{- HLINT ignore "Use :" -} + +-- +-- | instances of @LogFormatting@ +-- +-- NOTE: this list is sorted by the unqualified name of the outermost type. + +instance LogFormatting ApplyMempoolPayloadErr where + forMachine _dtal (MempoolTxErr utxoValidationErr) = + mkObject + [ "kind" .= String "MempoolTxErr" + , "error" .= String (show utxoValidationErr) + ] + forMachine _dtal (MempoolDlgErr delegScheduleError) = + mkObject + [ "kind" .= String "MempoolDlgErr" + , "error" .= String (show delegScheduleError) + ] + forMachine _dtal (MempoolUpdateProposalErr iFaceErr) = + mkObject + [ "kind" .= String "MempoolUpdateProposalErr" + , "error" .= String (show iFaceErr) + ] + forMachine _dtal (MempoolUpdateVoteErr iFaceErrr) = + mkObject + [ "kind" .= String "MempoolUpdateVoteErr" + , "error" .= String (show iFaceErrr) + ] + +instance LogFormatting ByronLedgerUpdate where + forMachine dtal (ByronUpdatedProtocolUpdates protocolUpdates) = + mkObject + [ "kind" .= String "ByronUpdatedProtocolUpdates" + , "protocolUpdates" .= map (forMachine dtal) protocolUpdates + ] + +instance LogFormatting ProtocolUpdate where + forMachine dtal (ProtocolUpdate updateVersion updateState) = + mkObject + [ "kind" .= String "ProtocolUpdate" + , "protocolUpdateVersion" .= updateVersion + , "protocolUpdateState" .= forMachine dtal updateState + ] + +instance LogFormatting UpdateState where + forMachine _dtal updateState = case updateState of + UpdateRegistered slot -> + mkObject + [ "kind" .= String "UpdateRegistered" + , "slot" .= slot + ] + UpdateActive votes -> + mkObject + [ "kind" .= String "UpdateActive" + , "votes" .= map (Text.pack . show) (Set.toList votes) + ] + UpdateConfirmed slot -> + mkObject + [ "kind" .= String "UpdateConfirmed" + , "slot" .= slot + ] + UpdateStablyConfirmed endorsements -> + mkObject + [ "kind" .= String "UpdateStablyConfirmed" + , "endorsements" .= map (Text.pack . show) (Set.toList endorsements) + ] + UpdateCandidate slot epoch -> + mkObject + [ "kind" .= String "UpdateCandidate" + , "slot" .= slot + , "epoch" .= epoch + ] + UpdateStableCandidate transitionEpoch -> + mkObject + [ "kind" .= String "UpdateStableCandidate" + , "transitionEpoch" .= transitionEpoch + ] + +instance LogFormatting (GenTx ByronBlock) where + forMachine dtal tx = + mkObject $ + ( "txid" .= txId tx ) + : [ "tx" .= condense tx | dtal == DDetailed ] + + +-- instance ToJSON (TxId (GenTx ByronBlock)) where +-- toJSON (ByronTxId i) = toJSON (condense i) +-- toJSON (ByronDlgId i) = toJSON (condense i) +-- toJSON (ByronUpdateProposalId i) = toJSON (condense i) +-- toJSON (ByronUpdateVoteId i) = toJSON (condense i) +-- + +instance LogFormatting ChainValidationError where + forMachine _dtal ChainValidationBoundaryTooLarge = + mkObject + [ "kind" .= String "ChainValidationBoundaryTooLarge" ] + forMachine _dtal ChainValidationBlockAttributesTooLarge = + mkObject + [ "kind" .= String "ChainValidationBlockAttributesTooLarge" ] + forMachine _dtal (ChainValidationBlockTooLarge _ _) = + mkObject + [ "kind" .= String "ChainValidationBlockTooLarge" ] + forMachine _dtal ChainValidationHeaderAttributesTooLarge = + mkObject + [ "kind" .= String "ChainValidationHeaderAttributesTooLarge" ] + forMachine _dtal (ChainValidationHeaderTooLarge _ _) = + mkObject + [ "kind" .= String "ChainValidationHeaderTooLarge" ] + forMachine _dtal (ChainValidationDelegationPayloadError err) = + mkObject + [ "kind" .= String err ] + forMachine _dtal (ChainValidationInvalidDelegation _ _) = + mkObject + [ "kind" .= String "ChainValidationInvalidDelegation" ] + forMachine _dtal (ChainValidationGenesisHashMismatch _ _) = + mkObject + [ "kind" .= String "ChainValidationGenesisHashMismatch" ] + forMachine _dtal (ChainValidationExpectedGenesisHash _ _) = + mkObject + [ "kind" .= String "ChainValidationExpectedGenesisHash" ] + forMachine _dtal (ChainValidationExpectedHeaderHash _ _) = + mkObject + [ "kind" .= String "ChainValidationExpectedHeaderHash" ] + forMachine _dtal (ChainValidationInvalidHash _ _) = + mkObject + [ "kind" .= String "ChainValidationInvalidHash" ] + forMachine _dtal (ChainValidationMissingHash _) = + mkObject + [ "kind" .= String "ChainValidationMissingHash" ] + forMachine _dtal (ChainValidationUnexpectedGenesisHash _) = + mkObject + [ "kind" .= String "ChainValidationUnexpectedGenesisHash" ] + forMachine _dtal (ChainValidationInvalidSignature _) = + mkObject + [ "kind" .= String "ChainValidationInvalidSignature" ] + forMachine _dtal (ChainValidationDelegationSchedulingError _) = + mkObject + [ "kind" .= String "ChainValidationDelegationSchedulingError" ] + forMachine _dtal (ChainValidationProtocolMagicMismatch _ _) = + mkObject + [ "kind" .= String "ChainValidationProtocolMagicMismatch" ] + forMachine _dtal ChainValidationSignatureLight = + mkObject + [ "kind" .= String "ChainValidationSignatureLight" ] + forMachine _dtal (ChainValidationTooManyDelegations _) = + mkObject + [ "kind" .= String "ChainValidationTooManyDelegations" ] + forMachine _dtal (ChainValidationUpdateError _ _) = + mkObject + [ "kind" .= String "ChainValidationUpdateError" ] + forMachine _dtal (ChainValidationUTxOValidationError _) = + mkObject + [ "kind" .= String "ChainValidationUTxOValidationError" ] + forMachine _dtal (ChainValidationProofValidationError _) = + mkObject + [ "kind" .= String "ChainValidationProofValidationError" ] + + +instance LogFormatting (Header ByronBlock) where + forMachine _dtal b = + mkObject $ + [ "kind" .= String "ByronBlock" + , "hash" .= condense (blockHash b) + , "slotNo" .= condense (blockSlot b) + , "blockNo" .= condense (blockNo b) + ] <> + case byronHeaderRaw b of + ABOBBoundaryHdr{} -> [] + ABOBBlockHdr h -> + [ "delegate" .= condense (headerSignerVk h) ] + where + headerSignerVk :: AHeader ByteString -> VerificationKey + headerSignerVk = + delegateVK . delegationCertificate . headerSignature + + +instance LogFormatting ByronOtherHeaderEnvelopeError where + forMachine _dtal (UnexpectedEBBInSlot slot) = + mkObject + [ "kind" .= String "UnexpectedEBBInSlot" + , "slot" .= slot + ] diff --git a/cardano-node/src/Cardano/TraceDispatcher/Era/ConvertTxId.hs b/cardano-node/src/Cardano/TraceDispatcher/Era/ConvertTxId.hs new file mode 100644 index 00000000000..75e1a3938b4 --- /dev/null +++ b/cardano-node/src/Cardano/TraceDispatcher/Era/ConvertTxId.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} + +module Cardano.TraceDispatcher.Era.ConvertTxId + ( ConvertTxId' (..) + ) where + +import Cardano.Prelude hiding (All) + +import Data.SOP.Strict + +import qualified Cardano.Crypto.Hash as Crypto +import qualified Cardano.Crypto.Hashing as Byron.Crypto +import qualified Cardano.Ledger.SafeHash as Ledger +import Ouroboros.Consensus.Byron.Ledger.Block (ByronBlock) +import Ouroboros.Consensus.Byron.Ledger.Mempool (TxId (..)) +import Ouroboros.Consensus.HardFork.Combinator +import Ouroboros.Consensus.Shelley.Ledger.Block (ShelleyBlock) +import Ouroboros.Consensus.Shelley.Ledger.Mempool (TxId (..)) +import Ouroboros.Consensus.TypeFamilyWrappers +import qualified Shelley.Spec.Ledger.TxBody as Shelley + +-- | Convert a transaction ID to raw bytes. +class ConvertTxId' blk where + txIdToRawBytes :: TxId (GenTx blk) -> ByteString + +instance ConvertTxId' ByronBlock where + txIdToRawBytes (ByronTxId txId) = Byron.Crypto.abstractHashToBytes txId + txIdToRawBytes (ByronDlgId dlgId) = Byron.Crypto.abstractHashToBytes dlgId + txIdToRawBytes (ByronUpdateProposalId upId) = + Byron.Crypto.abstractHashToBytes upId + txIdToRawBytes (ByronUpdateVoteId voteId) = + Byron.Crypto.abstractHashToBytes voteId + +instance ConvertTxId' (ShelleyBlock c) where + txIdToRawBytes (ShelleyTxId txId) = + Crypto.hashToBytes . Ledger.extractHash . Shelley._unTxId $ txId + +instance All ConvertTxId' xs + => ConvertTxId' (HardForkBlock xs) where + txIdToRawBytes = + hcollapse + . hcmap (Proxy @ ConvertTxId') (K . txIdToRawBytes . unwrapGenTxId) + . getOneEraGenTxId + . getHardForkGenTxId diff --git a/cardano-node/src/Cardano/TraceDispatcher/Era/HardFork.hs b/cardano-node/src/Cardano/TraceDispatcher/Era/HardFork.hs new file mode 100644 index 00000000000..48341340b33 --- /dev/null +++ b/cardano-node/src/Cardano/TraceDispatcher/Era/HardFork.hs @@ -0,0 +1,372 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_GHC -Wno-orphans #-} + +module Cardano.TraceDispatcher.Era.HardFork () + where + +import Cardano.Prelude hiding (All) + +import Cardano.Tracing.OrphanInstances.HardFork () + +import Data.Aeson +import Data.SOP.Strict + +import Cardano.Logging + +import Cardano.Slotting.Slot (EpochSize (..)) +import Ouroboros.Consensus.Block (BlockProtocol, CannotForge, + ForgeStateInfo, ForgeStateUpdateError) +import Ouroboros.Consensus.BlockchainTime (getSlotLength) +import Ouroboros.Consensus.Cardano.Condense () +import Ouroboros.Consensus.HardFork.Combinator +import Ouroboros.Consensus.HardFork.Combinator.AcrossEras + (EraMismatch (..), OneEraCannotForge (..), + OneEraEnvelopeErr (..), OneEraForgeStateInfo (..), + OneEraForgeStateUpdateError (..), OneEraLedgerError (..), + OneEraLedgerUpdate (..), OneEraLedgerWarning (..), + OneEraValidationErr (..), mkEraMismatch) +import Ouroboros.Consensus.HardFork.Combinator.Condense () +-- import Ouroboros.Consensus.HardFork.History.EraParams (EraParams (..), SafeZone) +import Ouroboros.Consensus.HardFork.History + (EraParams (eraEpochSize, eraSafeZone, eraSlotLength)) +import Ouroboros.Consensus.HardFork.History.EraParams + (EraParams (EraParams)) +import Ouroboros.Consensus.HeaderValidation (OtherHeaderEnvelopeError) +import Ouroboros.Consensus.Ledger.Abstract (LedgerError) +import Ouroboros.Consensus.Ledger.Inspect (LedgerUpdate, + LedgerWarning) +import Ouroboros.Consensus.Ledger.SupportsMempool (ApplyTxErr) +import Ouroboros.Consensus.Protocol.Abstract (ValidationErr) +import Ouroboros.Consensus.TypeFamilyWrappers +import Ouroboros.Consensus.Util.Condense (Condense (..)) + + +-- +-- instances for hashes +-- + +-- instance Condense (OneEraHash xs) where +-- condense = condense . Crypto.UnsafeHash . getOneEraHash + +-- +-- instances for Header HardForkBlock +-- + +instance All (LogFormatting `Compose` Header) xs => LogFormatting (Header (HardForkBlock xs)) where + forMachine dtal = + hcollapse + . hcmap (Proxy @ (LogFormatting `Compose` Header)) (K . forMachine dtal) + . getOneEraHeader + . getHardForkHeader + + +-- +-- instances for GenTx HardForkBlock +-- + +instance All (Compose LogFormatting GenTx) xs => LogFormatting (GenTx (HardForkBlock xs)) where + forMachine dtal = + hcollapse + . hcmap (Proxy @ (LogFormatting `Compose` GenTx)) (K . forMachine dtal) + . getOneEraGenTx + . getHardForkGenTx + +-- instance All (Compose ToJSON WrapGenTxId) xs => ToJSON (TxId (GenTx (HardForkBlock xs))) where +-- toJSON = +-- hcollapse +-- . hcmap (Proxy @ (ToJSON `Compose` WrapGenTxId)) (K . toJSON) +-- . getOneEraGenTxId +-- . getHardForkGenTxId +-- +-- instance ToJSON (TxId (GenTx blk)) => ToJSON (WrapGenTxId blk) where +-- toJSON = toJSON . unwrapGenTxId + + +-- +-- instances for HardForkApplyTxErr +-- + +instance All (LogFormatting `Compose` WrapApplyTxErr) xs => LogFormatting (HardForkApplyTxErr xs) where + forMachine dtal (HardForkApplyTxErrFromEra err) = forMachine dtal err + forMachine _dtal (HardForkApplyTxErrWrongEra mismatch) = + mkObject + [ "kind" .= String "HardForkApplyTxErrWrongEra" + , "currentEra" .= ledgerEraName + , "txEra" .= otherEraName + ] + where + EraMismatch {ledgerEraName, otherEraName} = mkEraMismatch mismatch + +instance All (LogFormatting `Compose` WrapApplyTxErr) xs => LogFormatting (OneEraApplyTxErr xs) where + forMachine dtal = + hcollapse + . hcmap (Proxy @ (LogFormatting `Compose` WrapApplyTxErr)) (K . forMachine dtal) + . getOneEraApplyTxErr + +instance LogFormatting (ApplyTxErr blk) => LogFormatting (WrapApplyTxErr blk) where + forMachine dtal = forMachine dtal . unwrapApplyTxErr + + +-- +-- instances for HardForkLedgerError +-- + +instance All (LogFormatting `Compose` WrapLedgerErr) xs => LogFormatting (HardForkLedgerError xs) where + forMachine dtal (HardForkLedgerErrorFromEra err) = forMachine dtal err + + forMachine _dtal (HardForkLedgerErrorWrongEra mismatch) = + mkObject + [ "kind" .= String "HardForkLedgerErrorWrongEra" + , "currentEra" .= ledgerEraName + , "blockEra" .= otherEraName + ] + where + EraMismatch {ledgerEraName, otherEraName} = mkEraMismatch mismatch + +instance All (LogFormatting `Compose` WrapLedgerErr) xs => LogFormatting (OneEraLedgerError xs) where + forMachine dtal = + hcollapse + . hcmap (Proxy @ (LogFormatting `Compose` WrapLedgerErr)) (K . forMachine dtal) + . getOneEraLedgerError + +instance LogFormatting (LedgerError blk) => LogFormatting (WrapLedgerErr blk) where + forMachine dtal = forMachine dtal . unwrapLedgerErr + + +-- +-- instances for HardForkLedgerWarning +-- + +instance ( All (LogFormatting `Compose` WrapLedgerWarning) xs + , All SingleEraBlock xs + ) => LogFormatting (HardForkLedgerWarning xs) where + forMachine dtal warning = case warning of + HardForkWarningInEra err -> forMachine dtal err + + HardForkWarningTransitionMismatch toEra eraParams epoch -> + mkObject + [ "kind" .= String "HardForkWarningTransitionMismatch" + , "toEra" .= condense toEra + , "eraParams" .= forMachine dtal eraParams + , "transitionEpoch" .= epoch + ] + + HardForkWarningTransitionInFinalEra fromEra epoch -> + mkObject + [ "kind" .= String "HardForkWarningTransitionInFinalEra" + , "fromEra" .= condense fromEra + , "transitionEpoch" .= epoch + ] + + HardForkWarningTransitionUnconfirmed toEra -> + mkObject + [ "kind" .= String "HardForkWarningTransitionUnconfirmed" + , "toEra" .= condense toEra + ] + + HardForkWarningTransitionReconfirmed fromEra toEra prevEpoch newEpoch -> + mkObject + [ "kind" .= String "HardForkWarningTransitionReconfirmed" + , "fromEra" .= condense fromEra + , "toEra" .= condense toEra + , "prevTransitionEpoch" .= prevEpoch + , "newTransitionEpoch" .= newEpoch + ] + +instance All (LogFormatting `Compose` WrapLedgerWarning) xs => LogFormatting (OneEraLedgerWarning xs) where + forMachine dtal = + hcollapse + . hcmap (Proxy @ (LogFormatting `Compose` WrapLedgerWarning)) (K . forMachine dtal) + . getOneEraLedgerWarning + +instance LogFormatting (LedgerWarning blk) => LogFormatting (WrapLedgerWarning blk) where + forMachine dtal = forMachine dtal . unwrapLedgerWarning + +instance LogFormatting EraParams where + forMachine _dtal EraParams{ eraEpochSize, eraSlotLength, eraSafeZone} = + mkObject + [ "epochSize" .= unEpochSize eraEpochSize + , "slotLength" .= getSlotLength eraSlotLength + , "safeZone" .= eraSafeZone + ] + +-- deriving instance ToJSON SafeZone + + +-- +-- instances for HardForkLedgerUpdate +-- + +instance ( All (LogFormatting `Compose` WrapLedgerUpdate) xs + , All SingleEraBlock xs + ) => LogFormatting (HardForkLedgerUpdate xs) where + forMachine dtal update = case update of + HardForkUpdateInEra err -> forMachine dtal err + + HardForkUpdateTransitionConfirmed fromEra toEra epoch -> + mkObject + [ "kind" .= String "HardForkUpdateTransitionConfirmed" + , "fromEra" .= condense fromEra + , "toEra" .= condense toEra + , "transitionEpoch" .= epoch + ] + + HardForkUpdateTransitionDone fromEra toEra epoch -> + mkObject + [ "kind" .= String "HardForkUpdateTransitionDone" + , "fromEra" .= condense fromEra + , "toEra" .= condense toEra + , "transitionEpoch" .= epoch + ] + + HardForkUpdateTransitionRolledBack fromEra toEra -> + mkObject + [ "kind" .= String "HardForkUpdateTransitionRolledBack" + , "fromEra" .= condense fromEra + , "toEra" .= condense toEra + ] + +instance All (LogFormatting `Compose` WrapLedgerUpdate) xs => LogFormatting (OneEraLedgerUpdate xs) where + forMachine dtal = + hcollapse + . hcmap (Proxy @ (LogFormatting `Compose` WrapLedgerUpdate)) (K . forMachine dtal) + . getOneEraLedgerUpdate + +instance LogFormatting (LedgerUpdate blk) => LogFormatting (WrapLedgerUpdate blk) where + forMachine dtal = forMachine dtal . unwrapLedgerUpdate + + +-- +-- instances for HardForkEnvelopeErr +-- + +instance All (LogFormatting `Compose` WrapEnvelopeErr) xs => LogFormatting (HardForkEnvelopeErr xs) where + forMachine dtal (HardForkEnvelopeErrFromEra err) = forMachine dtal err + + forMachine _dtal (HardForkEnvelopeErrWrongEra mismatch) = + mkObject + [ "kind" .= String "HardForkEnvelopeErrWrongEra" + , "currentEra" .= ledgerEraName + , "blockEra" .= otherEraName + ] + where + EraMismatch {ledgerEraName, otherEraName} = mkEraMismatch mismatch + +instance All (LogFormatting `Compose` WrapEnvelopeErr) xs => LogFormatting (OneEraEnvelopeErr xs) where + forMachine dtal = + hcollapse + . hcmap (Proxy @ (LogFormatting `Compose` WrapEnvelopeErr)) (K . forMachine dtal) + . getOneEraEnvelopeErr + +instance LogFormatting (OtherHeaderEnvelopeError blk) => LogFormatting (WrapEnvelopeErr blk) where + forMachine dtal = forMachine dtal . unwrapEnvelopeErr + + +-- +-- instances for HardForkValidationErr +-- + +instance All (LogFormatting `Compose` WrapValidationErr) xs => LogFormatting (HardForkValidationErr xs) where + forMachine dtal (HardForkValidationErrFromEra err) = forMachine dtal err + + forMachine _dtal (HardForkValidationErrWrongEra mismatch) = + mkObject + [ "kind" .= String "HardForkValidationErrWrongEra" + , "currentEra" .= ledgerEraName + , "blockEra" .= otherEraName + ] + where + EraMismatch {ledgerEraName, otherEraName} = mkEraMismatch mismatch + +instance All (LogFormatting `Compose` WrapValidationErr) xs => LogFormatting (OneEraValidationErr xs) where + forMachine dtal = + hcollapse + . hcmap (Proxy @ (LogFormatting `Compose` WrapValidationErr)) (K . forMachine dtal) + . getOneEraValidationErr + +instance LogFormatting (ValidationErr (BlockProtocol blk)) => LogFormatting (WrapValidationErr blk) where + forMachine dtal = forMachine dtal . unwrapValidationErr + + +-- +-- instances for HardForkCannotForge +-- + +-- It's a type alias: +-- type HardForkCannotForge xs = OneEraCannotForge xs + +instance All (LogFormatting `Compose` WrapCannotForge) xs => LogFormatting (OneEraCannotForge xs) where + forMachine dtal = + hcollapse + . hcmap (Proxy @ (LogFormatting `Compose` WrapCannotForge)) + (K . forMachine dtal) + . getOneEraCannotForge + +instance LogFormatting (CannotForge blk) => LogFormatting (WrapCannotForge blk) where + forMachine dtal = forMachine dtal . unwrapCannotForge + + +-- +-- instances for HardForkForgeStateInfo +-- + +-- It's a type alias: +-- type HardForkForgeStateInfo xs = OneEraForgeStateInfo xs + +instance All (LogFormatting `Compose` WrapForgeStateInfo) xs => LogFormatting (OneEraForgeStateInfo xs) where + forMachine dtal forgeStateInfo = + mkObject + [ "kind" .= String "HardForkForgeStateInfo" + , "forgeStateInfo" .= toJSON forgeStateInfo' + ] + where + forgeStateInfo' :: Object + forgeStateInfo' = + hcollapse + . hcmap (Proxy @ (LogFormatting `Compose` WrapForgeStateInfo)) + (K . forMachine dtal) + . getOneEraForgeStateInfo + $ forgeStateInfo + +instance LogFormatting (ForgeStateInfo blk) => LogFormatting (WrapForgeStateInfo blk) where + forMachine dtal = forMachine dtal . unwrapForgeStateInfo + + +-- +-- instances for HardForkForgeStateUpdateError +-- + +-- It's a type alias: +-- type HardForkForgeStateUpdateError xs = OneEraForgeStateUpdateError xs + +instance All (LogFormatting `Compose` WrapForgeStateUpdateError) xs => LogFormatting (OneEraForgeStateUpdateError xs) where + forMachine dtal forgeStateUpdateError = + mkObject + [ "kind" .= String "HardForkForgeStateUpdateError" + , "forgeStateUpdateError" .= toJSON forgeStateUpdateError' + ] + where + forgeStateUpdateError' :: Object + forgeStateUpdateError' = + hcollapse + . hcmap (Proxy @ (LogFormatting `Compose` WrapForgeStateUpdateError)) + (K . forMachine dtal) + . getOneEraForgeStateUpdateError + $ forgeStateUpdateError + +instance LogFormatting (ForgeStateUpdateError blk) => LogFormatting (WrapForgeStateUpdateError blk) where + forMachine dtal = forMachine dtal . unwrapForgeStateUpdateError diff --git a/cardano-node/src/Cardano/TraceDispatcher/Era/Shelley.hs b/cardano-node/src/Cardano/TraceDispatcher/Era/Shelley.hs new file mode 100644 index 00000000000..985441ba3ae --- /dev/null +++ b/cardano-node/src/Cardano/TraceDispatcher/Era/Shelley.hs @@ -0,0 +1,869 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralisedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_GHC -Wno-orphans #-} + +module Cardano.TraceDispatcher.Era.Shelley () + where + +import Cardano.Prelude +import Cardano.Logging + +import Data.Aeson(ToJSON, Value(..), (.=)) +import qualified Data.HashMap.Strict as HMS +import qualified Data.Set as Set +import qualified Data.Text as Text +import Cardano.Tracing.OrphanInstances.Shelley() + +import Cardano.Api.Orphans () + +import Cardano.Slotting.Block (BlockNo (..)) + +import Ouroboros.Consensus.Ledger.SupportsMempool (txId) +import Ouroboros.Consensus.Util.Condense (condense) +import Ouroboros.Network.Block (SlotNo (..), blockHash, blockNo, blockSlot) +import Ouroboros.Network.Point (WithOrigin, withOriginToMaybe) + +import Ouroboros.Consensus.Shelley.Ledger hiding (TxId) +import Ouroboros.Consensus.Shelley.Ledger.Inspect +import Ouroboros.Consensus.Shelley.Protocol (TPraosCannotForge (..)) +import Cardano.Ledger.Crypto (StandardCrypto) +import qualified Ouroboros.Consensus.Shelley.Protocol.HotKey as HotKey + +-- import qualified Cardano.Ledger.AuxiliaryData as Core +import qualified Cardano.Ledger.Core as Core +import qualified Cardano.Ledger.Crypto as Core +import qualified Cardano.Ledger.ShelleyMA.Rules.Utxo as MA +import Cardano.Ledger.Alonzo (AlonzoEra) +import Cardano.Ledger.Alonzo.Rules.Bbody (AlonzoBbodyPredFail) +import Cardano.Ledger.Alonzo.Rules.Utxow (AlonzoPredFail (..)) +import qualified Cardano.Ledger.Alonzo.Rules.Utxo as Alonzo +-- import qualified Cardano.Ledger.ShelleyMA.Timelocks as MA + +-- TODO: this should be exposed via Cardano.Api +import Shelley.Spec.Ledger.API hiding (ShelleyBasedEra) +import Shelley.Spec.Ledger.BlockChain (LastAppliedBlock (..)) + +import Shelley.Spec.Ledger.STS.Bbody +import Shelley.Spec.Ledger.STS.Chain +import Shelley.Spec.Ledger.STS.Deleg +import Shelley.Spec.Ledger.STS.Delegs +import Shelley.Spec.Ledger.STS.Delpl +import Shelley.Spec.Ledger.STS.Epoch +import Shelley.Spec.Ledger.STS.Ledger +import Shelley.Spec.Ledger.STS.Ledgers +import Shelley.Spec.Ledger.STS.Mir +import Shelley.Spec.Ledger.STS.NewEpoch +import Shelley.Spec.Ledger.STS.Newpp +import Shelley.Spec.Ledger.STS.Ocert +import Shelley.Spec.Ledger.STS.Overlay +import Shelley.Spec.Ledger.STS.Pool +import Shelley.Spec.Ledger.STS.PoolReap +import Shelley.Spec.Ledger.STS.Ppup +import Shelley.Spec.Ledger.STS.Rupd +import Shelley.Spec.Ledger.STS.Snap +import Shelley.Spec.Ledger.STS.Tick +import Shelley.Spec.Ledger.STS.Updn +import Shelley.Spec.Ledger.STS.Upec +import Shelley.Spec.Ledger.STS.Utxo +import Shelley.Spec.Ledger.STS.Utxow + +{- HLINT ignore "Use :" -} + +-- +-- | instances of @LogFormatting@ +-- +-- NOTE: this list is sorted in roughly topological order. + +instance ShelleyBasedEra era => LogFormatting (GenTx (ShelleyBlock era)) where + forMachine dtal tx = + mkObject $ + ( "txid" .= txId tx ) + : [ "tx" .= condense tx | dtal == DDetailed ] + +-- instance ToJSON (SupportsMempool.TxId (GenTx (ShelleyBlock era))) where +-- toJSON i = toJSON (condense i) + +instance ShelleyBasedEra era => LogFormatting (Header (ShelleyBlock era)) where + forMachine _dtal b = mkObject + [ "kind" .= String "ShelleyBlock" + , "hash" .= condense (blockHash b) + , "slotNo" .= condense (blockSlot b) + , "blockNo" .= condense (blockNo b) +-- , "delegate" .= condense (headerSignerVk h) + ] + +instance ( ShelleyBasedEra era + , LogFormatting (PredicateFailure (UTXO era)) + , LogFormatting (PredicateFailure (UTXOW era)) + , LogFormatting (PredicateFailure (Core.EraRule "LEDGER" era)) + ) => LogFormatting (ApplyTxError era) where + forMachine dtal (ApplyTxError predicateFailures) = + HMS.unions $ map (forMachine dtal) predicateFailures + +instance LogFormatting (TPraosCannotForge era) where + forMachine _dtal (TPraosCannotForgeKeyNotUsableYet wallClockPeriod keyStartPeriod) = + mkObject + [ "kind" .= String "TPraosCannotForgeKeyNotUsableYet" + , "keyStart" .= keyStartPeriod + , "wallClock" .= wallClockPeriod + ] + forMachine _dtal (TPraosCannotForgeWrongVRF genDlgVRFHash coreNodeVRFHash) = + mkObject + [ "kind" .= String "TPraosCannotLeadWrongVRF" + , "expected" .= genDlgVRFHash + , "actual" .= coreNodeVRFHash + ] + +-- deriving newtype instance ToJSON KESPeriod + +instance LogFormatting HotKey.KESInfo where + forMachine _dtal forgeStateInfo = + let maxKesEvos = endKesPeriod - startKesPeriod + oCertExpiryKesPeriod = startKesPeriod + maxKesEvos + kesPeriodsUntilExpiry = max 0 (oCertExpiryKesPeriod - currKesPeriod) + in + if (kesPeriodsUntilExpiry > 7) + then mkObject + [ "kind" .= String "KESInfo" + , "startPeriod" .= startKesPeriod + , "endPeriod" .= currKesPeriod + , "evolution" .= endKesPeriod + ] + else mkObject + [ "kind" .= String "ExpiryLogMessage" + , "keyExpiresIn" .= kesPeriodsUntilExpiry + , "startPeriod" .= startKesPeriod + , "endPeriod" .= currKesPeriod + , "evolution" .= endKesPeriod + ] + where + HotKey.KESInfo + { kesStartPeriod = KESPeriod startKesPeriod + , kesEvolution = currKesPeriod + , kesEndPeriod = KESPeriod endKesPeriod + } = forgeStateInfo + + forHuman forgeStateInfo = + let maxKesEvos = endKesPeriod - startKesPeriod + oCertExpiryKesPeriod = startKesPeriod + maxKesEvos + kesPeriodsUntilExpiry = max 0 (oCertExpiryKesPeriod - currKesPeriod) + in if (kesPeriodsUntilExpiry > 7) + then "KES info startPeriod " <> show startKesPeriod + <> " currPeriod " <> show currKesPeriod + <> " endPeriod " <> show endKesPeriod + <> (Text.pack . show) kesPeriodsUntilExpiry + <> " KES periods." + else "Operational key will expire in " + <> (Text.pack . show) kesPeriodsUntilExpiry + <> " KES periods." + where + HotKey.KESInfo + { kesStartPeriod = KESPeriod startKesPeriod + , kesEvolution = currKesPeriod + , kesEndPeriod = KESPeriod endKesPeriod + } = forgeStateInfo + + asMetrics forgeStateInfo = + let maxKesEvos = endKesPeriod - startKesPeriod + oCertExpiryKesPeriod = startKesPeriod + maxKesEvos + -- TODO JNF: What is the sense of it? + in [ + IntM ["operationalCertificateStartKESPeriod"] + (fromIntegral startKesPeriod) + , IntM ["operationalCertificateExpiryKESPeriod"] + (fromIntegral (startKesPeriod + maxKesEvos)) + , IntM ["currentKESPeriod"] + (fromIntegral currKesPeriod) + , IntM ["remainingKESPeriods"] + (fromIntegral (max 0 (oCertExpiryKesPeriod - currKesPeriod))) + ] + where + HotKey.KESInfo + { kesStartPeriod = KESPeriod startKesPeriod + , kesEvolution = currKesPeriod + , kesEndPeriod = KESPeriod endKesPeriod + } = forgeStateInfo + + +instance LogFormatting HotKey.KESEvolutionError where + forMachine dtal (HotKey.KESCouldNotEvolve kesInfo targetPeriod) = + mkObject + [ "kind" .= String "KESCouldNotEvolve" + , "kesInfo" .= forMachine dtal kesInfo + , "targetPeriod" .= targetPeriod + ] + forMachine dtal (HotKey.KESKeyAlreadyPoisoned kesInfo targetPeriod) = + mkObject + [ "kind" .= String "KESKeyAlreadyPoisoned" + , "kesInfo" .= forMachine dtal kesInfo + , "targetPeriod" .= targetPeriod + ] + +instance ( ShelleyBasedEra era + , LogFormatting (PredicateFailure (UTXO era)) + , LogFormatting (PredicateFailure (UTXOW era)) + , LogFormatting (PredicateFailure (Core.EraRule "BBODY" era)) + ) => LogFormatting (ShelleyLedgerError era) where + forMachine dtal (BBodyError (BlockTransitionError fs)) = + mkObject [ "kind" .= String "BBodyError" + , "failures" .= map (forMachine dtal) fs + ] + +instance ( ShelleyBasedEra era + , ToJSON (Core.PParamsDelta era) + ) => LogFormatting (ShelleyLedgerUpdate era) where + forMachine dtal (ShelleyUpdatedProtocolUpdates updates) = + mkObject [ "kind" .= String "ShelleyUpdatedProtocolUpdates" + , "updates" .= map (forMachine dtal) updates + ] + +instance ToJSON (Core.PParamsDelta era) + => LogFormatting (ProtocolUpdate era) where + forMachine dtal ProtocolUpdate{protocolUpdateProposal, protocolUpdateState} = + mkObject [ "proposal" .= forMachine dtal protocolUpdateProposal + , "state" .= forMachine dtal protocolUpdateState + ] + +instance ToJSON (Core.PParamsDelta era) + => LogFormatting (UpdateProposal era) where + forMachine _dtal UpdateProposal{proposalParams, proposalVersion, proposalEpoch} = + mkObject [ "params" .= proposalParams + , "version" .= proposalVersion + , "epoch" .= proposalEpoch + ] + +instance LogFormatting (UpdateState crypto) where + forMachine _dtal UpdateState{proposalVotes, proposalReachedQuorum} = + mkObject [ "proposal" .= proposalVotes + , "reachedQuorum" .= proposalReachedQuorum + ] + +instance Core.Crypto crypto => LogFormatting (ChainTransitionError crypto) where + forMachine dtal (ChainTransitionError fs) = + mkObject [ "kind" .= String "ChainTransitionError" + , "failures" .= map (forMachine dtal) fs + ] + +instance ( ShelleyBasedEra era + , LogFormatting (PredicateFailure (Core.EraRule "UTXOW" era)) + , LogFormatting (PredicateFailure (Core.EraRule "BBODY" era)) + , LogFormatting (PredicateFailure (Core.EraRule "TICK" era)) + , LogFormatting (PredicateFailure (Core.EraRule "TICKN" era)) + ) => LogFormatting (ChainPredicateFailure era) where + forMachine _dtal (HeaderSizeTooLargeCHAIN hdrSz maxHdrSz) = + mkObject [ "kind" .= String "HeaderSizeTooLarge" + , "headerSize" .= hdrSz + , "maxHeaderSize" .= maxHdrSz + ] + forMachine _dtal (BlockSizeTooLargeCHAIN blkSz maxBlkSz) = + mkObject [ "kind" .= String "BlockSizeTooLarge" + , "blockSize" .= blkSz + , "maxBlockSize" .= maxBlkSz + ] + forMachine _dtal (ObsoleteNodeCHAIN currentPtcl supportedPtcl) = + mkObject [ "kind" .= String "ObsoleteNode" + , "explanation" .= String explanation + , "currentProtocol" .= currentPtcl + , "supportedProtocol" .= supportedPtcl ] + where + explanation = "A scheduled major protocol version change (hard fork) \ + \has taken place on the chain, but this node does not \ + \understand the new major protocol version. This node \ + \must be upgraded before it can continue with the new \ + \protocol version." + forMachine dtal (BbodyFailure f) = forMachine dtal f + forMachine dtal (TickFailure f) = forMachine dtal f + forMachine dtal (TicknFailure f) = forMachine dtal f + forMachine dtal (PrtclFailure f) = forMachine dtal f + forMachine dtal (PrtclSeqFailure f) = forMachine dtal f + +instance LogFormatting (PrtlSeqFailure crypto) where + forMachine _dtal (WrongSlotIntervalPrtclSeq (SlotNo lastSlot) (SlotNo currSlot)) = + mkObject [ "kind" .= String "WrongSlotInterval" + , "lastSlot" .= lastSlot + , "currentSlot" .= currSlot + ] + forMachine _dtal (WrongBlockNoPrtclSeq lab currentBlockNo) = + mkObject [ "kind" .= String "WrongBlockNo" + , "lastAppliedBlockNo" .= showLastAppBlockNo lab + , "currentBlockNo" .= (String . textShow $ unBlockNo currentBlockNo) + ] + forMachine _dtal (WrongBlockSequencePrtclSeq lastAppliedHash currentHash) = + mkObject [ "kind" .= String "WrongBlockSequence" + , "lastAppliedBlockHash" .= String (textShow lastAppliedHash) + , "currentBlockHash" .= String (textShow currentHash) + ] + +instance ( ShelleyBasedEra era + , LogFormatting (PredicateFailure (UTXO era)) + , LogFormatting (PredicateFailure (UTXOW era)) + , LogFormatting (PredicateFailure (Core.EraRule "LEDGER" era)) + , LogFormatting (PredicateFailure (Core.EraRule "LEDGERS" era)) + ) => LogFormatting (BbodyPredicateFailure era) where + forMachine _dtal (WrongBlockBodySizeBBODY actualBodySz claimedBodySz) = + mkObject [ "kind" .= String "WrongBlockBodySizeBBODY" + , "actualBlockBodySize" .= actualBodySz + , "claimedBlockBodySize" .= claimedBodySz + ] + forMachine _dtal (InvalidBodyHashBBODY actualHash claimedHash) = + mkObject [ "kind" .= String "InvalidBodyHashBBODY" + , "actualBodyHash" .= textShow actualHash + , "claimedBodyHash" .= textShow claimedHash + ] + forMachine dtal (LedgersFailure f) = forMachine dtal f + + +instance ( ShelleyBasedEra era + , LogFormatting (PredicateFailure (UTXO era)) + , LogFormatting (PredicateFailure (UTXOW era)) + , LogFormatting (PredicateFailure (Core.EraRule "LEDGER" era)) + ) => LogFormatting (LedgersPredicateFailure era) where + forMachine dtal (LedgerFailure f) = forMachine dtal f + + +instance ( ShelleyBasedEra era + , LogFormatting (PredicateFailure (UTXO era)) + , LogFormatting (PredicateFailure (UTXOW era)) + , LogFormatting (PredicateFailure (Core.EraRule "DELEGS" era)) + , LogFormatting (PredicateFailure (Core.EraRule "UTXOW" era)) + ) => LogFormatting (LedgerPredicateFailure era) where + forMachine dtal (UtxowFailure f) = forMachine dtal f + forMachine dtal (DelegsFailure f) = forMachine dtal f + + +instance ( ShelleyBasedEra era + , LogFormatting (PredicateFailure (UTXO era)) + , LogFormatting (PredicateFailure (Core.EraRule "UTXO" era)) + ) => LogFormatting (UtxowPredicateFailure era) where + forMachine _dtal (InvalidWitnessesUTXOW wits') = + mkObject [ "kind" .= String "InvalidWitnessesUTXOW" + , "invalidWitnesses" .= map textShow wits' + ] + forMachine _dtal (MissingVKeyWitnessesUTXOW (WitHashes wits')) = + mkObject [ "kind" .= String "MissingVKeyWitnessesUTXOW" + , "missingWitnesses" .= wits' + ] + forMachine _dtal (MissingScriptWitnessesUTXOW missingScripts) = + mkObject [ "kind" .= String "MissingScriptWitnessesUTXOW" + , "missingScripts" .= missingScripts + ] + forMachine _dtal (ScriptWitnessNotValidatingUTXOW failedScripts) = + mkObject [ "kind" .= String "ScriptWitnessNotValidatingUTXOW" + , "failedScripts" .= failedScripts + ] + forMachine dtal (UtxoFailure f) = forMachine dtal f + forMachine _dtal (MIRInsufficientGenesisSigsUTXOW genesisSigs) = + mkObject [ "kind" .= String "MIRInsufficientGenesisSigsUTXOW" + , "genesisSigs" .= genesisSigs + ] + forMachine _dtal (MissingTxBodyMetadataHash metadataHash) = + mkObject [ "kind" .= String "MissingTxBodyMetadataHash" + , "metadataHash" .= metadataHash + ] + forMachine _dtal (MissingTxMetadata txBodyMetadataHash) = + mkObject [ "kind" .= String "MissingTxMetadata" + , "txBodyMetadataHash" .= txBodyMetadataHash + ] + forMachine _dtal (ConflictingMetadataHash txBodyMetadataHash fullMetadataHash) = + mkObject [ "kind" .= String "ConflictingMetadataHash" + , "txBodyMetadataHash" .= txBodyMetadataHash + , "fullMetadataHash" .= fullMetadataHash + ] + forMachine _dtal InvalidMetadata = + mkObject [ "kind" .= String "InvalidMetadata" + ] + +instance ( ShelleyBasedEra era + , ToJSON (Core.Value era) + , ToJSON (Core.TxOut era) + , LogFormatting (PredicateFailure (Core.EraRule "PPUP" era)) + ) + => LogFormatting (UtxoPredicateFailure era) where + forMachine _dtal (BadInputsUTxO badInputs) = + mkObject [ "kind" .= String "BadInputsUTxO" + , "badInputs" .= badInputs + , "error" .= renderBadInputsUTxOErr badInputs + ] + forMachine _dtal (ExpiredUTxO ttl slot) = + mkObject [ "kind" .= String "ExpiredUTxO" + , "ttl" .= ttl + , "slot" .= slot ] + forMachine _dtal (MaxTxSizeUTxO txsize maxtxsize) = + mkObject [ "kind" .= String "MaxTxSizeUTxO" + , "size" .= txsize + , "maxSize" .= maxtxsize ] + -- TODO: Add the minimum allowed UTxO value to OutputTooSmallUTxO + forMachine _dtal (OutputTooSmallUTxO badOutputs) = + mkObject [ "kind" .= String "OutputTooSmallUTxO" + , "outputs" .= badOutputs + , "error" .= String "The output is smaller than the allow minimum \ + \UTxO value defined in the protocol parameters" + ] + forMachine _dtal (OutputBootAddrAttrsTooBig badOutputs) = + mkObject [ "kind" .= String "OutputBootAddrAttrsTooBig" + , "outputs" .= badOutputs + , "error" .= String "The Byron address attributes are too big" + ] + forMachine _dtal InputSetEmptyUTxO = + mkObject [ "kind" .= String "InputSetEmptyUTxO" ] + forMachine _dtal (FeeTooSmallUTxO minfee txfee) = + mkObject [ "kind" .= String "FeeTooSmallUTxO" + , "minimum" .= minfee + , "fee" .= txfee ] + forMachine _dtal (ValueNotConservedUTxO consumed produced) = + mkObject [ "kind" .= String "ValueNotConservedUTxO" + , "consumed" .= consumed + , "produced" .= produced + , "error" .= renderValueNotConservedErr consumed produced + ] + forMachine dtal (UpdateFailure f) = forMachine dtal f + + forMachine _dtal (WrongNetwork network addrs) = + mkObject [ "kind" .= String "WrongNetwork" + , "network" .= network + , "addrs" .= addrs + ] + forMachine _dtal (WrongNetworkWithdrawal network addrs) = + mkObject [ "kind" .= String "WrongNetworkWithdrawal" + , "network" .= network + , "addrs" .= addrs + ] + +-- instance ToJSON MA.ValidityInterval where +-- toJSON vi = +-- Aeson.object $ +-- [ "invalidBefore" .= x | x <- mbfield (MA.invalidBefore vi) ] +-- ++ [ "invalidHereafter" .= x | x <- mbfield (MA.invalidHereafter vi) ] +-- where +-- mbfield SNothing = [] +-- mbfield (SJust x) = [x] + +instance ( ShelleyBasedEra era + , ToJSON (Core.Value era) + , ToJSON (Core.TxOut era) + , LogFormatting (PredicateFailure (Core.EraRule "PPUP" era)) + ) => LogFormatting (MA.UtxoPredicateFailure era) where + forMachine _dtal (MA.BadInputsUTxO badInputs) = + mkObject [ "kind" .= String "BadInputsUTxO" + , "badInputs" .= badInputs + , "error" .= renderBadInputsUTxOErr badInputs + ] + forMachine _dtal (MA.OutsideValidityIntervalUTxO validityInterval slot) = + mkObject [ "kind" .= String "ExpiredUTxO" + , "validityInterval" .= validityInterval + , "slot" .= slot ] + forMachine _dtal (MA.MaxTxSizeUTxO txsize maxtxsize) = + mkObject [ "kind" .= String "MaxTxSizeUTxO" + , "size" .= txsize + , "maxSize" .= maxtxsize ] + forMachine _dtal MA.InputSetEmptyUTxO = + mkObject [ "kind" .= String "InputSetEmptyUTxO" ] + forMachine _dtal (MA.FeeTooSmallUTxO minfee txfee) = + mkObject [ "kind" .= String "FeeTooSmallUTxO" + , "minimum" .= minfee + , "fee" .= txfee ] + forMachine _dtal (MA.ValueNotConservedUTxO consumed produced) = + mkObject [ "kind" .= String "ValueNotConservedUTxO" + , "consumed" .= consumed + , "produced" .= produced + , "error" .= renderValueNotConservedErr consumed produced + ] + forMachine _dtal (MA.WrongNetwork network addrs) = + mkObject [ "kind" .= String "WrongNetwork" + , "network" .= network + , "addrs" .= addrs + ] + forMachine _dtal (MA.WrongNetworkWithdrawal network addrs) = + mkObject [ "kind" .= String "WrongNetworkWithdrawal" + , "network" .= network + , "addrs" .= addrs + ] + -- TODO: Add the minimum allowed UTxO value to OutputTooSmallUTxO + forMachine _dtal (MA.OutputTooSmallUTxO badOutputs) = + mkObject [ "kind" .= String "OutputTooSmallUTxO" + , "outputs" .= badOutputs + , "error" .= String "The output is smaller than the allow minimum \ + \UTxO value defined in the protocol parameters" + ] + forMachine dtal (MA.UpdateFailure f) = forMachine dtal f + forMachine _dtal (MA.OutputBootAddrAttrsTooBig badOutputs) = + mkObject [ "kind" .= String "OutputBootAddrAttrsTooBig" + , "outputs" .= badOutputs + , "error" .= String "The Byron address attributes are too big" + ] + forMachine _dtal MA.TriesToForgeADA = + mkObject [ "kind" .= String "TriesToForgeADA" ] + forMachine _dtal (MA.OutputTooBigUTxO badOutputs) = + mkObject [ "kind" .= String "OutputTooBigUTxO" + , "outputs" .= badOutputs + , "error" .= String "Too many asset ids in the tx output" + ] + +renderBadInputsUTxOErr :: Set (TxIn era) -> Value +renderBadInputsUTxOErr txIns + | Set.null txIns = String "The transaction contains no inputs." + | otherwise = String "The transaction contains inputs that do not exist in the UTxO set." + +renderValueNotConservedErr :: Show val => val -> val -> Value +renderValueNotConservedErr consumed produced = String $ + "This transaction consumed " <> show consumed <> " but produced " <> show produced + +instance LogFormatting (PpupPredicateFailure era) where + forMachine _dtal (NonGenesisUpdatePPUP proposalKeys genesisKeys) = + mkObject [ "kind" .= String "NonGenesisUpdatePPUP" + , "keys" .= proposalKeys Set.\\ genesisKeys ] + forMachine _dtal (PPUpdateWrongEpoch currEpoch intendedEpoch votingPeriod) = + mkObject [ "kind" .= String "PPUpdateWrongEpoch" + , "currentEpoch" .= currEpoch + , "intendedEpoch" .= intendedEpoch + , "votingPeriod" .= String (show votingPeriod) + ] + forMachine _dtal (PVCannotFollowPPUP badPv) = + mkObject [ "kind" .= String "PVCannotFollowPPUP" + , "badProtocolVersion" .= badPv + ] + + +instance ( ShelleyBasedEra era + , LogFormatting (PredicateFailure (Core.EraRule "DELPL" era)) + ) => LogFormatting (DelegsPredicateFailure era) where + forMachine _dtal (DelegateeNotRegisteredDELEG targetPool) = + mkObject [ "kind" .= String "DelegateeNotRegisteredDELEG" + , "targetPool" .= targetPool + ] + forMachine _dtal (WithdrawalsNotInRewardsDELEGS incorrectWithdrawals) = + mkObject [ "kind" .= String "WithdrawalsNotInRewardsDELEGS" + , "incorrectWithdrawals" .= incorrectWithdrawals + ] + forMachine dtal (DelplFailure f) = forMachine dtal f + + +instance ( LogFormatting (PredicateFailure (Core.EraRule "POOL" era)) + , LogFormatting (PredicateFailure (Core.EraRule "DELEG" era)) + ) => LogFormatting (DelplPredicateFailure era) where + forMachine dtal (PoolFailure f) = forMachine dtal f + forMachine dtal (DelegFailure f) = forMachine dtal f + +instance LogFormatting (DelegPredicateFailure era) where + forMachine _dtal (StakeKeyAlreadyRegisteredDELEG alreadyRegistered) = + mkObject [ "kind" .= String "StakeKeyAlreadyRegisteredDELEG" + , "credential" .= String (textShow alreadyRegistered) + , "error" .= String "Staking credential already registered" + ] + forMachine _dtal (StakeKeyInRewardsDELEG alreadyRegistered) = + mkObject [ "kind" .= String "StakeKeyInRewardsDELEG" + , "credential" .= String (textShow alreadyRegistered) + , "error" .= String "Staking credential registered in rewards map" + ] + forMachine _dtal (StakeKeyNotRegisteredDELEG notRegistered) = + mkObject [ "kind" .= String "StakeKeyNotRegisteredDELEG" + , "credential" .= String (textShow notRegistered) + , "error" .= String "Staking credential not registered" + ] + forMachine _dtal (StakeKeyNonZeroAccountBalanceDELEG remBalance) = + mkObject [ "kind" .= String "StakeKeyNonZeroAccountBalanceDELEG" + , "remainingBalance" .= remBalance + ] + forMachine _dtal (StakeDelegationImpossibleDELEG unregistered) = + mkObject [ "kind" .= String "StakeDelegationImpossibleDELEG" + , "credential" .= String (textShow unregistered) + , "error" .= String "Cannot delegate this stake credential because it is not registered" + ] + forMachine _dtal WrongCertificateTypeDELEG = + mkObject [ "kind" .= String "WrongCertificateTypeDELEG" ] + forMachine _dtal (GenesisKeyNotInMappingDELEG (KeyHash genesisKeyHash)) = + mkObject [ "kind" .= String "GenesisKeyNotInMappingDELEG" + , "unknownKeyHash" .= String (textShow genesisKeyHash) + , "error" .= String "This genesis key is not in the delegation mapping" + ] + forMachine _dtal (DuplicateGenesisDelegateDELEG (KeyHash genesisKeyHash)) = + mkObject [ "kind" .= String "DuplicateGenesisDelegateDELEG" + , "duplicateKeyHash" .= String (textShow genesisKeyHash) + , "error" .= String "This genesis key has already been delegated to" + ] + forMachine _dtal (InsufficientForInstantaneousRewardsDELEG mirpot neededMirAmount reserves) = + mkObject [ "kind" .= String "InsufficientForInstantaneousRewardsDELEG" + , "pot" .= String (case mirpot of + ReservesMIR -> "Reserves" + TreasuryMIR -> "Treasury") + , "neededAmount" .= neededMirAmount + , "reserves" .= reserves + ] + forMachine _dtal (MIRCertificateTooLateinEpochDELEG currSlot boundSlotNo) = + mkObject [ "kind" .= String "MIRCertificateTooLateinEpochDELEG" + , "currentSlotNo" .= currSlot + , "mustBeSubmittedBeforeSlotNo" .= boundSlotNo + ] + forMachine _dtal (DuplicateGenesisVRFDELEG vrfKeyHash) = + mkObject [ "kind" .= String "DuplicateGenesisVRFDELEG" + , "keyHash" .= vrfKeyHash + ] + forMachine _dtal MIRTransferNotCurrentlyAllowed = + mkObject [ "kind" .= String "MIRTransferNotCurrentlyAllowed" + ] + forMachine _dtal MIRNegativesNotCurrentlyAllowed = + mkObject [ "kind" .= String "MIRNegativesNotCurrentlyAllowed" + ] + forMachine _dtal (InsufficientForTransferDELEG mirpot attempted available) = + mkObject [ "kind" .= String "DuplicateGenesisVRFDELEG" + , "pot" .= String (case mirpot of + ReservesMIR -> "Reserves" + TreasuryMIR -> "Treasury") + , "attempted" .= attempted + , "available" .= available + ] + forMachine _dtal MIRProducesNegativeUpdate = + mkObject [ "kind" .= String "MIRProducesNegativeUpdate" + ] + +instance LogFormatting (PoolPredicateFailure era) where + forMachine _dtal (StakePoolNotRegisteredOnKeyPOOL (KeyHash unregStakePool)) = + mkObject [ "kind" .= String "StakePoolNotRegisteredOnKeyPOOL" + , "unregisteredKeyHash" .= String (textShow unregStakePool) + , "error" .= String "This stake pool key hash is unregistered" + ] + forMachine _dtal (StakePoolRetirementWrongEpochPOOL currentEpoch intendedRetireEpoch maxRetireEpoch) = + mkObject [ "kind" .= String "StakePoolRetirementWrongEpochPOOL" + , "currentEpoch" .= String (textShow currentEpoch) + , "intendedRetirementEpoch" .= String (textShow intendedRetireEpoch) + , "maxEpochForRetirement" .= String (textShow maxRetireEpoch) + ] + forMachine _dtal (StakePoolCostTooLowPOOL certCost protCost) = + mkObject [ "kind" .= String "StakePoolCostTooLowPOOL" + , "certificateCost" .= String (textShow certCost) + , "protocolParCost" .= String (textShow protCost) + , "error" .= String "The stake pool cost is too low" + ] + forMachine _dtal (PoolMedataHashTooBig (KeyHash stakePool) hashSize) = + mkObject [ "kind" .= String "PoolMedataHashTooBig" + , "hashSize" .= String (textShow hashSize) + , "poolID" .= String (textShow stakePool) + , "error" .= String "The stake pool metadata hash is too large" + ] + +-- Apparently this should never happen according to the Shelley exec spec + forMachine _dtal (WrongCertificateTypePOOL index) = + case index of + 0 -> mkObject [ "kind" .= String "WrongCertificateTypePOOL" + , "error" .= String "Wrong certificate type: Delegation certificate" + ] + 1 -> mkObject [ "kind" .= String "WrongCertificateTypePOOL" + , "error" .= String "Wrong certificate type: MIR certificate" + ] + 2 -> mkObject [ "kind" .= String "WrongCertificateTypePOOL" + , "error" .= String "Wrong certificate type: Genesis certificate" + ] + k -> mkObject [ "kind" .= String "WrongCertificateTypePOOL" + , "certificateType" .= k + , "error" .= String "Wrong certificate type: Unknown certificate type" + ] + + forMachine _dtal (WrongNetworkPOOL networkId listedNetworkId poolId) = + mkObject [ "kind" .= String "WrongNetworkPOOL" + , "networkId" .= String (textShow networkId) + , "listedNetworkId" .= String (textShow listedNetworkId) + , "poolId" .= String (textShow poolId) + , "error" .= String "Wrong network ID in pool registration certificate" + ] + + +instance ( LogFormatting (PredicateFailure (Core.EraRule "NEWEPOCH" era)) + , LogFormatting (PredicateFailure (Core.EraRule "RUPD" era)) + ) => LogFormatting (TickPredicateFailure era) where + forMachine dtal (NewEpochFailure f) = forMachine dtal f + forMachine dtal (RupdFailure f) = forMachine dtal f + +instance LogFormatting TicknPredicateFailure where + forMachine _dtal x = case x of {} -- no constructors + +instance ( LogFormatting (PredicateFailure (Core.EraRule "EPOCH" era)) + , LogFormatting (PredicateFailure (Core.EraRule "MIR" era)) + ) => LogFormatting (NewEpochPredicateFailure era) where + forMachine dtal (EpochFailure f) = forMachine dtal f + forMachine dtal (MirFailure f) = forMachine dtal f + forMachine _dtal (CorruptRewardUpdate update) = + mkObject [ "kind" .= String "CorruptRewardUpdate" + , "update" .= String (show update) ] + + +instance ( LogFormatting (PredicateFailure (Core.EraRule "POOLREAP" era)) + , LogFormatting (PredicateFailure (Core.EraRule "SNAP" era)) + , LogFormatting (PredicateFailure (Core.EraRule "UPEC" era)) + ) => LogFormatting (EpochPredicateFailure era) where + forMachine dtal (PoolReapFailure f) = forMachine dtal f + forMachine dtal (SnapFailure f) = forMachine dtal f + forMachine dtal (UpecFailure f) = forMachine dtal f + + +instance LogFormatting (PoolreapPredicateFailure era) where + forMachine _dtal x = case x of {} -- no constructors + + +instance LogFormatting (SnapPredicateFailure era) where + forMachine _dtal x = case x of {} -- no constructors + +-- TODO: Need to elaborate more on this error +instance LogFormatting (NewppPredicateFailure era) where + forMachine _dtal (UnexpectedDepositPot outstandingDeposits depositPot) = + mkObject [ "kind" .= String "UnexpectedDepositPot" + , "outstandingDeposits" .= String (textShow outstandingDeposits) + , "depositPot" .= String (textShow depositPot) + ] + + +instance LogFormatting (MirPredicateFailure era) where + forMachine _dtal x = case x of {} -- no constructors + + +instance LogFormatting (RupdPredicateFailure era) where + forMachine _dtal x = case x of {} -- no constructors + + +instance Core.Crypto crypto => LogFormatting (PrtclPredicateFailure crypto) where + forMachine dtal (OverlayFailure f) = forMachine dtal f + forMachine dtal (UpdnFailure f) = forMachine dtal f + + +instance Core.Crypto crypto => LogFormatting (OverlayPredicateFailure crypto) where + forMachine _dtal (UnknownGenesisKeyOVERLAY (KeyHash genKeyHash)) = + mkObject [ "kind" .= String "UnknownGenesisKeyOVERLAY" + , "unknownKeyHash" .= String (textShow genKeyHash) + ] + forMachine _dtal (VRFKeyBadLeaderValue seedNonce (SlotNo currSlotNo) prevHashNonce leaderElecVal) = + mkObject [ "kind" .= String "VRFKeyBadLeaderValueOVERLAY" + , "seedNonce" .= String (textShow seedNonce) + , "currentSlot" .= String (textShow currSlotNo) + , "previousHashAsNonce" .= String (textShow prevHashNonce) + , "leaderElectionValue" .= String (textShow leaderElecVal) + ] + forMachine _dtal (VRFKeyBadNonce seedNonce (SlotNo currSlotNo) prevHashNonce blockNonce) = + mkObject [ "kind" .= String "VRFKeyBadNonceOVERLAY" + , "seedNonce" .= String (textShow seedNonce) + , "currentSlot" .= String (textShow currSlotNo) + , "previousHashAsNonce" .= String (textShow prevHashNonce) + , "blockNonce" .= String (textShow blockNonce) + ] + forMachine _dtal (VRFKeyWrongVRFKey issuerHash regVRFKeyHash unregVRFKeyHash) = + mkObject [ "kind" .= String "VRFKeyWrongVRFKeyOVERLAY" + , "poolHash" .= textShow issuerHash + , "registeredVRFKeHash" .= textShow regVRFKeyHash + , "unregisteredVRFKeyHash" .= textShow unregVRFKeyHash + ] + --TODO: Pipe slot number with VRFKeyUnknown + forMachine _dtal (VRFKeyUnknown (KeyHash kHash)) = + mkObject [ "kind" .= String "VRFKeyUnknownOVERLAY" + , "keyHash" .= String (textShow kHash) + ] + forMachine _dtal (VRFLeaderValueTooBig leadElecVal weightOfDelegPool actSlotCoefff) = + mkObject [ "kind" .= String "VRFLeaderValueTooBigOVERLAY" + , "leaderElectionValue" .= String (textShow leadElecVal) + , "delegationPoolWeight" .= String (textShow weightOfDelegPool) + , "activeSlotCoefficient" .= String (textShow actSlotCoefff) + ] + forMachine _dtal (NotActiveSlotOVERLAY notActiveSlotNo) = + -- TODO: Elaborate on NotActiveSlot error + mkObject [ "kind" .= String "NotActiveSlotOVERLAY" + , "slot" .= String (textShow notActiveSlotNo) + ] + forMachine _dtal (WrongGenesisColdKeyOVERLAY actual expected) = + mkObject [ "kind" .= String "WrongGenesisColdKeyOVERLAY" + , "actual" .= actual + , "expected" .= expected ] + forMachine _dtal (WrongGenesisVRFKeyOVERLAY issuer actual expected) = + mkObject [ "kind" .= String "WrongGenesisVRFKeyOVERLAY" + , "issuer" .= issuer + , "actual" .= actual + , "expected" .= expected ] + forMachine dtal (OcertFailure f) = forMachine dtal f + + +instance LogFormatting (OcertPredicateFailure crypto) where + forMachine _dtal (KESBeforeStartOCERT (KESPeriod oCertstart) (KESPeriod current)) = + mkObject [ "kind" .= String "KESBeforeStartOCERT" + , "opCertKESStartPeriod" .= String (textShow oCertstart) + , "currentKESPeriod" .= String (textShow current) + , "error" .= String "Your operational certificate's KES start period \ + \is before the KES current period." + ] + forMachine _dtal (KESAfterEndOCERT (KESPeriod current) (KESPeriod oCertstart) maxKESEvolutions) = + mkObject [ "kind" .= String "KESAfterEndOCERT" + , "currentKESPeriod" .= String (textShow current) + , "opCertKESStartPeriod" .= String (textShow oCertstart) + , "maxKESEvolutions" .= String (textShow maxKESEvolutions) + , "error" .= String "The operational certificate's KES start period is \ + \greater than the max number of KES + the KES current period" + ] + forMachine _dtal (CounterTooSmallOCERT lastKEScounterUsed currentKESCounter) = + mkObject [ "kind" .= String "CounterTooSmallOCert" + , "currentKESCounter" .= String (textShow currentKESCounter) + , "lastKESCounter" .= String (textShow lastKEScounterUsed) + , "error" .= String "The operational certificate's last KES counter is greater \ + \than the current KES counter." + ] + forMachine _dtal (InvalidSignatureOCERT oCertCounter oCertKESStartPeriod) = + mkObject [ "kind" .= String "InvalidSignatureOCERT" + , "opCertKESStartPeriod" .= String (textShow oCertKESStartPeriod) + , "opCertCounter" .= String (textShow oCertCounter) + ] + forMachine _dtal (InvalidKesSignatureOCERT currKESPeriod startKESPeriod expectedKESEvolutions err) = + mkObject [ "kind" .= String "InvalidKesSignatureOCERT" + , "opCertKESStartPeriod" .= String (textShow startKESPeriod) + , "opCertKESCurrentPeriod" .= String (textShow currKESPeriod) + , "opCertExpectedKESEvolutions" .= String (textShow expectedKESEvolutions) + , "error" .= err ] + forMachine _dtal (NoCounterForKeyHashOCERT (KeyHash stakePoolKeyHash)) = + mkObject [ "kind" .= String "NoCounterForKeyHashOCERT" + , "stakePoolKeyHash" .= String (textShow stakePoolKeyHash) + , "error" .= String "A counter was not found for this stake pool key hash" + ] + + +instance LogFormatting (UpdnPredicateFailure crypto) where + forMachine _dtal x = case x of {} -- no constructors + +instance LogFormatting (UpecPredicateFailure era) where + forMachine _dtal (NewPpFailure (UnexpectedDepositPot totalOutstanding depositPot)) = + mkObject [ "kind" .= String "UnexpectedDepositPot" + , "totalOutstanding" .= String (textShow totalOutstanding) + , "depositPot" .= String (textShow depositPot) + ] + +instance LogFormatting (Alonzo.UtxoPredicateFailure (AlonzoEra StandardCrypto)) where + forMachine _ _ = panic "ToJSON: UtxoPredicateFailure not implemented yet" + +instance LogFormatting (AlonzoBbodyPredFail (AlonzoEra StandardCrypto)) where + forMachine _ _ = panic "ToJSON: AlonzoBbodyPredFail not implemented yet" + +instance LogFormatting (AlonzoPredFail (AlonzoEra StandardCrypto)) where + forMachine _ _ = panic "ToJSON: AlonzoPredFail not implemented yet" + +-------------------------------------------------------------------------------- +-- Helper functions +-------------------------------------------------------------------------------- + +textShow :: Show a => a -> Text +textShow = Text.pack . show + +showLastAppBlockNo :: WithOrigin (LastAppliedBlock crypto) -> Text +showLastAppBlockNo wOblk = case withOriginToMaybe wOblk of + Nothing -> "Genesis Block" + Just blk -> textShow . unBlockNo $ labBlockNo blk + +-- Common to cardano-cli + +-- deriving newtype instance Core.Crypto crypto => ToJSON (Core.AuxiliaryDataHash crypto) +-- +-- deriving newtype instance ToJSON (TxId crypto) diff --git a/cardano-node/src/Cardano/TraceDispatcher/Formatting.hs b/cardano-node/src/Cardano/TraceDispatcher/Formatting.hs new file mode 100644 index 00000000000..af4af7c71b0 --- /dev/null +++ b/cardano-node/src/Cardano/TraceDispatcher/Formatting.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +{-# OPTIONS_GHC -Wno-orphans #-} + +module Cardano.TraceDispatcher.Formatting + ( + ) where + +import Cardano.Prelude () +import Data.Aeson (Value (String), toJSON, (.=)) + +import Cardano.Logging (LogFormatting (..), mkObject) +import Cardano.Prelude hiding (Show, show) + +import Cardano.TraceDispatcher.Render (renderHeaderHashForDetails) + +import Ouroboros.Consensus.Block (ConvertRawHash (..), RealPoint, + realPointHash, realPointSlot) +import Ouroboros.Network.Block + + + +-- | A bit of a weird one, but needed because some of the very general +-- consensus interfaces are sometimes instantiated to 'Void', when there are +-- no cases needed. +-- +instance LogFormatting Void where + forMachine _dtal _x = mempty + +instance LogFormatting () where + forMachine _dtal _x = mempty + + +instance LogFormatting SlotNo where + forMachine _dtal slot = + mkObject [ "kind" .= String "SlotNo" + , "slot" .= toJSON (unSlotNo slot) ] + +instance forall blk. ConvertRawHash blk + => LogFormatting (Point blk) where + forMachine _dtal GenesisPoint = + mkObject + [ "kind" .= String "GenesisPoint" ] + forMachine dtal (BlockPoint slot h) = + mkObject + [ "kind" .= String "BlockPoint" + , "slot" .= toJSON (unSlotNo slot) + , "headerHash" .= renderHeaderHashForDetails (Proxy @blk) dtal h + ] + +instance ConvertRawHash blk + => LogFormatting (RealPoint blk) where + forMachine dtal p = mkObject + [ "kind" .= String "Point" + , "slot" .= unSlotNo (realPointSlot p) + , "hash" .= renderHeaderHashForDetails (Proxy @blk) dtal (realPointHash p) + ] diff --git a/cardano-node/src/Cardano/TraceDispatcher/Network/Combinators.hs b/cardano-node/src/Cardano/TraceDispatcher/Network/Combinators.hs new file mode 100644 index 00000000000..62c5e0e0a83 --- /dev/null +++ b/cardano-node/src/Cardano/TraceDispatcher/Network/Combinators.hs @@ -0,0 +1,829 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Cardano.TraceDispatcher.Network.Combinators + ( + severityTChainSync + , namesForTChainSync + + , severityTTxSubmission + , namesForTTxSubmission + + , severityTStateQuery + , namesForTStateQuery + + , severityTChainSyncNode + , namesForTChainSyncNode + + , severityTChainSyncSerialised + , namesForTChainSyncSerialised + + , severityTBlockFetch + , namesForTBlockFetch + + , severityTBlockFetchSerialised + , namesForTBlockFetchSerialised + + , severityTxSubmissionNode + , namesForTxSubmissionNode + + , severityTxSubmission2Node + , namesForTxSubmission2Node + + , severityIPSubscription + , namesForIPSubscription + + , severityDNSSubscription + , namesForDNSSubscription + + , severityDNSResolver + , namesForDNSResolver + + , severityErrorPolicy + , namesForErrorPolicy + + , severityLocalErrorPolicy + , namesForLocalErrorPolicy + + , severityAcceptPolicy + , namesForAcceptPolicy + + , severityMux + , namesForMux + + , severityHandshake + , namesForHandshake + + , severityLocalHandshake + , namesForLocalHandshake + + , severityDiffusionInit + , namesForDiffusionInit + + + ) where + + +import Cardano.Logging +import Cardano.Prelude +import qualified Codec.CBOR.Term as CBOR + +import Network.Mux (MuxTrace (..), WithMuxBearer (..)) +import qualified Network.Socket as Socket + +import Ouroboros.Network.Block (Point, Serialised, Tip) +import qualified Ouroboros.Network.BlockFetch.ClientState as BlockFetch +import Ouroboros.Network.Codec (AnyMessageAndAgency (..)) +import qualified Ouroboros.Network.Diffusion as ND +import qualified Ouroboros.Network.NodeToClient as NtC +import Ouroboros.Network.NodeToNode (DnsTrace (..), + ErrorPolicyTrace (..), SubscriptionTrace (..), + TraceSendRecv (..), WithAddr (..), WithIPList (..)) +import qualified Ouroboros.Network.NodeToNode as NtN +import Ouroboros.Network.Protocol.BlockFetch.Type (BlockFetch (..), + Message (..)) +import Ouroboros.Network.Protocol.ChainSync.Type (ChainSync (..), + Message (..)) +import qualified Ouroboros.Network.Protocol.Handshake.Type as HS +import qualified Ouroboros.Network.Protocol.LocalStateQuery.Type as LSQ +import qualified Ouroboros.Network.Protocol.LocalTxSubmission.Type as LTS +import Ouroboros.Network.Protocol.Trans.Hello.Type (Hello, + Message (..)) +import qualified Ouroboros.Network.Protocol.TxSubmission.Type as TXS +import qualified Ouroboros.Network.Protocol.TxSubmission2.Type as TXS +import Ouroboros.Network.Subscription.Worker (ConnectResult (..), + SubscriberError) + +import Ouroboros.Consensus.Block (Header) +import Ouroboros.Consensus.Ledger.SupportsMempool (ApplyTxErr, GenTx, + GenTxId) +import Ouroboros.Consensus.Storage.Serialisation (SerialisedHeader) + +severityTChainSync :: BlockFetch.TraceLabelPeer peer (TraceSendRecv + (ChainSync (Serialised blk) (Point blk) (Tip blk))) -> SeverityS +severityTChainSync (BlockFetch.TraceLabelPeer _ v) = severityTChainSync' v + where + severityTChainSync' (TraceSendMsg msg) = severityTChainSync'' msg + severityTChainSync' (TraceRecvMsg msg) = severityTChainSync'' msg + + severityTChainSync'' (AnyMessageAndAgency _agency msg) = severityTChainSync''' msg + + severityTChainSync''' :: Message + (ChainSync header point tip) from to + -> SeverityS + severityTChainSync''' MsgRequestNext {} = Info + severityTChainSync''' MsgAwaitReply {} = Info + severityTChainSync''' MsgRollForward {} = Info + severityTChainSync''' MsgRollBackward {} = Info + severityTChainSync''' MsgFindIntersect {} = Info + severityTChainSync''' MsgIntersectFound {} = Info + severityTChainSync''' MsgIntersectNotFound {} = Info + severityTChainSync''' MsgDone {} = Info + +namesForTChainSync :: BlockFetch.TraceLabelPeer peer (TraceSendRecv + (ChainSync (Serialised blk) (Point blk) (Tip blk))) -> [Text] +namesForTChainSync (BlockFetch.TraceLabelPeer _ v) = "NodeToClient" : namesTChainSync v + where + + namesTChainSync (TraceSendMsg msg) = "Send" : namesTChainSync' msg + namesTChainSync (TraceRecvMsg msg) = "Recieve" : namesTChainSync' msg + + namesTChainSync' (AnyMessageAndAgency _agency msg) = namesTChainSync'' msg + + namesTChainSync'' :: Message (ChainSync header point tip) from to + -> [Text] + namesTChainSync'' MsgRequestNext {} = ["RequestNext"] + namesTChainSync'' MsgAwaitReply {} = ["AwaitReply"] + namesTChainSync'' MsgRollForward {} = ["RollForward"] + namesTChainSync'' MsgRollBackward {} = ["RollBackward"] + namesTChainSync'' MsgFindIntersect {} = ["FindIntersect"] + namesTChainSync'' MsgIntersectFound {} = ["IntersectFound"] + namesTChainSync'' MsgIntersectNotFound {} = ["IntersectNotFound"] + namesTChainSync'' MsgDone {} = ["Done"] + +severityTTxSubmission :: BlockFetch.TraceLabelPeer peer + (TraceSendRecv (LTS.LocalTxSubmission (GenTx blk) (ApplyTxErr blk))) + -> SeverityS +severityTTxSubmission (BlockFetch.TraceLabelPeer _ v) = severityTTxSubmission' v + where + severityTTxSubmission' (TraceSendMsg msg) = severityTTxSubmission'' msg + severityTTxSubmission' (TraceRecvMsg msg) = severityTTxSubmission'' msg + + severityTTxSubmission'' (AnyMessageAndAgency _agency msg) = severityTTxSubmission''' msg + + severityTTxSubmission''' :: Message + (LTS.LocalTxSubmission tx reject) from to + -> SeverityS + severityTTxSubmission''' LTS.MsgSubmitTx {} = Info + severityTTxSubmission''' LTS.MsgAcceptTx {} = Info + severityTTxSubmission''' LTS.MsgRejectTx {} = Info + severityTTxSubmission''' LTS.MsgDone {} = Info + + +namesForTTxSubmission :: BlockFetch.TraceLabelPeer peer + (TraceSendRecv (LTS.LocalTxSubmission (GenTx blk) (ApplyTxErr blk))) + -> [Text] +namesForTTxSubmission (BlockFetch.TraceLabelPeer _ v) = namesTTxSubmission v + where + namesTTxSubmission (TraceSendMsg msg) = "Send" : namesTTxSubmission' msg + namesTTxSubmission (TraceRecvMsg msg) = "Recieve" : namesTTxSubmission' msg + + namesTTxSubmission' (AnyMessageAndAgency _agency msg) = namesTTxSubmission'' msg + + namesTTxSubmission'' :: Message + (LTS.LocalTxSubmission tx reject) from to + -> [Text] + namesTTxSubmission'' LTS.MsgSubmitTx {} = ["SubmitTx"] + namesTTxSubmission'' LTS.MsgAcceptTx {} = ["AcceptTx"] + namesTTxSubmission'' LTS.MsgRejectTx {} = ["RejectTx"] + namesTTxSubmission'' LTS.MsgDone {} = ["Done"] + +severityTStateQuery :: BlockFetch.TraceLabelPeer peer + (TraceSendRecv (LSQ.LocalStateQuery blk (Point blk) query)) + -> SeverityS +severityTStateQuery (BlockFetch.TraceLabelPeer _ v) = severityTStateQuery' v + where + severityTStateQuery' (TraceSendMsg msg) = severityTStateQuery'' msg + severityTStateQuery' (TraceRecvMsg msg) = severityTStateQuery'' msg + + severityTStateQuery'' (AnyMessageAndAgency _agency msg) = severityTStateQuery''' msg + + severityTStateQuery''' :: Message + (LSQ.LocalStateQuery block point query1) from to + -> SeverityS + severityTStateQuery''' LSQ.MsgAcquire {} = Info + severityTStateQuery''' LSQ.MsgAcquired {} = Info + severityTStateQuery''' LSQ.MsgFailure {} = Warning + severityTStateQuery''' LSQ.MsgQuery {} = Info + severityTStateQuery''' LSQ.MsgResult {} = Info + severityTStateQuery''' LSQ.MsgRelease {} = Info + severityTStateQuery''' LSQ.MsgReAcquire {} = Info + severityTStateQuery''' LSQ.MsgDone {} = Info + +namesForTStateQuery :: BlockFetch.TraceLabelPeer peer + (TraceSendRecv (LSQ.LocalStateQuery blk (Point blk) query)) + -> [Text] +namesForTStateQuery (BlockFetch.TraceLabelPeer _ v) = namesForTStateQuery' v + where + namesForTStateQuery' (TraceSendMsg msg) = namesForTStateQuery'' msg + namesForTStateQuery' (TraceRecvMsg msg) = namesForTStateQuery'' msg + + namesForTStateQuery'' (AnyMessageAndAgency _agency msg) = namesForTStateQuery''' msg + + namesForTStateQuery''' :: Message + (LSQ.LocalStateQuery block point query1) from to + -> [Text] + + namesForTStateQuery''' LSQ.MsgAcquire {} = ["Acquire"] + namesForTStateQuery''' LSQ.MsgAcquired {} = ["Acquired"] + namesForTStateQuery''' LSQ.MsgFailure {} = ["Acquired"] + namesForTStateQuery''' LSQ.MsgQuery {} = ["Query"] + namesForTStateQuery''' LSQ.MsgResult {} = ["Result"] + namesForTStateQuery''' LSQ.MsgRelease {} = ["Release"] + namesForTStateQuery''' LSQ.MsgReAcquire {} = ["ReAcquire"] + namesForTStateQuery''' LSQ.MsgDone {} = ["Done"] + +severityTChainSyncNode :: BlockFetch.TraceLabelPeer peer (TraceSendRecv + (ChainSync (Header blk) (Point blk) (Tip blk))) -> SeverityS +severityTChainSyncNode (BlockFetch.TraceLabelPeer _ v) = severityTChainSync' v + where + severityTChainSync' (TraceSendMsg msg) = severityTChainSync'' msg + severityTChainSync' (TraceRecvMsg msg) = severityTChainSync'' msg + + severityTChainSync'' (AnyMessageAndAgency _agency msg) = severityTChainSync''' msg + + severityTChainSync''' :: Message + (ChainSync header point tip) from to + -> SeverityS + severityTChainSync''' MsgRequestNext {} = Info + severityTChainSync''' MsgAwaitReply {} = Info + severityTChainSync''' MsgRollForward {} = Info + severityTChainSync''' MsgRollBackward {} = Info + severityTChainSync''' MsgFindIntersect {} = Info + severityTChainSync''' MsgIntersectFound {} = Info + severityTChainSync''' MsgIntersectNotFound {} = Info + severityTChainSync''' MsgDone {} = Info + +namesForTChainSyncNode :: BlockFetch.TraceLabelPeer peer (TraceSendRecv + (ChainSync (Header blk) (Point blk) (Tip blk))) -> [Text] +namesForTChainSyncNode (BlockFetch.TraceLabelPeer _ v) = "NodeToNode" : namesTChainSync v + where + + namesTChainSync (TraceSendMsg msg) = "Send" : namesTChainSync' msg + namesTChainSync (TraceRecvMsg msg) = "Recieve" : namesTChainSync' msg + + namesTChainSync' (AnyMessageAndAgency _agency msg) = namesTChainSync'' msg + + namesTChainSync'' :: Message (ChainSync header point tip) from to + -> [Text] + namesTChainSync'' MsgRequestNext {} = ["RequestNext"] + namesTChainSync'' MsgAwaitReply {} = ["AwaitReply"] + namesTChainSync'' MsgRollForward {} = ["RollForward"] + namesTChainSync'' MsgRollBackward {} = ["RollBackward"] + namesTChainSync'' MsgFindIntersect {} = ["FindIntersect"] + namesTChainSync'' MsgIntersectFound {} = ["IntersectFound"] + namesTChainSync'' MsgIntersectNotFound {} = ["IntersectNotFound"] + namesTChainSync'' MsgDone {} = ["Done"] + +severityTChainSyncSerialised :: BlockFetch.TraceLabelPeer peer (TraceSendRecv + (ChainSync (SerialisedHeader blk) (Point blk) (Tip blk))) -> SeverityS +severityTChainSyncSerialised (BlockFetch.TraceLabelPeer _ v) = severityTChainSync' v + where + severityTChainSync' (TraceSendMsg msg) = severityTChainSync'' msg + severityTChainSync' (TraceRecvMsg msg) = severityTChainSync'' msg + + severityTChainSync'' (AnyMessageAndAgency _agency msg) = severityTChainSync''' msg + + severityTChainSync''' :: Message + (ChainSync header point tip) from to + -> SeverityS + severityTChainSync''' MsgRequestNext {} = Info + severityTChainSync''' MsgAwaitReply {} = Info + severityTChainSync''' MsgRollForward {} = Info + severityTChainSync''' MsgRollBackward {} = Info + severityTChainSync''' MsgFindIntersect {} = Info + severityTChainSync''' MsgIntersectFound {} = Info + severityTChainSync''' MsgIntersectNotFound {} = Info + severityTChainSync''' MsgDone {} = Info + +namesForTChainSyncSerialised :: BlockFetch.TraceLabelPeer peer (TraceSendRecv + (ChainSync (SerialisedHeader blk) (Point blk) (Tip blk))) -> [Text] +namesForTChainSyncSerialised (BlockFetch.TraceLabelPeer _ v) = + "NodeToNode" : namesTChainSync v + where + namesTChainSync (TraceSendMsg msg) = "Send" : namesTChainSync' msg + namesTChainSync (TraceRecvMsg msg) = "Recieve" : namesTChainSync' msg + + namesTChainSync' (AnyMessageAndAgency _agency msg) = namesTChainSync'' msg + + namesTChainSync'' :: Message (ChainSync header point tip) from to + -> [Text] + namesTChainSync'' MsgRequestNext {} = ["RequestNext"] + namesTChainSync'' MsgAwaitReply {} = ["AwaitReply"] + namesTChainSync'' MsgRollForward {} = ["RollForward"] + namesTChainSync'' MsgRollBackward {} = ["RollBackward"] + namesTChainSync'' MsgFindIntersect {} = ["FindIntersect"] + namesTChainSync'' MsgIntersectFound {} = ["IntersectFound"] + namesTChainSync'' MsgIntersectNotFound {} = ["IntersectNotFound"] + namesTChainSync'' MsgDone {} = ["Done"] + +severityTBlockFetch :: BlockFetch.TraceLabelPeer peer + (TraceSendRecv (BlockFetch blk (Point blk))) -> SeverityS +severityTBlockFetch (BlockFetch.TraceLabelPeer _ v) = severityTBlockFetch' v + where + severityTBlockFetch' (TraceSendMsg msg) = severityTBlockFetch'' msg + severityTBlockFetch' (TraceRecvMsg msg) = severityTBlockFetch'' msg + + severityTBlockFetch'' (AnyMessageAndAgency _agency msg) = severityTBlockFetch''' msg + + severityTBlockFetch''' :: Message (BlockFetch x (Point blk)) from to + -> SeverityS + severityTBlockFetch''' MsgRequestRange {} = Info + severityTBlockFetch''' MsgStartBatch {} = Info + severityTBlockFetch''' MsgNoBlocks {} = Info + severityTBlockFetch''' MsgBlock {} = Info + severityTBlockFetch''' MsgBatchDone {} = Info + severityTBlockFetch''' MsgClientDone {} = Info + +namesForTBlockFetch :: BlockFetch.TraceLabelPeer peer + (TraceSendRecv (BlockFetch blk (Point blk))) -> [Text] +namesForTBlockFetch (BlockFetch.TraceLabelPeer _ v) = + "NodeToNode" : namesTBlockFetch v + where + namesTBlockFetch (TraceSendMsg msg) = "Send" : namesTBlockFetch' msg + namesTBlockFetch (TraceRecvMsg msg) = "Recieve" : namesTBlockFetch' msg + + namesTBlockFetch' (AnyMessageAndAgency _agency msg) = namesTBlockFetch'' msg + + namesTBlockFetch'' :: Message (BlockFetch x (Point blk)) from to + -> [Text] + namesTBlockFetch'' MsgRequestRange {} = ["RequestRange"] + namesTBlockFetch'' MsgStartBatch {} = ["StartBatch"] + namesTBlockFetch'' MsgNoBlocks {} = ["NoBlocks"] + namesTBlockFetch'' MsgBlock {} = ["Block"] + namesTBlockFetch'' MsgBatchDone {} = ["BatchDone"] + namesTBlockFetch'' MsgClientDone {} = ["ClientDone"] + +severityTBlockFetchSerialised :: BlockFetch.TraceLabelPeer peer + (TraceSendRecv (BlockFetch (Serialised blk) (Point blk))) -> SeverityS +severityTBlockFetchSerialised (BlockFetch.TraceLabelPeer _ v) = severityTBlockFetch' v + where + severityTBlockFetch' (TraceSendMsg msg) = severityTBlockFetch'' msg + severityTBlockFetch' (TraceRecvMsg msg) = severityTBlockFetch'' msg + + severityTBlockFetch'' (AnyMessageAndAgency _agency msg) = severityTBlockFetch''' msg + + severityTBlockFetch''' :: Message (BlockFetch x (Point blk)) from to + -> SeverityS + severityTBlockFetch''' MsgRequestRange {} = Info + severityTBlockFetch''' MsgStartBatch {} = Info + severityTBlockFetch''' MsgNoBlocks {} = Info + severityTBlockFetch''' MsgBlock {} = Info + severityTBlockFetch''' MsgBatchDone {} = Info + severityTBlockFetch''' MsgClientDone {} = Info + +namesForTBlockFetchSerialised :: BlockFetch.TraceLabelPeer peer + (TraceSendRecv (BlockFetch (Serialised blk) (Point blk))) -> [Text] +namesForTBlockFetchSerialised (BlockFetch.TraceLabelPeer _ v) = + "NodeToNode" : namesTBlockFetch v + where + namesTBlockFetch (TraceSendMsg msg) = "Send" : namesTBlockFetch' msg + namesTBlockFetch (TraceRecvMsg msg) = "Recieve" : namesTBlockFetch' msg + + namesTBlockFetch' (AnyMessageAndAgency _agency msg) = namesTBlockFetch'' msg + + namesTBlockFetch'' :: Message (BlockFetch x (Point blk)) from to + -> [Text] + namesTBlockFetch'' MsgRequestRange {} = ["RequestRange"] + namesTBlockFetch'' MsgStartBatch {} = ["StartBatch"] + namesTBlockFetch'' MsgNoBlocks {} = ["NoBlocks"] + namesTBlockFetch'' MsgBlock {} = ["Block"] + namesTBlockFetch'' MsgBatchDone {} = ["BatchDone"] + namesTBlockFetch'' MsgClientDone {} = ["ClientDone"] + +severityTxSubmissionNode :: BlockFetch.TraceLabelPeer peer + (TraceSendRecv (TXS.TxSubmission (GenTxId blk) (GenTx blk))) -> SeverityS +severityTxSubmissionNode (BlockFetch.TraceLabelPeer _ v) = severityTxSubNode v + where + severityTxSubNode (TraceSendMsg msg) = severityTxSubNode' msg + severityTxSubNode (TraceRecvMsg msg) = severityTxSubNode' msg + + severityTxSubNode' (AnyMessageAndAgency _agency msg) = severityTxSubNode'' msg + + severityTxSubNode'' :: + Message + (TXS.TxSubmission (GenTxId blk) (GenTx blk)) + from + to + -> SeverityS + severityTxSubNode'' TXS.MsgRequestTxIds {} = Info + severityTxSubNode'' TXS.MsgReplyTxIds {} = Info + severityTxSubNode'' TXS.MsgRequestTxs {} = Info + severityTxSubNode'' TXS.MsgReplyTxs {} = Info + severityTxSubNode'' TXS.MsgDone {} = Info + + +namesForTxSubmissionNode :: BlockFetch.TraceLabelPeer peer + (TraceSendRecv (TXS.TxSubmission (GenTxId blk) (GenTx blk))) -> [Text] +namesForTxSubmissionNode (BlockFetch.TraceLabelPeer _ v) = + "NodeToNode" : namesTxSubNode v + where + namesTxSubNode (TraceSendMsg msg) = "Send" : namesTxSubNode' msg + namesTxSubNode (TraceRecvMsg msg) = "Recieve" : namesTxSubNode' msg + + namesTxSubNode' (AnyMessageAndAgency _agency msg) = namesTxSubNode'' msg + + namesTxSubNode'' :: + Message + (TXS.TxSubmission (GenTxId blk) (GenTx blk)) + from + to + -> [Text] + namesTxSubNode'' TXS.MsgRequestTxIds {} = ["RequestTxIds"] + namesTxSubNode'' TXS.MsgReplyTxIds {} = ["ReplyTxIds"] + namesTxSubNode'' TXS.MsgRequestTxs {} = ["RequestTxs"] + namesTxSubNode'' TXS.MsgReplyTxs {} = ["ReplyTxs"] + namesTxSubNode'' TXS.MsgDone {} = ["Done"] + +severityTxSubmission2Node :: BlockFetch.TraceLabelPeer peer + (TraceSendRecv (TXS.TxSubmission2 (GenTxId blk) (GenTx blk))) -> SeverityS +severityTxSubmission2Node (BlockFetch.TraceLabelPeer _ v) = severityTxSubNode v + where + severityTxSubNode (TraceSendMsg msg) = severityTxSubNode' msg + severityTxSubNode (TraceRecvMsg msg) = severityTxSubNode' msg + + severityTxSubNode' (AnyMessageAndAgency _agency msg) = severityTxSubNode'' msg + + severityTxSubNode'' :: + Message + (Hello (TXS.TxSubmission (GenTxId blk) (GenTx blk)) stIdle) + from + to + -> SeverityS + severityTxSubNode'' MsgHello {} = Debug + severityTxSubNode'' (MsgTalk TXS.MsgRequestTxIds {}) = Info + severityTxSubNode'' (MsgTalk TXS.MsgReplyTxIds {}) = Info + severityTxSubNode'' (MsgTalk TXS.MsgRequestTxs {}) = Info + severityTxSubNode'' (MsgTalk TXS.MsgReplyTxs {}) = Info + severityTxSubNode'' (MsgTalk TXS.MsgDone {}) = Info + +namesForTxSubmission2Node :: BlockFetch.TraceLabelPeer peer + (TraceSendRecv (TXS.TxSubmission2 (GenTxId blk) (GenTx blk))) -> [Text] +namesForTxSubmission2Node (BlockFetch.TraceLabelPeer _ v) = + "NodeToNode" : namesTxSubNode v + where + namesTxSubNode (TraceSendMsg msg) = "Send" : namesTxSubNode' msg + namesTxSubNode (TraceRecvMsg msg) = "Recieve" : namesTxSubNode' msg + + namesTxSubNode' (AnyMessageAndAgency _agency msg) = namesTxSubNode'' msg + + namesTxSubNode'' :: + Message + (Hello (TXS.TxSubmission (GenTxId blk) (GenTx blk)) stIdle) + from + to + -> [Text] + namesTxSubNode'' MsgHello {} = ["MsgHello"] + namesTxSubNode'' (MsgTalk TXS.MsgRequestTxIds {}) = ["RequestTxIds"] + namesTxSubNode'' (MsgTalk TXS.MsgReplyTxIds {}) = ["ReplyTxIds"] + namesTxSubNode'' (MsgTalk TXS.MsgRequestTxs {}) = ["RequestTxs"] + namesTxSubNode'' (MsgTalk TXS.MsgReplyTxs {}) = ["ReplyTxs"] + namesTxSubNode'' (MsgTalk TXS.MsgDone {}) = ["Done"] + +severityIPSubscription :: + WithIPList (SubscriptionTrace Socket.SockAddr) + -> SeverityS +severityIPSubscription WithIPList {..} = case wilEvent of + SubscriptionTraceConnectStart _ -> Info + SubscriptionTraceConnectEnd _ connectResult -> case connectResult of + ConnectSuccess -> Info + ConnectSuccessLast -> Notice + ConnectValencyExceeded -> Warning + SubscriptionTraceConnectException _ e -> + case fromException $ SomeException e of + Just (_::SubscriberError) -> Debug + Nothing -> Error + SubscriptionTraceSocketAllocationException {} -> Error + SubscriptionTraceTryConnectToPeer {} -> Info + SubscriptionTraceSkippingPeer {} -> Info + SubscriptionTraceSubscriptionRunning -> Debug + SubscriptionTraceSubscriptionWaiting {} -> Debug + SubscriptionTraceSubscriptionFailed -> Error + SubscriptionTraceSubscriptionWaitingNewConnection {} -> Notice + SubscriptionTraceStart {} -> Debug + SubscriptionTraceRestart {} -> Info + SubscriptionTraceConnectionExist {} -> Notice + SubscriptionTraceUnsupportedRemoteAddr {} -> Error + SubscriptionTraceMissingLocalAddress -> Warning + SubscriptionTraceApplicationException _ e -> + case fromException $ SomeException e of + Just (_::SubscriberError) -> Debug + Nothing -> Error + SubscriptionTraceAllocateSocket {} -> Debug + SubscriptionTraceCloseSocket {} -> Info + +namesForSubscription :: + SubscriptionTrace Socket.SockAddr + -> [Text] +namesForSubscription SubscriptionTraceConnectStart {} = ["ConnectStart"] +namesForSubscription SubscriptionTraceConnectEnd {} = ["ConnectEnd"] +namesForSubscription SubscriptionTraceConnectException {} = ["ConnectException"] +namesForSubscription SubscriptionTraceSocketAllocationException {} = ["SocketAllocationException"] +namesForSubscription SubscriptionTraceTryConnectToPeer {} = ["TryConnectToPeer"] +namesForSubscription SubscriptionTraceSkippingPeer {} = ["SkippingPeer"] +namesForSubscription SubscriptionTraceSubscriptionRunning = ["SubscriptionRunning"] +namesForSubscription SubscriptionTraceSubscriptionWaiting {} = ["SubscriptionWaiting"] +namesForSubscription SubscriptionTraceSubscriptionFailed = ["SubscriptionFailed"] +namesForSubscription SubscriptionTraceSubscriptionWaitingNewConnection {} = ["SubscriptionWaitingNewConnection"] +namesForSubscription SubscriptionTraceStart {} = ["Start"] +namesForSubscription SubscriptionTraceRestart {} = ["Restart"] +namesForSubscription SubscriptionTraceConnectionExist {} = ["ConnectionExist"] +namesForSubscription SubscriptionTraceUnsupportedRemoteAddr {} = ["UnsupportedRemoteAddr"] +namesForSubscription SubscriptionTraceMissingLocalAddress = ["MissingLocalAddress"] +namesForSubscription SubscriptionTraceApplicationException {} = ["ApplicationException"] +namesForSubscription SubscriptionTraceAllocateSocket {} = ["AllocateSocket"] +namesForSubscription SubscriptionTraceCloseSocket {} = ["CloseSocket"] + +namesForIPSubscription :: + WithIPList (SubscriptionTrace Socket.SockAddr) + -> [Text] +namesForIPSubscription(WithIPList _ _ e) = "IP" : namesForSubscription e + +namesForDNSSubscription :: + NtN.WithDomainName (SubscriptionTrace Socket.SockAddr) + -> [Text] +namesForDNSSubscription(NtN.WithDomainName _ e) = "DNS" : namesForSubscription e + +severityDNSSubscription :: + NtN.WithDomainName (SubscriptionTrace Socket.SockAddr) + -> SeverityS +severityDNSSubscription NtN.WithDomainName {..} = case wdnEvent of + SubscriptionTraceConnectStart {} -> Notice + SubscriptionTraceConnectEnd {} -> Notice + SubscriptionTraceConnectException _ e -> + case fromException $ SomeException e of + Just (_::SubscriberError) -> Debug + Nothing -> Error + SubscriptionTraceSocketAllocationException {} -> Error + SubscriptionTraceTryConnectToPeer {} -> Info + SubscriptionTraceSkippingPeer {} -> Info + SubscriptionTraceSubscriptionRunning -> Debug + SubscriptionTraceSubscriptionWaiting {} -> Debug + SubscriptionTraceSubscriptionFailed -> Warning + SubscriptionTraceSubscriptionWaitingNewConnection {} -> Debug + SubscriptionTraceStart {} -> Debug + SubscriptionTraceRestart {} -> Debug + SubscriptionTraceConnectionExist {} -> Info + SubscriptionTraceUnsupportedRemoteAddr {} -> Warning + SubscriptionTraceMissingLocalAddress -> Warning + SubscriptionTraceApplicationException _ e -> + case fromException $ SomeException e of + Just (_::SubscriberError) -> Debug + Nothing -> Error + SubscriptionTraceAllocateSocket {} -> Debug + SubscriptionTraceCloseSocket {} -> Debug + +severityDNSResolver :: NtN.WithDomainName DnsTrace -> SeverityS +severityDNSResolver (NtN.WithDomainName _ ev) = case ev of + DnsTraceLookupException {} -> Error + DnsTraceLookupAError {} -> Error + DnsTraceLookupAAAAError {} -> Error + DnsTraceLookupIPv6First -> Debug + DnsTraceLookupIPv4First -> Debug + DnsTraceLookupAResult {} -> Debug + DnsTraceLookupAAAAResult {} -> Debug + +namesForDNSResolver :: NtN.WithDomainName DnsTrace -> [Text] +namesForDNSResolver (NtN.WithDomainName _ ev) = case ev of + DnsTraceLookupException {} -> ["LookupException"] + DnsTraceLookupAError {} -> ["LookupAError"] + DnsTraceLookupAAAAError {} -> ["LookupAAAAError"] + DnsTraceLookupIPv6First -> ["LookupIPv6First"] + DnsTraceLookupIPv4First -> ["LookupIPv4First"] + DnsTraceLookupAResult {} -> ["LookupAResult"] + DnsTraceLookupAAAAResult {} -> ["LookupAAAAResult"] + +severityErrorPolicy :: WithAddr Socket.SockAddr ErrorPolicyTrace -> SeverityS +severityErrorPolicy (WithAddr _ ev) = case ev of + ErrorPolicySuspendPeer {} -> Warning -- peer misbehaved + ErrorPolicySuspendConsumer {} -> Notice -- peer temporarily not useful + ErrorPolicyLocalNodeError {} -> Error + ErrorPolicyResumePeer {} -> Debug + ErrorPolicyKeepSuspended {} -> Debug + ErrorPolicyResumeConsumer {} -> Debug + ErrorPolicyResumeProducer {} -> Debug + ErrorPolicyUnhandledApplicationException {} -> Error + ErrorPolicyUnhandledConnectionException {} -> Error + ErrorPolicyAcceptException {} -> Error + +namesForErrorPolicy :: WithAddr Socket.SockAddr ErrorPolicyTrace -> [Text] +namesForErrorPolicy (WithAddr _ ev) = case ev of + ErrorPolicySuspendPeer {} -> ["SuspendPeer"] + ErrorPolicySuspendConsumer {} -> ["SuspendConsumer"] + ErrorPolicyLocalNodeError {} -> ["LocalNodeError"] + ErrorPolicyResumePeer {} -> ["ResumePeer"] + ErrorPolicyKeepSuspended {} -> ["KeepSuspended"] + ErrorPolicyResumeConsumer {} -> ["ResumeConsumer"] + ErrorPolicyResumeProducer {} -> ["ResumeProducer"] + ErrorPolicyUnhandledApplicationException {} -> ["UnhandledApplicationException"] + ErrorPolicyUnhandledConnectionException {} -> ["UnhandledConnectionException"] + ErrorPolicyAcceptException {} -> ["AcceptException"] + +severityLocalErrorPolicy :: WithAddr NtC.LocalAddress ErrorPolicyTrace -> SeverityS +severityLocalErrorPolicy (WithAddr _ ev) = case ev of + ErrorPolicySuspendPeer {} -> Warning -- peer misbehaved + ErrorPolicySuspendConsumer {} -> Notice -- peer temporarily not useful + ErrorPolicyLocalNodeError {} -> Error + ErrorPolicyResumePeer {} -> Debug + ErrorPolicyKeepSuspended {} -> Debug + ErrorPolicyResumeConsumer {} -> Debug + ErrorPolicyResumeProducer {} -> Debug + ErrorPolicyUnhandledApplicationException {} -> Error + ErrorPolicyUnhandledConnectionException {} -> Error + ErrorPolicyAcceptException {} -> Error + +namesForLocalErrorPolicy :: WithAddr NtC.LocalAddress ErrorPolicyTrace -> [Text] +namesForLocalErrorPolicy (WithAddr _ ev) = case ev of + ErrorPolicySuspendPeer {} -> ["SuspendPeer"] + ErrorPolicySuspendConsumer {} -> ["SuspendConsumer"] + ErrorPolicyLocalNodeError {} -> ["LocalNodeError"] + ErrorPolicyResumePeer {} -> ["ResumePeer"] + ErrorPolicyKeepSuspended {} -> ["KeepSuspended"] + ErrorPolicyResumeConsumer {} -> ["ResumeConsumer"] + ErrorPolicyResumeProducer {} -> ["ResumeProducer"] + ErrorPolicyUnhandledApplicationException {} -> ["UnhandledApplicationException"] + ErrorPolicyUnhandledConnectionException {} -> ["UnhandledConnectionException"] + ErrorPolicyAcceptException {} -> ["AcceptException"] + +severityAcceptPolicy :: NtN.AcceptConnectionsPolicyTrace -> SeverityS +severityAcceptPolicy NtN.ServerTraceAcceptConnectionRateLimiting {} = Info +severityAcceptPolicy NtN.ServerTraceAcceptConnectionHardLimit {} = Warning + +namesForAcceptPolicy :: NtN.AcceptConnectionsPolicyTrace -> [Text] +namesForAcceptPolicy NtN.ServerTraceAcceptConnectionRateLimiting {} = + ["ConectionRateLimiting"] +namesForAcceptPolicy NtN.ServerTraceAcceptConnectionHardLimit {} = + ["ConnectionHardLimit"] + +severityMux :: WithMuxBearer peer MuxTrace -> SeverityS +severityMux (WithMuxBearer _ mt) = severityMux' mt + +severityMux' :: MuxTrace -> SeverityS +severityMux' MuxTraceRecvHeaderStart {} = Debug +severityMux' MuxTraceRecvHeaderEnd {} = Debug +severityMux' MuxTraceRecvStart {} = Debug +severityMux' MuxTraceRecvEnd {} = Debug +severityMux' MuxTraceSendStart {} = Debug +severityMux' MuxTraceSendEnd = Debug +severityMux' MuxTraceState {} = Info +severityMux' MuxTraceCleanExit {} = Notice +severityMux' MuxTraceExceptionExit {} = Notice +severityMux' MuxTraceChannelRecvStart {} = Debug +severityMux' MuxTraceChannelRecvEnd {} = Debug +severityMux' MuxTraceChannelSendStart {} = Debug +severityMux' MuxTraceChannelSendEnd {} = Debug +severityMux' MuxTraceHandshakeStart = Debug +severityMux' MuxTraceHandshakeClientEnd {} = Info +severityMux' MuxTraceHandshakeServerEnd = Debug +severityMux' MuxTraceHandshakeClientError {} = Error +severityMux' MuxTraceHandshakeServerError {} = Error +severityMux' MuxTraceRecvDeltaQObservation {} = Debug +severityMux' MuxTraceRecvDeltaQSample {} = Debug +severityMux' MuxTraceSDUReadTimeoutException = Notice +severityMux' MuxTraceSDUWriteTimeoutException = Notice +severityMux' MuxTraceStartEagerly {} = Debug +severityMux' MuxTraceStartOnDemand {} = Debug +severityMux' MuxTraceStartedOnDemand {} = Debug +severityMux' MuxTraceTerminating {} = Debug +severityMux' MuxTraceShutdown {} = Debug + +namesForMux :: WithMuxBearer peer MuxTrace -> [Text] +namesForMux (WithMuxBearer _ mt) = namesForMux' mt + +namesForMux' :: MuxTrace -> [Text] +namesForMux' MuxTraceRecvHeaderStart {} = ["RecvHeaderStart"] +namesForMux' MuxTraceRecvHeaderEnd {} = ["RecvHeaderEnd"] +namesForMux' MuxTraceRecvStart {} = ["RecvStart"] +namesForMux' MuxTraceRecvEnd {} = ["RecvEnd"] +namesForMux' MuxTraceSendStart {} = ["SendStart"] +namesForMux' MuxTraceSendEnd = ["SendEnd"] +namesForMux' MuxTraceState {} = ["State"] +namesForMux' MuxTraceCleanExit {} = ["CleanExit"] +namesForMux' MuxTraceExceptionExit {} = ["ExceptionExit"] +namesForMux' MuxTraceChannelRecvStart {} = ["ChannelRecvStart"] +namesForMux' MuxTraceChannelRecvEnd {} = ["ChannelRecvEnd"] +namesForMux' MuxTraceChannelSendStart {} = ["ChannelSendStart"] +namesForMux' MuxTraceChannelSendEnd {} = ["ChannelSendEnd"] +namesForMux' MuxTraceHandshakeStart = ["HandshakeStart "] +namesForMux' MuxTraceHandshakeClientEnd {} = ["HandshakeClientEnd"] +namesForMux' MuxTraceHandshakeServerEnd = ["HandshakeServerEnd"] +namesForMux' MuxTraceHandshakeClientError {} = ["HandshakeClientError"] +namesForMux' MuxTraceHandshakeServerError {} = ["HandshakeServerError"] +namesForMux' MuxTraceRecvDeltaQObservation {} = ["RecvDeltaQObservation"] +namesForMux' MuxTraceRecvDeltaQSample {} = ["RecvDeltaQSample"] +namesForMux' MuxTraceSDUReadTimeoutException = ["SDUReadTimeoutException"] +namesForMux' MuxTraceSDUWriteTimeoutException = ["SDUWriteTimeoutException"] +namesForMux' MuxTraceStartEagerly {} = ["StartEagerly"] +namesForMux' MuxTraceStartOnDemand {} = ["StartOnDemand"] +namesForMux' MuxTraceStartedOnDemand {} = ["StartedOnDemand"] +namesForMux' MuxTraceTerminating {} = ["Terminating"] +namesForMux' MuxTraceShutdown {} = ["Shutdown"] + +severityHandshake :: NtN.HandshakeTr -> SeverityS +severityHandshake (WithMuxBearer _ e) = severityHandshake' e + +severityHandshake' :: + TraceSendRecv (HS.Handshake nt CBOR.Term) + -> SeverityS +severityHandshake' (TraceSendMsg m) = severityHandshake'' m +severityHandshake' (TraceRecvMsg m) = severityHandshake'' m + +severityHandshake'' :: AnyMessageAndAgency (HS.Handshake nt CBOR.Term) -> SeverityS +severityHandshake'' (AnyMessageAndAgency _agency msg) = severityHandshake''' msg + +severityHandshake''' :: Message (HS.Handshake nt CBOR.Term) from to -> SeverityS +severityHandshake''' HS.MsgProposeVersions {} = Info +severityHandshake''' HS.MsgAcceptVersion {} = Info +severityHandshake''' HS.MsgRefuse {} = Info + +namesForHandshake :: NtN.HandshakeTr -> [Text] +namesForHandshake (WithMuxBearer _ e) = namesForHandshake' e + +namesForHandshake' :: + TraceSendRecv (HS.Handshake nt CBOR.Term) + -> [Text] +namesForHandshake' (TraceSendMsg m) = namesForHandshake'' m +namesForHandshake' (TraceRecvMsg m) = namesForHandshake'' m + +namesForHandshake'' :: AnyMessageAndAgency (HS.Handshake nt CBOR.Term) -> [Text] +namesForHandshake'' (AnyMessageAndAgency _agency msg) = namesForHandshake''' msg + +namesForHandshake''' :: Message (HS.Handshake nt CBOR.Term) from to -> [Text] +namesForHandshake''' HS.MsgProposeVersions {} = ["ProposeVersions"] +namesForHandshake''' HS.MsgAcceptVersion {} = ["AcceptVersion"] +namesForHandshake''' HS.MsgRefuse {} = ["Refuse"] + +severityLocalHandshake :: NtC.HandshakeTr -> SeverityS +severityLocalHandshake (WithMuxBearer _ e) = severityLocalHandshake' e + +severityLocalHandshake' :: + TraceSendRecv (HS.Handshake nt CBOR.Term) + -> SeverityS +severityLocalHandshake' (TraceSendMsg m) = severityLocalHandshake'' m +severityLocalHandshake' (TraceRecvMsg m) = severityLocalHandshake'' m + +severityLocalHandshake'' :: AnyMessageAndAgency (HS.Handshake nt CBOR.Term) -> SeverityS +severityLocalHandshake'' (AnyMessageAndAgency _agency msg) = severityLocalHandshake''' msg + +severityLocalHandshake''' :: Message (HS.Handshake nt CBOR.Term) from to -> SeverityS +severityLocalHandshake''' HS.MsgProposeVersions {} = Info +severityLocalHandshake''' HS.MsgAcceptVersion {} = Info +severityLocalHandshake''' HS.MsgRefuse {} = Info + +namesForLocalHandshake :: NtC.HandshakeTr -> [Text] +namesForLocalHandshake (WithMuxBearer _ e) = namesForLocalHandshake' e + +namesForLocalHandshake' :: + TraceSendRecv (HS.Handshake nt CBOR.Term) + -> [Text] +namesForLocalHandshake' (TraceSendMsg m) = namesForLocalHandshake'' m +namesForLocalHandshake' (TraceRecvMsg m) = namesForLocalHandshake'' m + +namesForLocalHandshake'' :: AnyMessageAndAgency (HS.Handshake nt CBOR.Term) -> [Text] +namesForLocalHandshake'' (AnyMessageAndAgency _agency msg) = namesForLocalHandshake''' msg + +namesForLocalHandshake''' :: Message (HS.Handshake nt CBOR.Term) from to -> [Text] +namesForLocalHandshake''' HS.MsgProposeVersions {} = ["ProposeVersions"] +namesForLocalHandshake''' HS.MsgAcceptVersion {} = ["AcceptVersion"] +namesForLocalHandshake''' HS.MsgRefuse {} = ["Refuse"] + +severityDiffusionInit :: ND.DiffusionInitializationTracer -> SeverityS +severityDiffusionInit ND.RunServer {} = Info +severityDiffusionInit ND.RunLocalServer {} = Info +severityDiffusionInit ND.UsingSystemdSocket {} = Info +severityDiffusionInit ND.CreateSystemdSocketForSnocketPath {} = Info +severityDiffusionInit ND.CreatedLocalSocket {} = Info +severityDiffusionInit ND.ConfiguringLocalSocket {} = Info +severityDiffusionInit ND.ListeningLocalSocket {} = Info +severityDiffusionInit ND.LocalSocketUp {} = Info +severityDiffusionInit ND.CreatingServerSocket {} = Info +severityDiffusionInit ND.ConfiguringServerSocket {} = Info +severityDiffusionInit ND.ListeningServerSocket {} = Info +severityDiffusionInit ND.ServerSocketUp {} = Info +severityDiffusionInit ND.UnsupportedLocalSystemdSocket {} = Info +severityDiffusionInit ND.UnsupportedReadySocketCase {} = Info +severityDiffusionInit ND.DiffusionErrored {} = Info + +namesForDiffusionInit :: ND.DiffusionInitializationTracer -> [Text] +namesForDiffusionInit ND.RunServer {} = + ["RunServer"] +namesForDiffusionInit ND.RunLocalServer {} = + ["RunLocalServer"] +namesForDiffusionInit ND.UsingSystemdSocket {} = + ["UsingSystemdSocket"] +namesForDiffusionInit ND.CreateSystemdSocketForSnocketPath {} = + ["CreateSystemdSocketForSnocketPath"] +namesForDiffusionInit ND.CreatedLocalSocket {} = + ["CreatedLocalSocket"] +namesForDiffusionInit ND.ConfiguringLocalSocket {} = + ["ConfiguringLocalSocket"] +namesForDiffusionInit ND.ListeningLocalSocket {} = + ["ListeningLocalSocket"] +namesForDiffusionInit ND.LocalSocketUp {} = + ["LocalSocketUp"] +namesForDiffusionInit ND.CreatingServerSocket {} = + ["CreatingServerSocket"] +namesForDiffusionInit ND.ConfiguringServerSocket {} = + ["ConfiguringServerSocket"] +namesForDiffusionInit ND.ListeningServerSocket {} = + ["ListeningServerSocket"] +namesForDiffusionInit ND.ServerSocketUp {} = + ["ServerSocketUp"] +namesForDiffusionInit ND.UnsupportedLocalSystemdSocket {} = + ["UnsupportedLocalSystemdSocket"] +namesForDiffusionInit ND.UnsupportedReadySocketCase {} = + ["UnsupportedReadySocketCase"] +namesForDiffusionInit ND.DiffusionErrored {} = + ["DiffusionErrored"] diff --git a/cardano-node/src/Cardano/TraceDispatcher/Network/Docu.hs b/cardano-node/src/Cardano/TraceDispatcher/Network/Docu.hs new file mode 100644 index 00000000000..d308e608f77 --- /dev/null +++ b/cardano-node/src/Cardano/TraceDispatcher/Network/Docu.hs @@ -0,0 +1,1111 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} + + +{-# OPTIONS_GHC -Wno-deprecations #-} + +module Cardano.TraceDispatcher.Network.Docu + ( docTChainSync + , docTTxSubmission + , docTStateQuery + , docTBlockFetch + , docTTxSubmissionNode + , docTTxSubmission2Node + , docIPSubscription + , docDNSSubscription + , docDNSResolver + , docErrorPolicy + , docLocalErrorPolicy + , docAcceptPolicy + , docMux + , docHandshake + , docLocalHandshake + , docDiffusionInit + ) where + +import Cardano.Prelude +import qualified Codec.CBOR.Term as CBOR +import Control.Monad.Class.MonadTime +import qualified Data.Map as Map +import Data.Time.Clock (secondsToDiffTime) +import qualified Network.DNS as DNS +import Network.Mux (MiniProtocolNum (..), MuxBearerState (..), + MuxTrace (..), WithMuxBearer (..)) +import Network.Mux.Types (MiniProtocolDir (..), MuxSDUHeader (..), + RemoteClockModel (..)) +import qualified Network.Socket as Socket +import Unsafe.Coerce +import System.IO.Unsafe (unsafePerformIO) + +import Cardano.Logging +import Ouroboros.Consensus.Ledger.SupportsMempool (ApplyTxErr, GenTx, + GenTxId) + +import Ouroboros.Network.Block (Point, Tip) +import qualified Ouroboros.Network.BlockFetch.ClientState as BlockFetch +import Ouroboros.Network.Codec (AnyMessageAndAgency (..)) +import qualified Ouroboros.Network.Diffusion as ND +import Ouroboros.Network.Driver.Simple (TraceSendRecv (..)) +import Ouroboros.Network.NodeToClient (NodeToClientVersion (..)) +import qualified Ouroboros.Network.NodeToClient as NtC +import Ouroboros.Network.NodeToNode (ErrorPolicyTrace (..), + WithAddr (..)) +import qualified Ouroboros.Network.NodeToNode as NtN +import Ouroboros.Network.Protocol.BlockFetch.Type +import Ouroboros.Network.Protocol.ChainSync.Type (ChainSync (..), + Message (..)) +import qualified Ouroboros.Network.Protocol.Handshake.Type as HS +import qualified Ouroboros.Network.Protocol.LocalStateQuery.Type as LSQ +import qualified Ouroboros.Network.Protocol.LocalTxSubmission.Type as LTS +import Ouroboros.Network.Protocol.Trans.Hello.Type (Message (..)) +import qualified Ouroboros.Network.Protocol.TxSubmission.Type as TXS +import qualified Ouroboros.Network.Protocol.TxSubmission2.Type as TXS +import Ouroboros.Network.Snocket (FileDescriptor, + LocalAddress (..), socketFileDescriptor) +import Ouroboros.Network.Subscription.Dns (DnsTrace (..), + WithDomainName (..)) +import Ouroboros.Network.Subscription.Ip (WithIPList (..)) +import Ouroboros.Network.Subscription.Worker (ConnectResult (..), + LocalAddresses (..), SubscriptionTrace (..)) + + +protoHeader :: header +protoHeader = undefined + +protoPoint :: Point blk +protoPoint = undefined + +protoTip :: Tip blk +protoTip = undefined + +protoPeer :: peer +protoPeer = unsafeCoerce (NtN.ConnectionId protoSockAddr protoSockAddr) + +protoStok :: stok +protoStok = undefined + +protoTx :: tx +protoTx = undefined + +protoAcquireFailure :: LSQ.AcquireFailure +protoAcquireFailure = undefined + +protoChainRange :: ChainRange point +protoChainRange = undefined + +protoTokBlockingStyle :: TXS.TokBlockingStyle blocking +protoTokBlockingStyle = undefined + +protoBlockingReplyList :: TXS.BlockingReplyList blocking (txid, TXS.TxSizeInBytes) +protoBlockingReplyList = undefined + +protoTxId :: txid +protoTxId = undefined + +protoLocalAdresses :: LocalAddresses addr +protoLocalAdresses = LocalAddresses Nothing Nothing Nothing + +protoRes :: ConnectResult +protoRes = ConnectSuccess + +protoDiffTime :: DiffTime +protoDiffTime = secondsToDiffTime 1 + +protoException :: NoMethodError +protoException = undefined + +protoDomain :: DNS.Domain +protoDomain = "www.example.org" + +protoDNSError :: DNS.DNSError +protoDNSError = undefined + +protoLocalAdress :: LocalAddress +protoLocalAdress = LocalAddress "loopback" + +protoMuxSDUHeader :: MuxSDUHeader +protoMuxSDUHeader = MuxSDUHeader { + mhTimestamp = RemoteClockModel 1 + , mhNum = MiniProtocolNum 1 + , mhDir = InitiatorDir + , mhLength = 1 + } + +protoTime :: Time +protoTime = undefined + +protoMuxBearerState :: MuxBearerState +protoMuxBearerState = Mature + +protoMiniProtocolNum :: MiniProtocolNum +protoMiniProtocolNum = MiniProtocolNum 1 + +protoMiniProtocolDir :: MiniProtocolDir +protoMiniProtocolDir = InitiatorDir + +protoSomeException :: SomeException +protoSomeException = SomeException (AssertionFailed "just fooled") + +protoNodeToClientVersion :: NodeToClientVersion +protoNodeToClientVersion = NodeToClientV_8 + +protoNodeToNodeVersion :: NtN.NodeToNodeVersion +protoNodeToNodeVersion = NtN.NodeToNodeV_1 + +protoCBORTerm :: CBOR.Term +protoCBORTerm = undefined + +protoRefuseReason :: HS.RefuseReason NtN.NodeToNodeVersion +protoRefuseReason = HS.Refused protoNodeToNodeVersion "hello" + +protoLocalRefuseReason :: HS.RefuseReason NtC.NodeToClientVersion +protoLocalRefuseReason = HS.Refused protoNodeToClientVersion "hello" + +protoSockAddr :: Socket.SockAddr +protoSockAddr = Socket.SockAddrUnix "loopback" + +protoLocalAddress :: LocalAddress +protoLocalAddress = LocalAddress "loopback" + +protoFilePath :: FilePath +protoFilePath = "loopback" + +protoFileDescriptor :: FileDescriptor +protoFileDescriptor = + unsafePerformIO $ do + sock <- Socket.mkSocket 111 + socketFileDescriptor sock + + + +------------------------------------ + +docTChainSync :: Documented (BlockFetch.TraceLabelPeer peer (TraceSendRecv + (ChainSync x (Point blk) (Tip blk)))) +docTChainSync = Documented [ + DocMsg + (BlockFetch.TraceLabelPeer protoPeer + (TraceSendMsg (AnyMessageAndAgency protoStok MsgRequestNext))) + [] + "Request the next update from the producer. The response can be a roll\ + \forward, a roll back or wait." + , DocMsg + (BlockFetch.TraceLabelPeer protoPeer + (TraceSendMsg (AnyMessageAndAgency protoStok MsgAwaitReply))) + [] + "Acknowledge the request but require the consumer to wait for the next\ + \update. This means that the consumer is synced with the producer, and\ + \the producer is waiting for its own chain state to change." + , DocMsg + (BlockFetch.TraceLabelPeer protoPeer + (TraceSendMsg (AnyMessageAndAgency protoStok MsgAwaitReply))) + [] + "Tell the consumer to extend their chain with the given header.\ + \ \ + \The message also tells the consumer about the head point of the producer." + , DocMsg + (BlockFetch.TraceLabelPeer protoPeer + (TraceSendMsg (AnyMessageAndAgency protoStok + (MsgRollForward protoHeader protoTip)))) + [] + "Tell the consumer to extend their chain with the given header.\ + \ \ + \The message also tells the consumer about the head point of the producer." + , DocMsg + (BlockFetch.TraceLabelPeer protoPeer + (TraceSendMsg (AnyMessageAndAgency protoStok + (MsgRollBackward protoPoint protoTip)))) + [] + "Tell the consumer to roll back to a given point on their chain.\ + \\ + \The message also tells the consumer about the head point of the producer." + , DocMsg + (BlockFetch.TraceLabelPeer protoPeer + (TraceSendMsg (AnyMessageAndAgency protoStok + (MsgFindIntersect [protoPoint])))) + [] + "Ask the producer to try to find an improved intersection point between\ + \the consumer and producer's chains. The consumer sends a sequence of\ + \points and it is up to the producer to find the first intersection point\ + \on its chain and send it back to the consumer." + , DocMsg + (BlockFetch.TraceLabelPeer protoPeer + (TraceSendMsg (AnyMessageAndAgency protoStok + (MsgIntersectFound protoPoint protoTip)))) + [] + "The reply to the consumer about an intersection found.\ + \The consumer can decide weather to send more points.\ + \\ + \The message also tells the consumer about the head point of the producer." + , DocMsg + (BlockFetch.TraceLabelPeer protoPeer + (TraceSendMsg (AnyMessageAndAgency protoStok + (MsgIntersectNotFound protoTip)))) + [] + "The reply to the consumer that no intersection was found: none of the\ + \points the consumer supplied are on the producer chain.\ + \\ + \The message also tells the consumer about the head point of the producer." + , DocMsg + (BlockFetch.TraceLabelPeer protoPeer + (TraceSendMsg (AnyMessageAndAgency protoStok + MsgDone))) + [] + "We have to explain to the framework what our states mean, in terms of\ + \which party has agency in each state.\ + \ \ + \Idle states are where it is for the client to send a message,\ + \busy states are where the server is expected to send a reply." + ] + +docTTxSubmission :: Documented + (BlockFetch.TraceLabelPeer + localPeer + (TraceSendRecv + (LTS.LocalTxSubmission + (GenTx blk) (ApplyTxErr blk)))) +docTTxSubmission = Documented [ + DocMsg + (BlockFetch.TraceLabelPeer protoPeer + (TraceSendMsg (AnyMessageAndAgency protoStok (LTS.MsgSubmitTx protoTx)))) + [] + "The client submits a single transaction and waits a reply." + , DocMsg + (BlockFetch.TraceLabelPeer protoPeer + (TraceSendMsg (AnyMessageAndAgency protoStok LTS.MsgAcceptTx))) + [] + "The server can reply to inform the client that it has accepted the\ + \transaction." + , DocMsg + (BlockFetch.TraceLabelPeer protoPeer + (TraceSendMsg (AnyMessageAndAgency protoStok (LTS.MsgRejectTx undefined)))) + [] + "The server can reply to inform the client that it has rejected the\ + \transaction. A reason for the rejection is included." + , DocMsg + (BlockFetch.TraceLabelPeer protoPeer + (TraceSendMsg (AnyMessageAndAgency protoStok LTS.MsgDone))) + [] + "The client can terminate the protocol." + ] + +docTStateQuery :: Documented + (BlockFetch.TraceLabelPeer peer + (TraceSendRecv + (LSQ.LocalStateQuery blk (Point blk) query))) +docTStateQuery = Documented [ + DocMsg + (BlockFetch.TraceLabelPeer protoPeer + (TraceSendMsg (AnyMessageAndAgency protoStok (LSQ.MsgAcquire Nothing)))) + [] + "The client requests that the state as of a particular recent point on\ + \the server's chain (within K of the tip) be made available to query,\ + \and waits for confirmation or failure.\ + \\ + \From 'NodeToClient_V8' onwards if the point is not specified, current tip\ + \will be acquired. For previous versions of the protocol 'point' must be\ + \given." + , DocMsg + (BlockFetch.TraceLabelPeer protoPeer + (TraceSendMsg (AnyMessageAndAgency protoStok LSQ.MsgAcquired))) + [] + "The server can confirm that it has the state at the requested point." + , DocMsg + (BlockFetch.TraceLabelPeer protoPeer + (TraceSendMsg + (AnyMessageAndAgency protoStok + (LSQ.MsgFailure protoAcquireFailure)))) + [] + "The server can report that it cannot obtain the state for the\ + \requested point." + , DocMsg + (BlockFetch.TraceLabelPeer protoPeer + (TraceSendMsg + (AnyMessageAndAgency protoStok + (LSQ.MsgQuery (undefined :: query result))))) + [] + "The client can perform queries on the current acquired state." + , DocMsg + (BlockFetch.TraceLabelPeer protoPeer + (TraceSendMsg + (AnyMessageAndAgency protoStok + (LSQ.MsgResult (undefined :: query result) (undefined :: result))))) + [] + "The server must reply with the queries." + , DocMsg + (BlockFetch.TraceLabelPeer protoPeer + (TraceSendMsg + (AnyMessageAndAgency protoStok + LSQ.MsgRelease))) + [] + "The client can instruct the server to release the state. This lets\ + \the server free resources." + , DocMsg + (BlockFetch.TraceLabelPeer protoPeer + (TraceSendMsg + (AnyMessageAndAgency protoStok + (LSQ.MsgReAcquire Nothing)))) + [] + "This is like 'MsgAcquire' but for when the client already has a\ + \state. By moveing to another state directly without a 'MsgRelease' it\ + \enables optimisations on the server side (e.g. moving to the state for\ + \the immediate next block).\ + \\ + \Note that failure to re-acquire is equivalent to 'MsgRelease',\ + \rather than keeping the exiting acquired state.\ + \\ + \From 'NodeToClient_V8' onwards if the point is not specified, current tip\ + \will be acquired. For previous versions of the protocol 'point' must be\ + \given." + , DocMsg + (BlockFetch.TraceLabelPeer protoPeer + (TraceSendMsg + (AnyMessageAndAgency protoStok + LSQ.MsgDone))) + [] + "The client can terminate the protocol." + ] + +docTBlockFetch :: Documented + (BlockFetch.TraceLabelPeer peer + (TraceSendRecv + (BlockFetch x (Point blk)))) +docTBlockFetch = Documented [ + DocMsg + (BlockFetch.TraceLabelPeer protoPeer + (TraceSendMsg + (AnyMessageAndAgency protoStok + (MsgRequestRange protoChainRange)))) + [] + "Request range of blocks." + , DocMsg + (BlockFetch.TraceLabelPeer protoPeer + (TraceSendMsg + (AnyMessageAndAgency protoStok + MsgStartBatch))) + [] + "Start block streaming." + , DocMsg + (BlockFetch.TraceLabelPeer protoPeer + (TraceSendMsg + (AnyMessageAndAgency protoStok + MsgNoBlocks))) + [] + "Respond that there are no blocks." + , DocMsg + (BlockFetch.TraceLabelPeer protoPeer + (TraceSendMsg + (AnyMessageAndAgency protoStok + (MsgBlock undefined)))) + [] + "Stream a single block." + , DocMsg + (BlockFetch.TraceLabelPeer protoPeer + (TraceSendMsg + (AnyMessageAndAgency protoStok + MsgBatchDone))) + [] + "End of block streaming." + , DocMsg + (BlockFetch.TraceLabelPeer protoPeer + (TraceSendMsg + (AnyMessageAndAgency protoStok + MsgClientDone))) + [] + "Client termination message." + ] + +docTTxSubmissionNode :: Documented + (BlockFetch.TraceLabelPeer peer + (TraceSendRecv + (TXS.TxSubmission (GenTxId blk) (GenTx blk)))) +docTTxSubmissionNode = Documented [ + DocMsg + (BlockFetch.TraceLabelPeer protoPeer + (TraceSendMsg + (AnyMessageAndAgency protoStok + (TXS.MsgRequestTxIds protoTokBlockingStyle 1 1)))) + [] + "Request a non-empty list of transaction identifiers from the client,\ + \and confirm a number of outstanding transaction identifiers.\ + \\ + \With 'TokBlocking' this is a a blocking operation: the response will\ + \always have at least one transaction identifier, and it does not expect\ + \a prompt response: there is no timeout. This covers the case when there\ + \is nothing else to do but wait. For example this covers leaf nodes that\ + \rarely, if ever, create and submit a transaction.\ + \\ + \With 'TokNonBlocking' this is a non-blocking operation: the response\ + \may be an empty list and this does expect a prompt response. This\ + \covers high throughput use cases where we wish to pipeline, by\ + \interleaving requests for additional transaction identifiers with\ + \requests for transactions, which requires these requests not block.\ + \\ + \The request gives the maximum number of transaction identifiers that\ + \can be accepted in the response. This must be greater than zero in the\ + \'TokBlocking' case. In the 'TokNonBlocking' case either the numbers\ + \acknowledged or the number requested must be non-zero. In either case,\ + \the number requested must not put the total outstanding over the fixed\ + \protocol limit.\ + \\ + \The request also gives the number of outstanding transaction\ + \identifiers that can now be acknowledged. The actual transactions\ + \to acknowledge are known to the peer based on the FIFO order in which\ + \they were provided.\ + \\ + \There is no choice about when to use the blocking case versus the\ + \non-blocking case, it depends on whether there are any remaining\ + \unacknowledged transactions (after taking into account the ones\ + \acknowledged in this message):\ + \\ + \* The blocking case must be used when there are zero remaining\ + \ unacknowledged transactions.\ + \\ + \* The non-blocking case must be used when there are non-zero remaining\ + \ unacknowledged transactions." + , DocMsg + (BlockFetch.TraceLabelPeer protoPeer + (TraceSendMsg + (AnyMessageAndAgency protoStok + (TXS.MsgReplyTxIds protoBlockingReplyList)))) + [] + "Reply with a list of transaction identifiers for available\ + \transactions, along with the size of each transaction.\ + \\ + \The list must not be longer than the maximum number requested.\ + \\ + \In the 'StTxIds' 'StBlocking' state the list must be non-empty while\ + \in the 'StTxIds' 'StNonBlocking' state the list may be empty.\ + \\ + \These transactions are added to the notional FIFO of outstanding\ + \transaction identifiers for the protocol.\ + \\ + \The order in which these transaction identifiers are returned must be\ + \the order in which they are submitted to the mempool, to preserve\ + \dependent transactions." + , DocMsg + (BlockFetch.TraceLabelPeer protoPeer + (TraceSendMsg + (AnyMessageAndAgency protoStok + (TXS.MsgRequestTxs [protoTxId])))) + [] + "Request one or more transactions corresponding to the given \ + \transaction identifiers. \ + \\ + \While it is the responsibility of the replying peer to keep within \ + \pipelining in-flight limits, the sender must also cooperate by keeping \ + \the total requested across all in-flight requests within the limits. \ + \\ + \It is an error to ask for transaction identifiers that were not \ + \previously announced (via 'MsgReplyTxIds'). \ + \\ + \It is an error to ask for transaction identifiers that are not \ + \outstanding or that were already asked for." + , DocMsg + (BlockFetch.TraceLabelPeer protoPeer + (TraceSendMsg + (AnyMessageAndAgency protoStok + (TXS.MsgReplyTxs [protoTx])))) + [] + "Reply with the requested transactions, or implicitly discard.\ + \\ + \Transactions can become invalid between the time the transaction \ + \identifier was sent and the transaction being requested. Invalid \ + \(including committed) transactions do not need to be sent.\ + \\ + \Any transaction identifiers requested but not provided in this reply \ + \should be considered as if this peer had never announced them. (Note \ + \that this is no guarantee that the transaction is invalid, it may still \ + \be valid and available from another peer)." + , DocMsg + (BlockFetch.TraceLabelPeer protoPeer + (TraceSendMsg + (AnyMessageAndAgency protoStok + TXS.MsgDone))) + [] + "Termination message, initiated by the client when the server is \ + \making a blocking call for more transaction identifiers." + --TODO: Can't use 'MsgKThxBye' because NodeToNodeV_2 is not introduced yet. + ] + +docTTxSubmission2Node :: Documented + (BlockFetch.TraceLabelPeer peer + (TraceSendRecv + (TXS.TxSubmission2 (GenTxId blk) (GenTx blk)))) +docTTxSubmission2Node = Documented [ + DocMsg + (BlockFetch.TraceLabelPeer protoPeer + (TraceSendMsg + (AnyMessageAndAgency protoStok + MsgHello))) + [] + "Client side hello message." + , DocMsg + (BlockFetch.TraceLabelPeer protoPeer + (TraceSendMsg + (AnyMessageAndAgency protoStok + (MsgTalk (TXS.MsgRequestTxIds protoTokBlockingStyle 1 1))))) + [] + "Request a non-empty list of transaction identifiers from the client, \ + \and confirm a number of outstanding transaction identifiers. \ + \\ + \With 'TokBlocking' this is a a blocking operation: the response will \ + \always have at least one transaction identifier, and it does not expect \ + \a prompt response: there is no timeout. This covers the case when there \ + \is nothing else to do but wait. For example this covers leaf nodes that \ + \rarely, if ever, create and submit a transaction. \ + \\ + \With 'TokNonBlocking' this is a non-blocking operation: the response \ + \may be an empty list and this does expect a prompt response. This \ + \covers high throughput use cases where we wish to pipeline, by \ + \interleaving requests for additional transaction identifiers with \ + \requests for transactions, which requires these requests not block. \ + \\ + \The request gives the maximum number of transaction identifiers that \ + \can be accepted in the response. This must be greater than zero in the \ + \'TokBlocking' case. In the 'TokNonBlocking' case either the numbers \ + \acknowledged or the number requested must be non-zero. In either case, \ + \the number requested must not put the total outstanding over the fixed \ + \protocol limit. \ + \\ + \The request also gives the number of outstanding transaction \ + \identifiers that can now be acknowledged. The actual transactions \ + \to acknowledge are known to the peer based on the FIFO order in which \ + \they were provided. \ + \\ + \There is no choice about when to use the blocking case versus the \ + \non-blocking case, it depends on whether there are any remaining \ + \unacknowledged transactions (after taking into account the ones \ + \acknowledged in this message): \ + \\ + \* The blocking case must be used when there are zero remaining \ + \ unacknowledged transactions. \ + \\ + \* The non-blocking case must be used when there are non-zero remaining \ + \ unacknowledged transactions." + , DocMsg + (BlockFetch.TraceLabelPeer protoPeer + (TraceSendMsg + (AnyMessageAndAgency protoStok + (MsgTalk (TXS.MsgReplyTxIds protoBlockingReplyList))))) + [] + "Reply with a list of transaction identifiers for available\ + \transactions, along with the size of each transaction.\ + \\ + \The list must not be longer than the maximum number requested.\ + \\ + \In the 'StTxIds' 'StBlocking' state the list must be non-empty while\ + \in the 'StTxIds' 'StNonBlocking' state the list may be empty.\ + \\ + \These transactions are added to the notional FIFO of outstanding\ + \transaction identifiers for the protocol.\ + \\ + \The order in which these transaction identifiers are returned must be\ + \the order in which they are submitted to the mempool, to preserve\ + \dependent transactions." + , DocMsg + (BlockFetch.TraceLabelPeer protoPeer + (TraceSendMsg + (AnyMessageAndAgency protoStok + (MsgTalk (TXS.MsgRequestTxs [protoTxId]))))) + [] + "Request one or more transactions corresponding to the given \ + \transaction identifiers. \ + \\ + \While it is the responsibility of the replying peer to keep within\ + \pipelining in-flight limits, the sender must also cooperate by keeping\ + \the total requested across all in-flight requests within the limits.\ + \\ + \It is an error to ask for transaction identifiers that were not\ + \previously announced (via 'MsgReplyTxIds').\ + \\ + \It is an error to ask for transaction identifiers that are not\ + \outstanding or that were already asked for." + , DocMsg + (BlockFetch.TraceLabelPeer protoPeer + (TraceSendMsg + (AnyMessageAndAgency protoStok + (MsgTalk (TXS.MsgReplyTxs [protoTx]))))) + [] + "Reply with the requested transactions, or implicitly discard.\ + \\ + \Transactions can become invalid between the time the transaction\ + \identifier was sent and the transaction being requested. Invalid\ + \(including committed) transactions do not need to be sent.\ + \\ + \Any transaction identifiers requested but not provided in this reply\ + \should be considered as if this peer had never announced them. (Note\ + \that this is no guarantee that the transaction is invalid, it may still\ + \be valid and available from another peer)." + , DocMsg + (BlockFetch.TraceLabelPeer protoPeer + (TraceSendMsg + (AnyMessageAndAgency protoStok + (MsgTalk TXS.MsgDone)))) + [] + "Termination message, initiated by the client when the server is\ + \making a blocking call for more transaction identifiers." + --TODO: Can't use 'MsgKThxBye' because NodeToNodeV_2 is not introduced yet. + ] + +docIPSubscription :: Documented (WithIPList (SubscriptionTrace Socket.SockAddr)) +docIPSubscription = Documented $ map withIPList (undoc docSubscription) + where + withIPList (DocMsg v nl comment) = + DocMsg (WithIPList protoLocalAdresses [] v) nl ("IP Subscription: " <> comment) + +docDNSSubscription :: Documented (WithDomainName (SubscriptionTrace Socket.SockAddr)) +docDNSSubscription = Documented $ map withDomainName (undoc docSubscription) + where + withDomainName (DocMsg v nl comment) = + DocMsg (WithDomainName protoDomain v) nl ("DNS Subscription: " <> comment) + +docSubscription :: Documented (SubscriptionTrace Socket.SockAddr) +docSubscription = Documented [ + DocMsg + (SubscriptionTraceConnectStart protoSockAddr) + [] + "Connection Attempt Start with destination." + , DocMsg + (SubscriptionTraceConnectEnd protoSockAddr protoRes) + [] + "Connection Attempt end with destination and outcome." + , DocMsg + (SubscriptionTraceSocketAllocationException protoSockAddr protoException) + [] + "Socket Allocation Exception with destination and the exception." + , DocMsg + (SubscriptionTraceConnectException protoSockAddr protoException) + [] + "Connection Attempt Exception with destination and exception." + , DocMsg + (SubscriptionTraceTryConnectToPeer protoSockAddr) + [] + "Trying to connect to peer with address." + , DocMsg + (SubscriptionTraceSkippingPeer protoSockAddr) + [] + "Skipping peer with address." + , DocMsg + SubscriptionTraceSubscriptionRunning + [] + "Required subscriptions started." + , DocMsg + (SubscriptionTraceSubscriptionWaiting 1) + [] + "Waiting on address with active connections." + , DocMsg + SubscriptionTraceSubscriptionFailed + [] + "Failed to start all required subscriptions." + , DocMsg + (SubscriptionTraceSubscriptionWaitingNewConnection protoDiffTime) + [] + "Waiting delay time before attempting a new connection." + , DocMsg + (SubscriptionTraceStart 1) + [] + "Starting Subscription Worker with a valency." + , DocMsg + (SubscriptionTraceRestart protoDiffTime 1 2) + [] + "Restarting Subscription after duration with desired valency and\ + \ current valency." + , DocMsg + (SubscriptionTraceConnectionExist protoSockAddr) + [] + "Connection exists to destination." + , DocMsg + (SubscriptionTraceUnsupportedRemoteAddr protoSockAddr) + [] + "Unsupported remote target address." + , DocMsg + SubscriptionTraceMissingLocalAddress + [] + "Missing local address." + , DocMsg + (SubscriptionTraceApplicationException protoSockAddr protoException) + [] + "Application Exception occured." + , DocMsg + (SubscriptionTraceAllocateSocket protoSockAddr) + [] + "Allocate socket to address." + , DocMsg + (SubscriptionTraceCloseSocket protoSockAddr) + [] + "Closed socket to address." + ] + +docDNSResolver :: Documented (WithDomainName DnsTrace) +docDNSResolver = Documented [ + DocMsg + (WithDomainName protoDomain + (DnsTraceLookupException protoSomeException)) + [] + "A DNS lookup exception occured." + , DocMsg + (WithDomainName protoDomain + (DnsTraceLookupAError protoDNSError)) + [] + "A lookup failed with an error." + , DocMsg + (WithDomainName protoDomain + (DnsTraceLookupAAAAError protoDNSError)) + [] + "AAAA lookup failed with an error." + , DocMsg + (WithDomainName protoDomain + DnsTraceLookupIPv4First) + [] + "Returning IPv4 address first." + , DocMsg + (WithDomainName protoDomain + DnsTraceLookupIPv6First) + [] + "Returning IPv6 address first." + , DocMsg + (WithDomainName protoDomain + DnsTraceLookupIPv6First) + [] + "Returning IPv6 address first." + , DocMsg + (WithDomainName protoDomain + (DnsTraceLookupAResult [protoSockAddr])) + [] + "Lookup A result." + , DocMsg + (WithDomainName protoDomain + (DnsTraceLookupAAAAResult [protoSockAddr])) + [] + "Lookup AAAA result." + ] + +docErrorPolicy :: Documented (WithAddr Socket.SockAddr ErrorPolicyTrace) +docErrorPolicy = docErrorPolicy' protoSockAddr + +docLocalErrorPolicy :: Documented (WithAddr LocalAddress ErrorPolicyTrace) +docLocalErrorPolicy = docErrorPolicy' protoLocalAdress + +docErrorPolicy' :: adr -> Documented (WithAddr adr ErrorPolicyTrace) +docErrorPolicy' adr = Documented [ + DocMsg + (WithAddr adr + (ErrorPolicySuspendPeer Nothing protoDiffTime protoDiffTime)) + [] + "Suspending peer with a given exception." + , DocMsg + (WithAddr adr + (ErrorPolicySuspendConsumer Nothing protoDiffTime)) + [] + "Suspending consumer." + , DocMsg + (WithAddr adr + (ErrorPolicyLocalNodeError undefined)) + [] + "caught a local exception." + , DocMsg + (WithAddr adr + ErrorPolicyResumePeer) + [] + "Resume a peer (both consumer and producer)." + , DocMsg + (WithAddr adr + ErrorPolicyKeepSuspended) + [] + "Consumer was suspended until producer will resume." + , DocMsg + (WithAddr adr + ErrorPolicyResumeConsumer) + [] + "Resume consumer." + , DocMsg + (WithAddr adr + ErrorPolicyResumeProducer) + [] + "Resume producer." + , DocMsg + (WithAddr adr + (ErrorPolicyUnhandledApplicationException undefined)) + [] + "An application throwed an exception, which was not handled." + , DocMsg + (WithAddr adr + (ErrorPolicyUnhandledConnectionException undefined)) + [] + "'connect' throwed an exception, which was not handled by any\ + \ 'ErrorPolicy'." + , DocMsg + (WithAddr adr + (ErrorPolicyAcceptException undefined)) + [] + "'accept' throwed an exception." + ] + +docAcceptPolicy :: Documented NtN.AcceptConnectionsPolicyTrace +docAcceptPolicy = Documented [ + DocMsg + (NtN.ServerTraceAcceptConnectionRateLimiting protoDiffTime 2) + [] + "Rate limiting accepting connections,\ + \ delaying next accept for given time, currently serving n connections." + , DocMsg + (NtN.ServerTraceAcceptConnectionHardLimit 2) + [] + "Hard rate limit reached,\ + \ waiting until the number of connections drops below n." + ] + +docMux :: Documented (WithMuxBearer peer MuxTrace) +docMux = Documented [ + DocMsg + (WithMuxBearer protoPeer + MuxTraceRecvHeaderStart) + [] + "Bearer receive header start." + , DocMsg + (WithMuxBearer protoPeer + (MuxTraceRecvHeaderEnd protoMuxSDUHeader)) + [] + "Bearer receive header end." + , DocMsg + (WithMuxBearer protoPeer + (MuxTraceRecvDeltaQObservation protoMuxSDUHeader protoTime)) + [] + "Bearer DeltaQ observation." + , DocMsg + (WithMuxBearer protoPeer + (MuxTraceRecvDeltaQSample 1.0 1 1 1.0 1.0 1.0 1.0 "")) + [] + "Bearer DeltaQ sample." + , DocMsg + (WithMuxBearer protoPeer + (MuxTraceRecvStart 1)) + [] + "Bearer receive start." + , DocMsg + (WithMuxBearer protoPeer + (MuxTraceRecvEnd 1)) + [] + "Bearer receive end." + , DocMsg + (WithMuxBearer protoPeer + (MuxTraceSendStart protoMuxSDUHeader)) + [] + "Bearer send start." + , DocMsg + (WithMuxBearer protoPeer + MuxTraceSendEnd) + [] + "Bearer send end." + , DocMsg + (WithMuxBearer protoPeer + (MuxTraceState protoMuxBearerState)) + [] + "State." + , DocMsg + (WithMuxBearer protoPeer + (MuxTraceCleanExit protoMiniProtocolNum protoMiniProtocolDir)) + [] + "Miniprotocol terminated cleanly." + , DocMsg + (WithMuxBearer protoPeer + (MuxTraceExceptionExit + protoMiniProtocolNum protoMiniProtocolDir protoSomeException)) + [] + "Miniprotocol terminated with exception." + , DocMsg + (WithMuxBearer protoPeer + (MuxTraceChannelRecvStart protoMiniProtocolNum)) + [] + "Channel receive start." + , DocMsg + (WithMuxBearer protoPeer + (MuxTraceChannelRecvEnd protoMiniProtocolNum 1)) + [] + "Channel receive end." + , DocMsg + (WithMuxBearer protoPeer + (MuxTraceChannelSendStart protoMiniProtocolNum 1)) + [] + "Channel send start." + , DocMsg + (WithMuxBearer protoPeer + (MuxTraceChannelSendEnd protoMiniProtocolNum)) + [] + "Channel send end." + , DocMsg + (WithMuxBearer protoPeer + MuxTraceHandshakeStart) + [] + "Handshake start." + , DocMsg + (WithMuxBearer protoPeer + (MuxTraceHandshakeClientEnd protoDiffTime)) + [] + "Handshake client end." + , DocMsg + (WithMuxBearer protoPeer + (MuxTraceHandshakeClientError protoSomeException protoDiffTime)) + [] + "Handshake client error." + , DocMsg + (WithMuxBearer protoPeer + (MuxTraceHandshakeServerError protoSomeException)) + [] + "Handshake server error." + , DocMsg + (WithMuxBearer protoPeer + MuxTraceSDUReadTimeoutException) + [] + "Timed out reading SDU." + , DocMsg + (WithMuxBearer protoPeer + MuxTraceSDUWriteTimeoutException) + [] + "Timed out writing SDU." + , DocMsg + (WithMuxBearer protoPeer + (MuxTraceStartEagerly protoMiniProtocolNum protoMiniProtocolDir)) + [] + "Eagerly started." + , DocMsg + (WithMuxBearer protoPeer + (MuxTraceStartOnDemand protoMiniProtocolNum protoMiniProtocolDir)) + [] + "Preparing to start." + , DocMsg + (WithMuxBearer protoPeer + (MuxTraceStartedOnDemand protoMiniProtocolNum protoMiniProtocolDir)) + [] + "Started on demand." + , DocMsg + (WithMuxBearer protoPeer + (MuxTraceTerminating protoMiniProtocolNum protoMiniProtocolDir)) + [] + "Terminating." + , DocMsg + (WithMuxBearer protoPeer + MuxTraceShutdown) + [] + "Mux shutdown." + ] + +docHandshake :: Documented NtN.HandshakeTr +docHandshake = Documented [ + DocMsg + (WithMuxBearer protoPeer + (TraceSendMsg + (AnyMessageAndAgency protoStok + (HS.MsgProposeVersions Map.empty)))) + [] + "Propose versions together with version parameters. It must be\ + \ encoded to a sorted list.." + , DocMsg + (WithMuxBearer protoPeer + (TraceSendMsg + (AnyMessageAndAgency protoStok + (HS.MsgAcceptVersion protoNodeToNodeVersion protoCBORTerm)))) + [] + "The remote end decides which version to use and sends chosen version.\ + \The server is allowed to modify version parameters." + , DocMsg + (WithMuxBearer protoPeer + (TraceSendMsg + (AnyMessageAndAgency protoStok + (HS.MsgRefuse protoRefuseReason)))) + [] + "It refuses to run any version." + ] + +docLocalHandshake :: Documented NtC.HandshakeTr +docLocalHandshake = Documented [ + DocMsg + (WithMuxBearer protoPeer + (TraceSendMsg + (AnyMessageAndAgency protoStok + (HS.MsgProposeVersions Map.empty)))) + [] + "Propose versions together with version parameters. It must be\ + \ encoded to a sorted list.." + , DocMsg + (WithMuxBearer protoPeer + (TraceSendMsg + (AnyMessageAndAgency protoStok + (HS.MsgAcceptVersion protoNodeToClientVersion protoCBORTerm)))) + [] + "The remote end decides which version to use and sends chosen version.\ + \The server is allowed to modify version parameters." + , DocMsg + (WithMuxBearer protoPeer + (TraceSendMsg + (AnyMessageAndAgency protoStok + (HS.MsgRefuse protoLocalRefuseReason)))) + [] + "It refuses to run any version." + ] + +docDiffusionInit :: Documented ND.DiffusionInitializationTracer +docDiffusionInit = Documented [ + DocMsg + (ND.RunServer protoSockAddr) + [] + "RunServer TODO" + , DocMsg + (ND.RunLocalServer protoLocalAddress) + [] + "RunLocalServer TODO" + , DocMsg + (ND.UsingSystemdSocket protoFilePath) + [] + "UsingSystemdSocket TODO" + , DocMsg + (ND.CreateSystemdSocketForSnocketPath protoFilePath) + [] + "CreateSystemdSocketForSnocketPath TODO" + , DocMsg + (ND.CreatedLocalSocket protoFilePath) + [] + "CreatedLocalSocket TODO" + , DocMsg + (ND.ConfiguringLocalSocket protoFilePath protoFileDescriptor) + [] + "ConfiguringLocalSocket TODO" + , DocMsg + (ND.ListeningLocalSocket protoFilePath protoFileDescriptor) + [] + "ListeningLocalSocket TODO" + , DocMsg + (ND.LocalSocketUp protoFilePath protoFileDescriptor) + [] + "LocalSocketUp TODO" + , DocMsg + (ND.CreatingServerSocket protoSockAddr) + [] + "CreatingServerSocket TODO" + , DocMsg + (ND.ConfiguringServerSocket protoSockAddr) + [] + "ConfiguringServerSocket TODO" + , DocMsg + (ND.ListeningServerSocket protoSockAddr) + [] + "ListeningServerSocket TODO" + , DocMsg + (ND.ServerSocketUp protoSockAddr) + [] + "ServerSocketUp TODO" + , DocMsg + (ND.UnsupportedLocalSystemdSocket protoSockAddr) + [] + "UnsupportedLocalSystemdSocket TODO" + , DocMsg + ND.UnsupportedReadySocketCase + [] + "UnsupportedReadySocketCase TODO" + , DocMsg + (ND.DiffusionErrored protoSomeException) + [] + "DiffusionErrored TODO" + ] diff --git a/cardano-node/src/Cardano/TraceDispatcher/Network/Formatting.hs b/cardano-node/src/Cardano/TraceDispatcher/Network/Formatting.hs new file mode 100644 index 00000000000..1242a772b9c --- /dev/null +++ b/cardano-node/src/Cardano/TraceDispatcher/Network/Formatting.hs @@ -0,0 +1,489 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + + +{-# OPTIONS_GHC -Wno-orphans #-} + +module Cardano.TraceDispatcher.Network.Formatting + ( + ) where + +import Data.Aeson (Value (String), toJSON, (.=)) +import qualified Data.IP as IP +import Data.Text (pack) +import Network.Mux (MuxTrace (..), WithMuxBearer (..)) +import qualified Network.Socket as Socket +import Text.Show + +import Cardano.TraceDispatcher.Era.ConvertTxId +import Cardano.TraceDispatcher.Formatting () +import Cardano.TraceDispatcher.Render + +import Cardano.Logging +import Cardano.Prelude hiding (Show, show) + +import Ouroboros.Consensus.Block (ConvertRawHash, GetHeader, + getHeader) +import Ouroboros.Consensus.Ledger.Query (Query) +import Ouroboros.Consensus.Ledger.SupportsMempool (GenTx, HasTxId, + HasTxs, LedgerSupportsMempool, extractTxs, txId) +import Ouroboros.Consensus.Node.Run (SerialiseNodeToNodeConstraints, + estimateBlockSize) + +import Ouroboros.Network.Block (HasHeader, Point, Serialised, + blockHash) +import Ouroboros.Network.Codec (AnyMessageAndAgency (..)) +import Ouroboros.Network.Codec (PeerHasAgency (..)) +import qualified Ouroboros.Network.Diffusion as ND +import Ouroboros.Network.Driver.Simple (TraceSendRecv (..)) +import qualified Ouroboros.Network.NodeToClient as NtC +import qualified Ouroboros.Network.NodeToNode as NtN +import Ouroboros.Network.Protocol.BlockFetch.Type +import Ouroboros.Network.Protocol.ChainSync.Type as ChainSync +import qualified Ouroboros.Network.Protocol.LocalStateQuery.Type as LSQ +import qualified Ouroboros.Network.Protocol.LocalTxSubmission.Type as LTS +import Ouroboros.Network.Protocol.Trans.Hello.Type + (ClientHasAgency (..), Message (..), ServerHasAgency (..)) +import qualified Ouroboros.Network.Protocol.TxSubmission.Type as STX +import qualified Ouroboros.Network.Protocol.TxSubmission2.Type as TXS +import Ouroboros.Network.Snocket (LocalAddress (..)) +import Ouroboros.Network.Subscription.Dns (DnsTrace (..), + WithDomainName (..)) +import Ouroboros.Network.Subscription.Ip (SubscriptionTrace, + WithIPList (..)) + + +instance LogFormatting (AnyMessageAndAgency ps) + => LogFormatting (TraceSendRecv ps) where + forMachine dtal (TraceSendMsg m) = mkObject + [ "kind" .= String "Send" , "msg" .= forMachine dtal m ] + forMachine dtal (TraceRecvMsg m) = mkObject + [ "kind" .= String "Recv" , "msg" .= forMachine dtal m ] + + forHuman (TraceSendMsg m) = "Send: " <> forHuman m + forHuman (TraceRecvMsg m) = "Receive: " <> forHuman m + + asMetrics (TraceSendMsg m) = asMetrics m + asMetrics (TraceRecvMsg m) = asMetrics m + +instance LogFormatting (AnyMessageAndAgency (ChainSync blk pt tip)) where + forMachine _dtal (AnyMessageAndAgency stok ChainSync.MsgRequestNext{}) = + mkObject [ "kind" .= String "MsgRequestNext" + , "agency" .= String (pack $ show stok) + ] + forMachine _dtal (AnyMessageAndAgency stok ChainSync.MsgAwaitReply{}) = + mkObject [ "kind" .= String "MsgAwaitReply" + , "agency" .= String (pack $ show stok) + ] + forMachine _dtal (AnyMessageAndAgency stok ChainSync.MsgRollForward{}) = + mkObject [ "kind" .= String "MsgRollForward" + , "agency" .= String (pack $ show stok) + ] + forMachine _dtal (AnyMessageAndAgency stok ChainSync.MsgRollBackward{}) = + mkObject [ "kind" .= String "MsgRollBackward" + , "agency" .= String (pack $ show stok) + ] + forMachine _dtal (AnyMessageAndAgency stok ChainSync.MsgFindIntersect{}) = + mkObject [ "kind" .= String "MsgFindIntersect" + , "agency" .= String (pack $ show stok) + ] + forMachine _dtal (AnyMessageAndAgency stok ChainSync.MsgIntersectFound{}) = + mkObject [ "kind" .= String "MsgIntersectFound" + , "agency" .= String (pack $ show stok) + ] + forMachine _dtal (AnyMessageAndAgency stok ChainSync.MsgIntersectNotFound{}) = + mkObject [ "kind" .= String "MsgIntersectNotFound" + , "agency" .= String (pack $ show stok) + ] + forMachine _dtal (AnyMessageAndAgency stok ChainSync.MsgDone{}) = + mkObject [ "kind" .= String "MsgDone" + , "agency" .= String (pack $ show stok) + ] + +instance LogFormatting (AnyMessageAndAgency (LTS.LocalTxSubmission tx err)) where + forMachine _dtal (AnyMessageAndAgency stok LTS.MsgSubmitTx{}) = + mkObject [ "kind" .= String "MsgSubmitTx" + , "agency" .= String (pack $ show stok) + ] + forMachine _dtal (AnyMessageAndAgency stok LTS.MsgAcceptTx{}) = + mkObject [ "kind" .= String "MsgAcceptTx" + , "agency" .= String (pack $ show stok) + ] + forMachine _dtal (AnyMessageAndAgency stok LTS.MsgRejectTx{}) = + mkObject [ "kind" .= String "MsgRejectTx" + , "agency" .= String (pack $ show stok) + ] + forMachine _dtal (AnyMessageAndAgency stok LTS.MsgDone{}) = + mkObject [ "kind" .= String "MsgDone" + , "agency" .= String (pack $ show stok) + ] + + +instance (forall result. Show (Query blk result)) + => LogFormatting (AnyMessageAndAgency (LSQ.LocalStateQuery blk pt (Query blk))) where + forMachine _dtal (AnyMessageAndAgency stok LSQ.MsgAcquire{}) = + mkObject [ "kind" .= String "MsgAcquire" + , "agency" .= String (pack $ show stok) + ] + forMachine _dtal (AnyMessageAndAgency stok LSQ.MsgAcquired{}) = + mkObject [ "kind" .= String "MsgAcquired" + , "agency" .= String (pack $ show stok) + ] + forMachine _dtal (AnyMessageAndAgency stok LSQ.MsgFailure{}) = + mkObject [ "kind" .= String "MsgFailure" + , "agency" .= String (pack $ show stok) + ] + forMachine _dtal (AnyMessageAndAgency stok LSQ.MsgQuery{}) = + mkObject [ "kind" .= String "MsgQuery" + , "agency" .= String (pack $ show stok) + ] + forMachine _dtal (AnyMessageAndAgency stok LSQ.MsgResult{}) = + mkObject [ "kind" .= String "MsgResult" + , "agency" .= String (pack $ show stok) + ] + forMachine _dtal (AnyMessageAndAgency stok LSQ.MsgRelease{}) = + mkObject [ "kind" .= String "MsgRelease" + , "agency" .= String (pack $ show stok) + ] + forMachine _dtal (AnyMessageAndAgency stok LSQ.MsgReAcquire{}) = + mkObject [ "kind" .= String "MsgReAcquire" + , "agency" .= String (pack $ show stok) + ] + forMachine _dtal (AnyMessageAndAgency stok LSQ.MsgDone{}) = + mkObject [ "kind" .= String "MsgDone" + , "agency" .= String (pack $ show stok) + ] + +-- +-- | instances of @forMachine@ +-- +-- NOTE: this list is sorted by the unqualified name of the outermost type. + +instance ( ConvertTxId' blk + , ConvertRawHash blk + , HasHeader blk + , GetHeader blk + , HasTxId (GenTx blk) + , SerialiseNodeToNodeConstraints blk + , HasTxs blk + , LedgerSupportsMempool blk + ) + => LogFormatting (AnyMessageAndAgency (BlockFetch blk (Point blk))) where + forMachine DMinimal (AnyMessageAndAgency stok (MsgBlock blk)) = + mkObject [ "kind" .= String "MsgBlock" + , "agency" .= String (pack $ show stok) + , "blockHash" .= renderHeaderHash (Proxy @blk) (blockHash blk) + , "blockSize" .= toJSON (estimateBlockSize (getHeader blk)) + ] + + forMachine dtal (AnyMessageAndAgency stok (MsgBlock blk)) = + mkObject [ "kind" .= String "MsgBlock" + , "agency" .= String (pack $ show stok) + , "blockHash" .= renderHeaderHash (Proxy @blk) (blockHash blk) + , "blockSize" .= toJSON (estimateBlockSize (getHeader blk)) + , "txIds" .= toJSON (presentTx <$> extractTxs blk) + ] + where + presentTx :: GenTx blk -> Value + presentTx = String . renderTxIdForDetails dtal . txId + + forMachine _v (AnyMessageAndAgency stok MsgRequestRange{}) = + mkObject [ "kind" .= String "MsgRequestRange" + , "agency" .= String (pack $ show stok) + ] + forMachine _v (AnyMessageAndAgency stok MsgStartBatch{}) = + mkObject [ "kind" .= String "MsgStartBatch" + , "agency" .= String (pack $ show stok) + ] + forMachine _v (AnyMessageAndAgency stok MsgNoBlocks{}) = + mkObject [ "kind" .= String "MsgNoBlocks" + , "agency" .= String (pack $ show stok) + ] + forMachine _v (AnyMessageAndAgency stok MsgBatchDone{}) = + mkObject [ "kind" .= String "MsgBatchDone" + , "agency" .= String (pack $ show stok) + ] + forMachine _v (AnyMessageAndAgency stok MsgClientDone{}) = + mkObject [ "kind" .= String "MsgClientDone" + , "agency" .= String (pack $ show stok) + ] + +instance ( ConvertTxId' blk + , HasTxId (GenTx blk) + , ConvertRawHash blk + , HasTxs blk + ) + => LogFormatting (AnyMessageAndAgency (BlockFetch (Serialised blk) (Point blk))) where + forMachine DMinimal (AnyMessageAndAgency stok (MsgBlock _blk)) = + mkObject [ "kind" .= String "MsgBlock" + , "agency" .= String (pack $ show stok) + -- , "blockHash" .= renderHeaderHash (Proxy @blk) (blockHash blk) + -- , "blockSize" .= toJSON (estimateBlockSize (getHeader blk)) + ] + + forMachine _dtal (AnyMessageAndAgency stok (MsgBlock _blk)) = + mkObject [ "kind" .= String "MsgBlock" + , "agency" .= String (pack $ show stok) + -- TODO + -- , "blockHash" .= renderHeaderHash (Proxy @blk) (blockHash blk) + -- , "blockSize" .= toJSON (estimateBlockSize (getHeader blk)) + -- , "txIds" .= toJSON (presentTx <$> extractTxs blk) + ] + -- where + -- presentTx :: GenTx blk -> Value + -- presentTx = String . renderTxIdForDetails dtal . txId + + forMachine _v (AnyMessageAndAgency stok MsgRequestRange{}) = + mkObject [ "kind" .= String "MsgRequestRange" + , "agency" .= String (pack $ show stok) + ] + forMachine _v (AnyMessageAndAgency stok MsgStartBatch{}) = + mkObject [ "kind" .= String "MsgStartBatch" + , "agency" .= String (pack $ show stok) + ] + forMachine _v (AnyMessageAndAgency stok MsgNoBlocks{}) = + mkObject [ "kind" .= String "MsgNoBlocks" + , "agency" .= String (pack $ show stok) + ] + forMachine _v (AnyMessageAndAgency stok MsgBatchDone{}) = + mkObject [ "kind" .= String "MsgBatchDone" + , "agency" .= String (pack $ show stok) + ] + forMachine _v (AnyMessageAndAgency stok MsgClientDone{}) = + mkObject [ "kind" .= String "MsgClientDone" + , "agency" .= String (pack $ show stok) + ] + +instance (Show txid, Show tx) + => LogFormatting (AnyMessageAndAgency (STX.TxSubmission txid tx)) where + forMachine _dtal (AnyMessageAndAgency stok (STX.MsgRequestTxs txids)) = + mkObject + [ "kind" .= String "MsgRequestTxs" + , "agency" .= String (pack $ show stok) + , "txIds" .= String (pack $ show txids) + ] + forMachine _dtal (AnyMessageAndAgency stok (STX.MsgReplyTxs txs)) = + mkObject + [ "kind" .= String "MsgReplyTxs" + , "agency" .= String (pack $ show stok) + , "txs" .= String (pack $ show txs) + ] + forMachine _dtal (AnyMessageAndAgency stok (STX.MsgRequestTxIds _ _ _)) = + mkObject + [ "kind" .= String "MsgRequestTxIds" + , "agency" .= String (pack $ show stok) + ] + forMachine _dtal (AnyMessageAndAgency stok (STX.MsgReplyTxIds _)) = + mkObject + [ "kind" .= String "MsgReplyTxIds" + , "agency" .= String (pack $ show stok) + ] + forMachine _dtal (AnyMessageAndAgency stok STX.MsgDone) = + mkObject + [ "kind" .= String "MsgDone" + , "agency" .= String (pack $ show stok) + ] + +instance (Show txid, Show tx) + => LogFormatting (AnyMessageAndAgency (TXS.TxSubmission2 txid tx)) where + forMachine _dtal (AnyMessageAndAgency + -- we need this pattern match for GHC to recognise this + -- function as total. + stok@(ClientAgency TokHello) + MsgHello) = + mkObject + [ "kind" .= String "MsgHello" + , "agency" .= String (pack $ show stok) + ] + forMachine dtal (AnyMessageAndAgency + (ClientAgency (TokClientTalk stok)) + (MsgTalk msg)) = + forMachine dtal (AnyMessageAndAgency (ClientAgency stok) msg) + forMachine dtal (AnyMessageAndAgency + (ServerAgency (TokServerTalk stok)) + (MsgTalk msg)) = + forMachine dtal (AnyMessageAndAgency (ServerAgency stok) msg) + +instance LogFormatting (WithIPList (SubscriptionTrace Socket.SockAddr)) where + forMachine _dtal (WithIPList localAddresses dests ev) = + mkObject [ "kind" .= String "IP SubscriptionTrace" + , "localAddresses" .= String (pack $ show localAddresses) + , "dests" .= String (pack $ show dests) + , "event" .= String (pack $ show ev)] + forHuman (WithIPList localAddresses dests ev) = + pack (show ev) + <> ". Local addresses are " + <> (pack $ show localAddresses) + <> ". Destinations are " + <> (pack $ show dests) + <> "." + +instance LogFormatting (WithDomainName (SubscriptionTrace Socket.SockAddr)) where + forMachine _dtal (WithDomainName dom ev) = + mkObject [ "kind" .= String "DNS SubscriptionTrace" + , "domain" .= String (pack $ show dom) + , "event" .= String (pack $ show ev)] + forHuman (WithDomainName dom ev) = + pack (show ev) + <> ". Domain is " + <> pack (show dom) + <> "." + +instance LogFormatting (WithDomainName DnsTrace) where + forMachine _dtal (WithDomainName dom ev) = + mkObject [ "kind" .= String "DnsTrace" + , "domain" .= String (pack $ show dom) + , "event" .= String (pack $ show ev)] + forHuman (WithDomainName dom ev) = + pack (show ev) + <> ". Domain is " + <> pack (show dom) + <> "." + +instance LogFormatting NtN.RemoteAddress where + forMachine _dtal (Socket.SockAddrInet port addr) = + let ip = IP.fromHostAddress addr in + mkObject [ "addr" .= show ip + , "port" .= show port + ] + forMachine _dtal (Socket.SockAddrInet6 port _ addr _) = + let ip = IP.fromHostAddress6 addr in + mkObject [ "addr" .= show ip + , "port" .= show port + ] + forMachine _dtal (Socket.SockAddrUnix path) = + mkObject [ "path" .= show path ] + + +instance LogFormatting NtN.RemoteConnectionId where + forMachine dtal (NtN.ConnectionId l r) = + mkObject [ "local" .= forMachine dtal l + , "remote" .= forMachine dtal r + ] + +instance LogFormatting LocalAddress where + forMachine _dtal (LocalAddress path) = + mkObject ["path" .= path] + +instance LogFormatting NtC.LocalConnectionId where + forMachine dtal (NtC.ConnectionId l r) = + mkObject [ "local" .= forMachine dtal l + , "remote" .= forMachine dtal r + ] + +instance Show addr => LogFormatting (NtN.WithAddr addr NtN.ErrorPolicyTrace) where + forMachine _dtal (NtN.WithAddr addr ev) = + mkObject [ "kind" .= String "ErrorPolicyTrace" + , "address" .= show addr + , "event" .= show ev ] + forHuman (NtN.WithAddr addr ev) = "With address " <> showT addr <> ". " <> showT ev + +instance LogFormatting NtN.AcceptConnectionsPolicyTrace where + forMachine _dtal (NtN.ServerTraceAcceptConnectionRateLimiting delay numOfConnections) = + mkObject [ "kind" .= String "ServerTraceAcceptConnectionRateLimiting" + , "delay" .= show delay + , "numberOfConnection" .= show numOfConnections + ] + forMachine _dtal (NtN.ServerTraceAcceptConnectionHardLimit softLimit) = + mkObject [ "kind" .= String "ServerTraceAcceptConnectionHardLimit" + , "softLimit" .= show softLimit + ] + forHuman m = showT m + +instance (LogFormatting peer, Show peer) => + LogFormatting (WithMuxBearer peer MuxTrace) where + forMachine dtal (WithMuxBearer b ev) = + mkObject [ "kind" .= String "MuxTrace" + , "bearer" .= forMachine dtal b + , "event" .= showT ev ] + forHuman (WithMuxBearer b ev) = "With mux bearer " <> showT b + <> ". " <> showT ev + +instance LogFormatting NtC.HandshakeTr where + forMachine _dtal (WithMuxBearer b ev) = + mkObject [ "kind" .= String "LocalHandshakeTrace" + , "bearer" .= show b + , "event" .= show ev ] + forHuman (WithMuxBearer b ev) = "With mux bearer " <> showT b + <> ". " <> showT ev + +instance LogFormatting NtN.HandshakeTr where + forMachine _dtal (WithMuxBearer b ev) = + mkObject [ "kind" .= String "HandshakeTrace" + , "bearer" .= show b + , "event" .= show ev ] + forHuman (WithMuxBearer b ev) = "With mux bearer " <> showT b + <> ". " <> showT ev + + +instance LogFormatting ND.DiffusionInitializationTracer where + forMachine _dtal (ND.RunServer sockAddr) = mkObject + [ "kind" .= String "RunServer" + , "socketAddress" .= String (pack (show sockAddr)) + ] + + forMachine _dtal (ND.RunLocalServer localAddress) = mkObject + [ "kind" .= String "RunLocalServer" + , "localAddress" .= String (pack (show localAddress)) + ] + forMachine _dtal (ND.UsingSystemdSocket path) = mkObject + [ "kind" .= String "UsingSystemdSocket" + , "path" .= String (pack path) + ] + + forMachine _dtal (ND.CreateSystemdSocketForSnocketPath path) = mkObject + [ "kind" .= String "CreateSystemdSocketForSnocketPath" + , "path" .= String (pack path) + ] + forMachine _dtal (ND.CreatedLocalSocket path) = mkObject + [ "kind" .= String "CreatedLocalSocket" + , "path" .= String (pack path) + ] + forMachine _dtal (ND.ConfiguringLocalSocket path socket) = mkObject + [ "kind" .= String "ConfiguringLocalSocket" + , "path" .= String (pack path) + , "socket" .= String (pack (show socket)) + ] + forMachine _dtal (ND.ListeningLocalSocket path socket) = mkObject + [ "kind" .= String "ListeningLocalSocket" + , "path" .= String (pack path) + , "socket" .= String (pack (show socket)) + ] + forMachine _dtal (ND.LocalSocketUp path fd) = mkObject + [ "kind" .= String "LocalSocketUp" + , "path" .= String (pack path) + , "socket" .= String (pack (show fd)) + ] + forMachine _dtal (ND.CreatingServerSocket socket) = mkObject + [ "kind" .= String "CreatingServerSocket" + , "socket" .= String (pack (show socket)) + ] + forMachine _dtal (ND.ListeningServerSocket socket) = mkObject + [ "kind" .= String "ListeningServerSocket" + , "socket" .= String (pack (show socket)) + ] + forMachine _dtal (ND.ServerSocketUp socket) = mkObject + [ "kind" .= String "ServerSocketUp" + , "socket" .= String (pack (show socket)) + ] + forMachine _dtal (ND.ConfiguringServerSocket socket) = mkObject + [ "kind" .= String "ConfiguringServerSocket" + , "socket" .= String (pack (show socket)) + ] + forMachine _dtal (ND.UnsupportedLocalSystemdSocket path) = mkObject + [ "kind" .= String "UnsupportedLocalSystemdSocket" + , "path" .= String (pack (show path)) + ] + forMachine _dtal ND.UnsupportedReadySocketCase = mkObject + [ "kind" .= String "UnsupportedReadySocketCase" + ] + forMachine _dtal (ND.DiffusionErrored exception) = mkObject + [ "kind" .= String "DiffusionErrored" + , "path" .= String (pack (show exception)) + ] diff --git a/cardano-node/src/Cardano/TraceDispatcher/Peer.hs b/cardano-node/src/Cardano/TraceDispatcher/Peer.hs new file mode 100644 index 00000000000..9b838f70fa7 --- /dev/null +++ b/cardano-node/src/Cardano/TraceDispatcher/Peer.hs @@ -0,0 +1,145 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} + +module Cardano.TraceDispatcher.Peer + ( PeerT (..) + , startPeerTracer + , namesForPeers + , severityPeers + , docPeers + , ppPeer + ) where + +import Cardano.Logging +import Cardano.Prelude hiding (atomically) +import Prelude (String) + +import qualified Control.Monad.Class.MonadSTM.Strict as STM + +import Data.Aeson (ToJSON (..), Value (..), toJSON, (.=)) +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import qualified Data.Text as Text +import Text.Printf (printf) + +import Ouroboros.Consensus.Block (Header) +import Ouroboros.Consensus.Node (remoteAddress) +import Ouroboros.Consensus.Util.Orphans () + +import qualified Ouroboros.Network.AnchoredFragment as Net +import Ouroboros.Network.Block (unSlotNo) +import qualified Ouroboros.Network.Block as Net +import qualified Ouroboros.Network.BlockFetch.ClientRegistry as Net +import Ouroboros.Network.BlockFetch.ClientState + (PeerFetchInFlight (..), PeerFetchStatus (..), + readFetchClientState) + +import Cardano.Tracing.Kernel + +startPeerTracer :: + Trace IO [PeerT blk] + -> NodeKernelData blk + -> IO () +startPeerTracer tr nodeKern = do + void $ forkIO $ forever $ do + peers <- getCurrentPeers nodeKern + traceWith tr peers + threadDelay 2000000 -- 2 seconds. TODO JNF: make configurable + +data PeerT blk = PeerT + RemoteConnectionId + (Net.AnchoredFragment (Header blk)) + (PeerFetchStatus (Header blk)) + (PeerFetchInFlight (Header blk)) + + +ppPeer :: PeerT blk -> Text +ppPeer (PeerT cid _af status inflight) = + Text.pack $ printf "%-15s %-8s %s" (ppCid cid) (ppStatus status) (ppInFlight inflight) + +ppCid :: RemoteConnectionId -> String +ppCid = takeWhile (/= ':') . show . remoteAddress + +ppInFlight :: PeerFetchInFlight header -> String +ppInFlight f = printf + "%5s %3d %5d %6d" + (ppMaxSlotNo $ peerFetchMaxSlotNo f) + (peerFetchReqsInFlight f) + (Set.size $ peerFetchBlocksInFlight f) + (peerFetchBytesInFlight f) + +ppMaxSlotNo :: Net.MaxSlotNo -> String +ppMaxSlotNo Net.NoMaxSlotNo = "???" +ppMaxSlotNo (Net.MaxSlotNo x) = show (unSlotNo x) + +ppStatus :: PeerFetchStatus header -> String +ppStatus PeerFetchStatusShutdown = "shutdown" +ppStatus PeerFetchStatusAberrant = "aberrant" +ppStatus PeerFetchStatusBusy = "fetching" +ppStatus PeerFetchStatusReady {} = "ready" + +getCurrentPeers + :: NodeKernelData blk + -> IO [PeerT blk] +getCurrentPeers nkd = mapNodeKernelDataIO extractPeers nkd + <&> fromSMaybe mempty + where + tuple3pop :: (a, b, c) -> (a, b) + tuple3pop (a, b, _) = (a, b) + + getCandidates + :: STM.StrictTVar IO (Map peer (STM.StrictTVar IO (Net.AnchoredFragment (Header blk)))) + -> STM.STM IO (Map peer (Net.AnchoredFragment (Header blk))) + getCandidates var = STM.readTVar var >>= traverse STM.readTVar + + extractPeers :: NodeKernel IO RemoteConnectionId LocalConnectionId blk + -> IO [PeerT blk] + extractPeers kernel = do + peerStates <- fmap tuple3pop <$> ( STM.atomically + . (>>= traverse readFetchClientState) + . Net.readFetchClientsStateVars + . getFetchClientRegistry $ kernel + ) + candidates <- STM.atomically . getCandidates . getNodeCandidates $ kernel + + let peers = flip Map.mapMaybeWithKey candidates $ \cid af -> + maybe Nothing + (\(status, inflight) -> Just $ PeerT cid af status inflight) + $ Map.lookup cid peerStates + pure . Map.elems $ peers + +namesForPeers :: [PeerT blk] -> [Text] +namesForPeers _ = [] + +severityPeers :: [PeerT blk] -> SeverityS +severityPeers _ = Notice + +docPeers :: Documented [PeerT blk] +docPeers = Documented [ + DocMsg + [] + [(["peersFromNodeKernel"],"TODO Doc")] + "TODO Doc" + ] + +instance LogFormatting [PeerT blk] where + forMachine DMinimal _ = mkObject [ "kind" .= String "NodeKernelPeers"] + forMachine _ [] = mkObject [ "kind" .= String "NodeKernelPeers"] + forMachine dtal xs = mkObject + [ "kind" .= String "NodeKernelPeers" + , "peers" .= toJSON (foldl' (\acc x -> forMachine dtal x : acc) [] xs) + ] + forHuman peers = Text.concat $ intersperse ", " (map ppPeer peers) + asMetrics peers = [IntM ["peersFromNodeKernel"] (fromIntegral (length peers))] + +instance LogFormatting (PeerT blk) where + forMachine _dtal (PeerT cid _af status inflight) = + mkObject [ "peerAddress" .= String (Text.pack . show . remoteAddress $ cid) + , "peerStatus" .= String (Text.pack . ppStatus $ status) + , "peerSlotNo" .= String (Text.pack . ppMaxSlotNo . peerFetchMaxSlotNo $ inflight) + , "peerReqsInF" .= String (show . peerFetchReqsInFlight $ inflight) + , "peerBlocksInF" .= String (show . Set.size . peerFetchBlocksInFlight $ inflight) + , "peerBytesInF" .= String (show . peerFetchBytesInFlight $ inflight) + ] diff --git a/cardano-node/src/Cardano/TraceDispatcher/Render.hs b/cardano-node/src/Cardano/TraceDispatcher/Render.hs new file mode 100644 index 00000000000..11f1a798a45 --- /dev/null +++ b/cardano-node/src/Cardano/TraceDispatcher/Render.hs @@ -0,0 +1,177 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +{-# OPTIONS_GHC -Wno-unused-imports #-} + +module Cardano.TraceDispatcher.Render + ( + -- renderBlockOrEBB + renderChunkNo + , renderHeaderHash + , renderHeaderHashForDetails + , renderChainHash + , renderTipBlockNo + , renderTipHash + , condenseT + , showT + , renderPoint + , renderPointAsPhrase + , renderPointForDetails + , renderRealPoint + , renderRealPointAsPhrase + , renderSlotNo + , renderTip + , renderTipForDetails + , renderTxId + , renderTxIdForDetails + , renderWithOrigin + ) where + +import Cardano.Prelude +import Prelude (id) + +import qualified Data.ByteString.Base16 as B16 +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text + +import Cardano.Logging +import Cardano.Slotting.Slot (EpochNo (..), SlotNo (..), + WithOrigin (..)) +import Cardano.TraceDispatcher.Era.ConvertTxId (ConvertTxId' (..)) +import Ouroboros.Consensus.Block (BlockNo (..), ConvertRawHash (..), + RealPoint (..)) +import Ouroboros.Consensus.Block.Abstract (Point (..)) +import Ouroboros.Consensus.Ledger.SupportsMempool (GenTx, TxId) +import qualified Ouroboros.Consensus.Storage.ImmutableDB.API as ImmDB +import Ouroboros.Consensus.Storage.ImmutableDB.Chunks.Internal + (ChunkNo (..)) +import Ouroboros.Consensus.Storage.ImmutableDB.Impl.Types + (BlockOrEBB (..)) +import Ouroboros.Consensus.Util.Condense (Condense, condense) +import Ouroboros.Network.Block (ChainHash (..), HeaderHash, + StandardHash, Tip, getTipPoint) + +condenseT :: Condense a => a -> Text +condenseT = Text.pack . condense + +showT :: Show a => a -> Text +showT = Text.pack . show + +-- renderBlockOrEBB :: BlockOrEBB -> Text +-- renderBlockOrEBB (Block slotNo) = "Block at " <> renderSlotNo slotNo +-- renderBlockOrEBB (EBB epochNo) = "Epoch boundary block at " <> renderEpochNo epochNo + +renderChunkNo :: ChunkNo -> Text +renderChunkNo = Text.pack . show . unChunkNo + +-- renderEpochNo :: EpochNo -> Text +-- renderEpochNo = Text.pack . show . unEpochNo + +renderTipBlockNo :: ImmDB.Tip blk -> Text +renderTipBlockNo = Text.pack . show . unBlockNo . ImmDB.tipBlockNo + +renderTipHash :: StandardHash blk => ImmDB.Tip blk -> Text +renderTipHash tInfo = Text.pack . show $ ImmDB.tipHash tInfo + +renderTxIdForDetails + :: ConvertTxId' blk + => DetailLevel + -> TxId (GenTx blk) + -> Text +renderTxIdForDetails dtal = trimHashTextForDetails dtal . renderTxId + +renderTxId :: ConvertTxId' blk => TxId (GenTx blk) -> Text +renderTxId = Text.decodeLatin1 . B16.encode . txIdToRawBytes + +renderWithOrigin :: (a -> Text) -> WithOrigin a -> Text +renderWithOrigin _ Origin = "origin" +renderWithOrigin render (At a) = render a + +renderSlotNo :: SlotNo -> Text +renderSlotNo = Text.pack . show . unSlotNo + +renderRealPoint + :: forall blk. + ConvertRawHash blk + => RealPoint blk + -> Text +renderRealPoint (RealPoint slotNo headerHash) = + renderHeaderHash (Proxy @blk) headerHash + <> "@" + <> renderSlotNo slotNo + +-- | Render a short phrase describing a 'RealPoint'. +-- e.g. "62292d753b2ee7e903095bc5f10b03cf4209f456ea08f55308e0aaab4350dda4 at +-- slot 39920" +renderRealPointAsPhrase + :: forall blk. + ConvertRawHash blk + => RealPoint blk + -> Text +renderRealPointAsPhrase (RealPoint slotNo headerHash) = + renderHeaderHash (Proxy @blk) headerHash + <> " at slot " + <> renderSlotNo slotNo + +renderPointForDetails + :: forall blk. + ConvertRawHash blk + => DetailLevel + -> Point blk + -> Text +renderPointForDetails dtal point = + case point of + GenesisPoint -> "genesis (origin)" + BlockPoint slot h -> + renderHeaderHashForDetails (Proxy @blk) dtal h + <> "@" + <> renderSlotNo slot + +renderPoint :: ConvertRawHash blk => Point blk -> Text +renderPoint = renderPointForDetails DDetailed + +-- | Render a short phrase describing a 'Point'. +-- e.g. "62292d753b2ee7e903095bc5f10b03cf4209f456ea08f55308e0aaab4350dda4 at +-- slot 39920" or "genesis (origin)" in the case of a genesis point. +renderPointAsPhrase :: forall blk. ConvertRawHash blk => Point blk -> Text +renderPointAsPhrase point = + case point of + GenesisPoint -> "genesis (origin)" + BlockPoint slot h -> + renderHeaderHash (Proxy @blk) h + <> " at slot " + <> renderSlotNo slot + +renderTipForDetails + :: ConvertRawHash blk + => DetailLevel + -> Tip blk + -> Text +renderTipForDetails dtal = renderPointForDetails dtal . getTipPoint + +renderTip :: ConvertRawHash blk => Tip blk -> Text +renderTip = renderTipForDetails DDetailed + +renderHeaderHashForDetails + :: ConvertRawHash blk + => proxy blk + -> DetailLevel + -> HeaderHash blk + -> Text +renderHeaderHashForDetails p dtal = + trimHashTextForDetails dtal . renderHeaderHash p + + +-- | Hex encode and render a 'HeaderHash' as text. +renderHeaderHash :: ConvertRawHash blk => proxy blk -> HeaderHash blk -> Text +renderHeaderHash p = Text.decodeLatin1 . B16.encode . toRawHash p + +renderChainHash :: (HeaderHash blk -> Text) -> ChainHash blk -> Text +renderChainHash _ GenesisHash = "GenesisHash" +renderChainHash p (BlockHash hash) = p hash + +trimHashTextForDetails :: DetailLevel -> Text -> Text +trimHashTextForDetails dtal = + case dtal of + DMinimal -> Text.take 7 + _ -> id diff --git a/cardano-node/src/Cardano/TraceDispatcher/Resources.hs b/cardano-node/src/Cardano/TraceDispatcher/Resources.hs new file mode 100644 index 00000000000..ad5d8551968 --- /dev/null +++ b/cardano-node/src/Cardano/TraceDispatcher/Resources.hs @@ -0,0 +1,29 @@ +module Cardano.TraceDispatcher.Resources + ( + startResourceTracer + , namesForResources + , severityResources + ) where + + +import Cardano.Logging +import Cardano.Logging.Resources +import Cardano.Prelude hiding (trace) + +startResourceTracer :: + Trace IO ResourceStats + -> IO () +startResourceTracer tr = do + void $ forkIO $ forever $ do + mbrs <- readResourceStats + case mbrs of + Just rs -> traceWith tr rs + Nothing -> pure () + threadDelay 1000000 -- TODO JNF: make configurable + -- in microseconds + +namesForResources :: ResourceStats -> [Text] +namesForResources _ = [] + +severityResources :: ResourceStats -> SeverityS +severityResources _ = Info diff --git a/cardano-node/src/Cardano/TraceDispatcher/Tracers.hs b/cardano-node/src/Cardano/TraceDispatcher/Tracers.hs new file mode 100644 index 00000000000..02b2c298ae1 --- /dev/null +++ b/cardano-node/src/Cardano/TraceDispatcher/Tracers.hs @@ -0,0 +1,996 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeSynonymInstances #-} + +{-# OPTIONS_GHC -Wno-unused-imports #-} +{-# OPTIONS_GHC -Wno-deprecations #-} + + +module Cardano.TraceDispatcher.Tracers + ( mkDispatchTracers + , docTracers + ) where + +import qualified Data.Text.IO as T +import Network.Mux (MuxTrace (..), WithMuxBearer (..)) +import qualified Network.Socket as Socket + +import Cardano.Logging +import Cardano.Logging.Resources +import Cardano.Logging.Resources.Types +import Cardano.Prelude hiding (trace) +import Cardano.TraceDispatcher.BasicInfo.Combinators +import Cardano.TraceDispatcher.BasicInfo.Types (BasicInfo) +import Cardano.TraceDispatcher.ChainDB.Combinators +import Cardano.TraceDispatcher.ChainDB.Docu +import Cardano.TraceDispatcher.Consensus.Combinators +import Cardano.TraceDispatcher.Consensus.Docu +import Cardano.TraceDispatcher.Consensus.ForgingThreadStats + (docForgeStats, forgeThreadStats, ForgeThreadStats) +import Cardano.TraceDispatcher.Consensus.StateInfo +import Cardano.TraceDispatcher.Formatting () +import Cardano.TraceDispatcher.Network.Combinators +import Cardano.TraceDispatcher.Network.Docu +import Cardano.TraceDispatcher.Peer +import Cardano.TraceDispatcher.Network.Formatting () +import Cardano.TraceDispatcher.Resources (namesForResources, + severityResources, startResourceTracer) +import qualified "trace-dispatcher" Control.Tracer as NT +-- import Cardano.TraceDispatcher.Consensus.StartLeadershipCheck + + +import Cardano.Node.Configuration.Logging (EKGDirect) + +import qualified Cardano.BM.Data.Trace as Old +import Cardano.Tracing.Config (TraceOptions (..)) +import Cardano.Tracing.Constraints (TraceConstraints) +import Cardano.Tracing.Kernel (NodeKernelData) +import Cardano.Tracing.OrphanInstances.Common (ToObject) +import Cardano.Tracing.Tracers +import "contra-tracer" Control.Tracer (Tracer (..)) + +import Ouroboros.Consensus.Block.Forging +import Ouroboros.Consensus.BlockchainTime.WallClock.Util + (TraceBlockchainTimeEvent (..)) +import Ouroboros.Consensus.Byron.Ledger.Block (ByronBlock) +import Ouroboros.Consensus.Byron.Ledger.Config (BlockConfig) +import Ouroboros.Consensus.Ledger.Query (Query) +import Ouroboros.Consensus.Ledger.SupportsMempool (ApplyTxErr, GenTx, + GenTxId) +import Ouroboros.Consensus.Ledger.SupportsProtocol + (LedgerSupportsProtocol) +import Ouroboros.Consensus.Mempool.API (TraceEventMempool (..)) +import Ouroboros.Consensus.MiniProtocol.BlockFetch.Server + (TraceBlockFetchServerEvent (..)) +import Ouroboros.Consensus.MiniProtocol.ChainSync.Client + (TraceChainSyncClientEvent) +import Ouroboros.Consensus.MiniProtocol.ChainSync.Server + (TraceChainSyncServerEvent) +import Ouroboros.Consensus.MiniProtocol.LocalTxSubmission.Server + (TraceLocalTxSubmissionServerEvent (..)) +import qualified Ouroboros.Consensus.Network.NodeToClient as NtC +import qualified Ouroboros.Consensus.Network.NodeToNode as NtN +import qualified Ouroboros.Consensus.Node.Run as Consensus +import qualified Ouroboros.Consensus.Node.Tracers as Consensus +import Ouroboros.Consensus.Shelley.Ledger.Block +import qualified Ouroboros.Consensus.Shelley.Protocol.HotKey as HotKey +import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB +import Ouroboros.Consensus.Storage.Serialisation (SerialisedHeader) + + +import Ouroboros.Network.Block (Point (..), Serialised, Tip) +import qualified Ouroboros.Network.BlockFetch.ClientState as BlockFetch +import Ouroboros.Network.BlockFetch.Decision +import qualified Ouroboros.Network.Diffusion as ND +import Ouroboros.Network.Driver.Simple (TraceSendRecv) +import Ouroboros.Network.KeepAlive (TraceKeepAliveClient (..)) +import qualified Ouroboros.Network.NodeToClient as NtC +import Ouroboros.Network.NodeToNode (ErrorPolicyTrace (..), + WithAddr (..)) +import qualified Ouroboros.Network.NodeToNode as NtN +import Ouroboros.Network.Protocol.BlockFetch.Type (BlockFetch) +import Ouroboros.Network.Protocol.ChainSync.Type (ChainSync) +import Ouroboros.Network.Protocol.LocalStateQuery.Type + (LocalStateQuery) +import qualified Ouroboros.Network.Protocol.LocalTxSubmission.Type as LTS +import Ouroboros.Network.Protocol.TxSubmission.Type (TxSubmission) +import Ouroboros.Network.Protocol.TxSubmission2.Type (TxSubmission2) +import Ouroboros.Network.Snocket (LocalAddress (..)) +import Ouroboros.Network.Subscription.Dns (DnsTrace (..), + WithDomainName (..)) +import Ouroboros.Network.Subscription.Ip (WithIPList (..)) +import Ouroboros.Network.Subscription.Worker (SubscriptionTrace (..)) +import Ouroboros.Network.TxSubmission.Inbound + (TraceTxSubmissionInbound) +import Ouroboros.Network.TxSubmission.Outbound + (TraceTxSubmissionOutbound) + +import Debug.Trace + +type Peer = NtN.ConnectionId Socket.SockAddr + +-- | Construct tracers for all system components. +-- +mkDispatchTracers + :: forall peer localPeer blk. + ( Consensus.RunNode blk + , LogFormatting (ChainDB.InvalidBlockReason blk) + , TraceConstraints blk + , Show peer, Eq peer + , Show localPeer + , ToObject peer + , ToObject localPeer + , LogFormatting peer + , LogFormatting localPeer + ) + => BlockConfig blk + -> TraceOptions + -> Old.Trace IO Text + -> NodeKernelData blk + -> Maybe EKGDirect + -> Trace IO FormattedMessage + -> Trace IO FormattedMessage + -> Maybe (Trace IO FormattedMessage) + -> TraceConfig + -> [BasicInfo] + -> IO (Tracers peer localPeer blk) +mkDispatchTracers _blockConfig (TraceDispatcher _trSel) _tr nodeKernel _ekgDirect + trBase trForward mbTrEKG trConfig basicInfos = do + trace ("TraceConfig " <> show trConfig) $ pure () + cdbmTr <- mkCardanoTracer + trBase trForward mbTrEKG + "ChainDB" + namesForChainDBTraceEvents + severityChainDB + allPublic + cscTr <- mkCardanoTracer + trBase trForward mbTrEKG + "ChainSyncClient" + namesForChainSyncClientEvent + severityChainSyncClientEvent + allPublic + csshTr <- mkCardanoTracer + trBase trForward mbTrEKG + "ChainSyncServerHeader" + namesForChainSyncServerEvent + severityChainSyncServerEvent + allPublic + cssbTr <- mkCardanoTracer + trBase trForward mbTrEKG + "ChainSyncServerBlock" + namesForChainSyncServerEvent + severityChainSyncServerEvent + allPublic + bfdTr <- mkCardanoTracer + trBase trForward mbTrEKG + "BlockFetchDecision" + namesForBlockFetchDecision + severityBlockFetchDecision + allConfidential + bfcTr <- mkCardanoTracer + trBase trForward mbTrEKG + "BlockFetchClient" + namesForBlockFetchClient + severityBlockFetchClient + allPublic + bfsTr <- mkCardanoTracer + trBase trForward mbTrEKG + "BlockFetchServer" + namesForBlockFetchServer + severityBlockFetchServer + allPublic + fsiTr <- mkCardanoTracer + trBase trForward mbTrEKG + "ForgeStateInfo" + namesForStateInfo + severityStateInfo + allPublic + txiTr <- mkCardanoTracer + trBase trForward mbTrEKG + "TxInbound" + namesForTxInbound + severityTxInbound + allPublic + txoTr <- mkCardanoTracer + trBase trForward mbTrEKG + "TxOutbound" + namesForTxOutbound + severityTxOutbound + allPublic + ltxsTr <- mkCardanoTracer + trBase trForward mbTrEKG + "LocalTxSubmissionServer" + namesForLocalTxSubmissionServer + severityLocalTxSubmissionServer + allPublic + mpTr <- mkCardanoTracer + trBase trForward mbTrEKG + "Mempool" + namesForMempool + severityMempool + allPublic + fTr <- mkCardanoTracer' + trBase trForward mbTrEKG + "Forge" + namesForForge + severityForge + allPublic + (forgeTracerTransform nodeKernel) + fSttTr <- mkCardanoTracer' + trBase trForward mbTrEKG + "ForgeStats" + namesForForge + severityForge + allPublic + forgeThreadStats + btTr <- mkCardanoTracer + trBase trForward mbTrEKG + "BlockchainTime" + namesForBlockchainTime + severityBlockchainTime + allPublic + kacTr <- mkCardanoTracer + trBase trForward mbTrEKG + "KeepAliveClient" + namesForKeepAliveClient + severityKeepAliveClient + allPublic + tcsTr <- mkCardanoTracer + trBase trForward mbTrEKG + "ChainSyncClient" + namesForTChainSync + severityTChainSync + allPublic + ttsTr <- mkCardanoTracer + trBase trForward mbTrEKG + "TxSubmissionClient" + namesForTTxSubmission + severityTTxSubmission + allPublic + tsqTr <- mkCardanoTracer + trBase trForward mbTrEKG + "StateQueryClient" + namesForTStateQuery + severityTStateQuery + allPublic + tcsnTr <- mkCardanoTracer + trBase trForward mbTrEKG + "ChainSyncNode" + namesForTChainSyncNode + severityTChainSyncNode + allPublic + tcssTr <- mkCardanoTracer + trBase trForward mbTrEKG + "ChainSyncSerialised" + namesForTChainSyncSerialised + severityTChainSyncSerialised + allPublic + tbfTr <- mkCardanoTracer + trBase trForward mbTrEKG + "BlockFetch" + namesForTBlockFetch + severityTBlockFetch + allPublic + tbfsTr <- mkCardanoTracer + trBase trForward mbTrEKG + "BlockFetchSerialised" + namesForTBlockFetchSerialised + severityTBlockFetchSerialised + allPublic + tsnTr <- mkCardanoTracer + trBase trForward mbTrEKG + "TxSubmissionTracer" + namesForTxSubmissionNode + severityTxSubmissionNode + allPublic + ts2nTr <- mkCardanoTracer + trBase trForward mbTrEKG + "TxSubmission2" + namesForTxSubmission2Node + severityTxSubmission2Node + allPublic + ipsTr <- mkCardanoTracer + trBase trForward mbTrEKG + "IpSubscription" + namesForIPSubscription + severityIPSubscription + allPublic + dnssTr <- mkCardanoTracer + trBase trForward mbTrEKG + "DnsSubscription" + namesForDNSSubscription + severityDNSSubscription + allPublic + dnsrTr <- mkCardanoTracer + trBase trForward mbTrEKG + "DNSResolver" + namesForDNSResolver + severityDNSResolver + allPublic + errpTr <- mkCardanoTracer + trBase trForward mbTrEKG + "ErrorPolicy" + namesForErrorPolicy + severityErrorPolicy + allPublic + lerrpTr <- mkCardanoTracer + trBase trForward mbTrEKG + "LocalErrorPolicy" + namesForLocalErrorPolicy + severityLocalErrorPolicy + allPublic + apTr <- mkCardanoTracer + trBase trForward mbTrEKG + "AcceptPolicy" + namesForAcceptPolicy + severityAcceptPolicy + allPublic + muxTr <- mkCardanoTracer + trBase trForward mbTrEKG + "Mux" + namesForMux + severityMux + allPublic + muxLTr <- mkCardanoTracer + trBase trForward mbTrEKG + "MuxLocal" + namesForMux + severityMux + allPublic + hsTr <- mkCardanoTracer + trBase trForward mbTrEKG + "Handshake" + namesForHandshake + severityHandshake + allPublic + lhsTr <- mkCardanoTracer + trBase trForward mbTrEKG + "LocalHandshake" + namesForLocalHandshake + severityLocalHandshake + allPublic + diTr <- mkCardanoTracer + trBase trForward mbTrEKG + "DiffusionInit" + namesForDiffusionInit + severityDiffusionInit + allPublic + rsTr <- mkCardanoTracer + trBase trForward mbTrEKG + "Resources" + (\ _ -> []) + (\ _ -> Info) + allPublic + biTr <- mkCardanoTracer + trBase trForward mbTrEKG + "BasicInfo" + namesForBasicInfo + severityBasicInfo + allPublic + pTr <- mkCardanoTracer + trBase trForward mbTrEKG + "Peers" + namesForPeers + severityPeers + allPublic + + configureTracers trConfig docChainDBTraceEvent [cdbmTr] + configureTracers trConfig docChainSyncClientEvent [cscTr] + configureTracers trConfig docChainSyncServerEvent [csshTr] + configureTracers trConfig docChainSyncServerEvent [cssbTr] + configureTracers trConfig docBlockFetchDecision [bfdTr] + configureTracers trConfig docBlockFetchClient [bfcTr] + configureTracers trConfig docBlockFetchServer [bfsTr] + configureTracers trConfig docForgeStateInfo [fsiTr] + configureTracers trConfig docTxInbound [txiTr] + configureTracers trConfig docTxOutbound [txoTr] + configureTracers trConfig docLocalTxSubmissionServer [ltxsTr] + configureTracers trConfig docMempool [mpTr] + configureTracers trConfig docForge [fTr, fSttTr] + configureTracers trConfig docBlockchainTime [btTr] + configureTracers trConfig docKeepAliveClient [kacTr] + configureTracers trConfig docTChainSync [tcsTr] + configureTracers trConfig docTTxSubmission [ttsTr] + configureTracers trConfig docTStateQuery [tsqTr] + configureTracers trConfig docTChainSync [tcsnTr] + configureTracers trConfig docTChainSync [tcssTr] + configureTracers trConfig docTBlockFetch [tbfTr] + configureTracers trConfig docTBlockFetch [tbfsTr] + configureTracers trConfig docTTxSubmissionNode [tsnTr] + configureTracers trConfig docTTxSubmission2Node [ts2nTr] + configureTracers trConfig docIPSubscription [ipsTr] + configureTracers trConfig docDNSSubscription [dnssTr] + configureTracers trConfig docDNSResolver [dnsrTr] + configureTracers trConfig docErrorPolicy [errpTr] + configureTracers trConfig docLocalErrorPolicy [lerrpTr] + configureTracers trConfig docAcceptPolicy [apTr] + configureTracers trConfig docMux [muxTr] + configureTracers trConfig docMux [muxLTr] + configureTracers trConfig docHandshake [hsTr] + configureTracers trConfig docLocalHandshake [lhsTr] + configureTracers trConfig docDiffusionInit [diTr] + configureTracers trConfig docResourceStats [rsTr] + configureTracers trConfig docBasicInfo [biTr] + configureTracers trConfig docPeers [pTr] + +-- -- TODO JNF Code for debugging frequency limiting +-- void . forkIO $ +-- sendContinously +-- 0.1 +-- cdbmTr +-- (ChainDB.TraceOpenEvent +-- (ChainDB.OpenedDB (Point Origin) (Point Origin))) +-- -- End of debugging code + + mapM_ (traceWith biTr) basicInfos + startResourceTracer rsTr + startPeerTracer pTr nodeKernel + + pure Tracers + { chainDBTracer = Tracer (traceWith cdbmTr) + , consensusTracers = Consensus.Tracers + { Consensus.chainSyncClientTracer = Tracer (traceWith cscTr) + , Consensus.chainSyncServerHeaderTracer = Tracer (traceWith csshTr) + , Consensus.chainSyncServerBlockTracer = Tracer (traceWith cssbTr) + , Consensus.blockFetchDecisionTracer = Tracer (traceWith bfdTr) + , Consensus.blockFetchClientTracer = Tracer (traceWith bfcTr) + , Consensus.blockFetchServerTracer = Tracer (traceWith bfsTr) + , Consensus.forgeStateInfoTracer = + Tracer (traceWith (traceAsKESInfo (Proxy @blk) fsiTr)) + , Consensus.txInboundTracer = Tracer (traceWith txiTr) + , Consensus.txOutboundTracer = Tracer (traceWith txoTr) + , Consensus.localTxSubmissionServerTracer = Tracer (traceWith ltxsTr) + , Consensus.mempoolTracer = Tracer (traceWith mpTr) + , Consensus.forgeTracer = + Tracer (traceWith (contramap Left fTr)) + <> Tracer (traceWith (contramap Left fSttTr)) + , Consensus.blockchainTimeTracer = Tracer (traceWith btTr) + , Consensus.keepAliveClientTracer = Tracer (traceWith kacTr) + } + , nodeToClientTracers = NtC.Tracers + { NtC.tChainSyncTracer = Tracer (traceWith tcsTr) + , NtC.tTxSubmissionTracer = Tracer (traceWith ttsTr) + , NtC.tStateQueryTracer = Tracer (traceWith tsqTr) + } + , nodeToNodeTracers = NtN.Tracers + { NtN.tChainSyncTracer = Tracer (traceWith tcsnTr) + , NtN.tChainSyncSerialisedTracer = Tracer (traceWith tcssTr) + , NtN.tBlockFetchTracer = Tracer (traceWith tbfTr) + , NtN.tBlockFetchSerialisedTracer = Tracer (traceWith tbfsTr) + , NtN.tTxSubmissionTracer = Tracer (traceWith tsnTr) + , NtN.tTxSubmission2Tracer = Tracer (traceWith ts2nTr) + } + , ipSubscriptionTracer = Tracer (traceWith ipsTr) + , dnsSubscriptionTracer= Tracer (traceWith dnssTr) + , dnsResolverTracer = Tracer (traceWith dnsrTr) + , errorPolicyTracer = Tracer (traceWith errpTr) + , localErrorPolicyTracer = Tracer (traceWith lerrpTr) + , acceptPolicyTracer = Tracer (traceWith apTr) + , muxTracer = Tracer (traceWith muxTr) + , muxLocalTracer = Tracer (traceWith muxLTr) + , handshakeTracer = Tracer (traceWith hsTr) + , localHandshakeTracer = Tracer (traceWith lhsTr) + , diffusionInitializationTracer = Tracer (traceWith diTr) + , basicInfoTracer = Tracer (traceWith biTr) + } + +mkDispatchTracers blockConfig tOpts tr nodeKern ekgDirect _ _ _ _ _ = + mkTracers blockConfig tOpts tr nodeKern ekgDirect + +-- -- TODO JNF Code for debugging frequency limiting +-- sendContinously :: +-- Double +-- -> Trace IO m +-- -> m +-- -> IO () +-- sendContinously delay tracer message = do +-- threadDelay (round (delay * 1000000.0)) +-- traceWith tracer message +-- sendContinously delay tracer message +-- -- End of debugging code + +docTracers :: forall blk t. + ( Show t + , forall result. Show (Query blk result) + , TraceConstraints blk + , LogFormatting (ChainDB.InvalidBlockReason blk) + , LedgerSupportsProtocol blk + , Consensus.RunNode blk + ) + => FilePath + -> FilePath + -> Proxy blk + -> IO () +docTracers configFileName outputFileName _ = do + trConfig <- readConfiguration configFileName + trBase <- docTracer (Stdout HumanFormatColoured) + trForward <- docTracer Forwarder + mbTrEKG :: Maybe (Trace IO FormattedMessage) <- + liftM Just (docTracer EKGBackend) + cdbmTr <- mkCardanoTracer + trBase trForward mbTrEKG + "ChainDB" + namesForChainDBTraceEvents + severityChainDB + allPublic + cscTr <- mkCardanoTracer + trBase trForward mbTrEKG + "ChainSyncClient" + namesForChainSyncClientEvent + severityChainSyncClientEvent + allPublic + csshTr <- mkCardanoTracer + trBase trForward mbTrEKG + "ChainSyncServerHeader" + namesForChainSyncServerEvent + severityChainSyncServerEvent + allPublic + cssbTr <- mkCardanoTracer + trBase trForward mbTrEKG + "ChainSyncServerBlock" + namesForChainSyncServerEvent + severityChainSyncServerEvent + allPublic + bfdTr <- mkCardanoTracer + trBase trForward mbTrEKG + "BlockFetchDecision" + namesForBlockFetchDecision + severityBlockFetchDecision + allConfidential + bfcTr <- mkCardanoTracer + trBase trForward mbTrEKG + "BlockFetchClient" + namesForBlockFetchClient + severityBlockFetchClient + allPublic + bfsTr <- mkCardanoTracer + trBase trForward mbTrEKG + "BlockFetchServer" + namesForBlockFetchServer + severityBlockFetchServer + allPublic + fsiTr <- mkCardanoTracer + trBase trForward mbTrEKG + "ForgeStateInfo" + namesForStateInfo + severityStateInfo + allPublic + txiTr <- mkCardanoTracer + trBase trForward mbTrEKG + "TxInbound" + namesForTxInbound + severityTxInbound + allPublic + txoTr <- mkCardanoTracer + trBase trForward mbTrEKG + "TxOutbound" + namesForTxOutbound + severityTxOutbound + allPublic + ltxsTr <- mkCardanoTracer + trBase trForward mbTrEKG + "LocalTxSubmissionServer" + namesForLocalTxSubmissionServer + severityLocalTxSubmissionServer + allPublic + -- mpTr <- mkCardanoTracer + -- "Mempool" + -- namesForMempool + -- severityMempool + -- allPublic + -- trBase trForward mbTrEKG + fTr <- mkCardanoTracer + trBase trForward mbTrEKG + "Forge" + namesForForge + severityForge + allPublic + fSttTr <- mkCardanoTracer' + trBase trForward mbTrEKG + "ForgeStats" + namesForForge + severityForge + allPublic + forgeThreadStats + btTr <- mkCardanoTracer + trBase trForward mbTrEKG + "BlockchainTime" + namesForBlockchainTime + severityBlockchainTime + allPublic + kacTr <- mkCardanoTracer + trBase trForward mbTrEKG + "KeepAliveClient" + namesForKeepAliveClient + severityKeepAliveClient + allPublic + tcsTr <- mkCardanoTracer + trBase trForward mbTrEKG + "ChainSyncClient" + namesForTChainSync + severityTChainSync + allPublic + ttsTr <- mkCardanoTracer + trBase trForward mbTrEKG + "TxSubmissionClient" + namesForTTxSubmission + severityTTxSubmission + allPublic + tsqTr <- mkCardanoTracer + trBase trForward mbTrEKG + "StateQueryClient" + namesForTStateQuery + severityTStateQuery + allPublic + tcsnTr <- mkCardanoTracer + trBase trForward mbTrEKG + "ChainSyncNode" + namesForTChainSyncNode + severityTChainSyncNode + allPublic + tcssTr <- mkCardanoTracer + trBase trForward mbTrEKG + "ChainSyncSerialised" + namesForTChainSyncSerialised + severityTChainSyncSerialised + allPublic + tbfTr <- mkCardanoTracer + trBase trForward mbTrEKG + "BlockFetch" + namesForTBlockFetch + severityTBlockFetch + allPublic + tbfsTr <- mkCardanoTracer + trBase trForward mbTrEKG + "BlockFetchSerialised" + namesForTBlockFetchSerialised + severityTBlockFetchSerialised + allPublic + tsnTr <- mkCardanoTracer + trBase trForward mbTrEKG + "TxSubmissionTracer" + namesForTxSubmissionNode + severityTxSubmissionNode + allPublic + ts2nTr <- mkCardanoTracer + trBase trForward mbTrEKG + "TxSubmission2" + namesForTxSubmission2Node + severityTxSubmission2Node + allPublic + ipsTr <- mkCardanoTracer + trBase trForward mbTrEKG + "IpSubscription" + namesForIPSubscription + severityIPSubscription + allPublic + dnssTr <- mkCardanoTracer + trBase trForward mbTrEKG + "DnsSubscription" + namesForDNSSubscription + severityDNSSubscription + allPublic + dnsrTr <- mkCardanoTracer + trBase trForward mbTrEKG + "DNSResolver" + namesForDNSResolver + severityDNSResolver + allPublic + errpTr <- mkCardanoTracer + trBase trForward mbTrEKG + "ErrorPolicy" + namesForErrorPolicy + severityErrorPolicy + allPublic + lerrpTr <- mkCardanoTracer + trBase trForward mbTrEKG + "LocalErrorPolicy" + namesForLocalErrorPolicy + severityLocalErrorPolicy + allPublic + apTr <- mkCardanoTracer + trBase trForward mbTrEKG + "AcceptPolicy" + namesForAcceptPolicy + severityAcceptPolicy + allPublic + muxTr <- mkCardanoTracer + trBase trForward mbTrEKG + "Mux" + namesForMux + severityMux + allPublic + muxLTr <- mkCardanoTracer + trBase trForward mbTrEKG + "MuxLocal" + namesForMux + severityMux + allPublic + hsTr <- mkCardanoTracer + trBase trForward mbTrEKG + "Handshake" + namesForHandshake + severityHandshake + allPublic + lhsTr <- mkCardanoTracer + trBase trForward mbTrEKG + "LocalHandshake" + namesForLocalHandshake + severityLocalHandshake + allPublic + diTr <- mkCardanoTracer + trBase trForward mbTrEKG + "DiffusionInit" + namesForDiffusionInit + severityDiffusionInit + allPublic + rsTr <- mkCardanoTracer + trBase trForward mbTrEKG + "Resources" + namesForResources + severityResources + allPublic + biTr <- mkCardanoTracer + trBase trForward mbTrEKG + "BasicInfo" + namesForBasicInfo + severityBasicInfo + allPublic + + configureTracers trConfig docChainDBTraceEvent [cdbmTr] + configureTracers trConfig docChainSyncClientEvent [cscTr] + configureTracers trConfig docChainSyncServerEvent [csshTr] + configureTracers trConfig docChainSyncServerEvent [cssbTr] + configureTracers trConfig docBlockFetchDecision [bfdTr] + configureTracers trConfig docBlockFetchClient [bfcTr] + configureTracers trConfig docBlockFetchServer [bfsTr] + configureTracers trConfig docForgeStateInfo [fsiTr] + configureTracers trConfig docTxInbound [txiTr] + configureTracers trConfig docTxOutbound [txoTr] + configureTracers trConfig docLocalTxSubmissionServer [ltxsTr] +-- configureTracers trConfig docMempool [mpTr] + configureTracers trConfig docForge [fTr, fSttTr] + configureTracers trConfig docBlockchainTime [btTr] + configureTracers trConfig docKeepAliveClient [kacTr] + configureTracers trConfig docTChainSync [tcsTr] + configureTracers trConfig docTTxSubmission [ttsTr] + configureTracers trConfig docTStateQuery [tsqTr] + configureTracers trConfig docTChainSync [tcsnTr] + configureTracers trConfig docTChainSync [tcssTr] + configureTracers trConfig docTBlockFetch [tbfTr] + configureTracers trConfig docTBlockFetch [tbfsTr] + configureTracers trConfig docTTxSubmissionNode [tsnTr] + configureTracers trConfig docTTxSubmission2Node [ts2nTr] + configureTracers trConfig docIPSubscription [ipsTr] + configureTracers trConfig docDNSSubscription [dnssTr] + configureTracers trConfig docDNSResolver [dnsrTr] + configureTracers trConfig docErrorPolicy [errpTr] + configureTracers trConfig docLocalErrorPolicy [lerrpTr] + configureTracers trConfig docAcceptPolicy [apTr] + configureTracers trConfig docMux [muxTr] + configureTracers trConfig docMux [muxLTr] + configureTracers trConfig docHandshake [hsTr] + configureTracers trConfig docLocalHandshake [lhsTr] + configureTracers trConfig docDiffusionInit [diTr] + configureTracers trConfig docResourceStats [rsTr] + configureTracers trConfig docBasicInfo [biTr] + + cdbmTrDoc <- documentMarkdown + (docChainDBTraceEvent :: Documented + (ChainDB.TraceEvent blk)) + [cdbmTr] + cscTrDoc <- documentMarkdown + (docChainSyncClientEvent :: Documented + (BlockFetch.TraceLabelPeer Peer + (TraceChainSyncClientEvent blk))) + [cscTr] + csshTrDoc <- documentMarkdown + (docChainSyncServerEvent :: Documented + (TraceChainSyncServerEvent blk)) + [csshTr] + cssbTrDoc <- documentMarkdown + (docChainSyncServerEvent :: Documented + (TraceChainSyncServerEvent blk)) + [cssbTr] + bfdTrDoc <- documentMarkdown + (docBlockFetchDecision :: Documented + [BlockFetch.TraceLabelPeer Peer (FetchDecision [Point (Header blk)])]) + [bfdTr] + bfcTrDoc <- documentMarkdown + (docBlockFetchClient :: Documented + (BlockFetch.TraceLabelPeer Peer (BlockFetch.TraceFetchClientState (Header blk)))) + [bfcTr] + bfsTrDoc <- documentMarkdown + (docBlockFetchServer :: Documented + (TraceBlockFetchServerEvent blk)) + [bfsTr] + -- fsiTrDoc <- documentMarkdown + -- (docForgeStateInfo :: Documented + -- (Consensus.TraceLabelCreds HotKey.KESInfo)) + -- [fsiTr] + txiTrDoc <- documentMarkdown + (docTxInbound :: Documented + (BlockFetch.TraceLabelPeer Peer + (TraceTxSubmissionInbound (GenTxId blk) (GenTx blk)))) + [txiTr] + txoTrDoc <- documentMarkdown + (docTxOutbound :: Documented + (BlockFetch.TraceLabelPeer Peer + (TraceTxSubmissionOutbound (GenTxId blk) (GenTx blk)))) + [txoTr] + ltxsTrDoc <- documentMarkdown + (docLocalTxSubmissionServer :: Documented + (TraceLocalTxSubmissionServerEvent blk)) + [ltxsTr] + -- mpTrDoc <- documentMarkdown + -- (docMempool :: Documented + -- (TraceEventMempool blk)) + -- [mpTr] + fTrDoc <- documentMarkdown + (docForge :: Documented + (ForgeTracerType blk)) + [fTr] + -- TODO JNF Docu for forgeThreadStats + -- fSttTr' <- forgeThreadStats fSttTr + -- fSttTrDoc <- documentMarkdown + -- (docForgeStats :: Documented + -- ForgeThreadStats) + -- [unfold fSttTr] + btTrDoc <- documentMarkdown + (docBlockchainTime :: Documented + (TraceBlockchainTimeEvent t)) + [btTr] + kacTrDoc <- documentMarkdown + (docKeepAliveClient :: Documented + (TraceKeepAliveClient Peer)) + [kacTr] + tcsTrDoc <- documentMarkdown + (docTChainSync :: Documented + (BlockFetch.TraceLabelPeer Peer + (TraceSendRecv + (ChainSync (Serialised blk) (Point blk) (Tip blk))))) + [tcsTr] + ttsTrDoc <- documentMarkdown + (docTTxSubmission :: Documented + (BlockFetch.TraceLabelPeer + Peer + (TraceSendRecv + (LTS.LocalTxSubmission + (GenTx blk) (ApplyTxErr blk))))) + [ttsTr] + tsqTrDoc <- documentMarkdown + (docTStateQuery :: Documented + (BlockFetch.TraceLabelPeer Peer + (TraceSendRecv + (LocalStateQuery blk (Point blk) (Query blk))))) + [tsqTr] + tcsnTrDoc <- documentMarkdown + (docTChainSync :: Documented + (BlockFetch.TraceLabelPeer Peer + (TraceSendRecv + (ChainSync (Header blk) (Point blk) (Tip blk))))) + [tcsnTr] + tcssTrDoc <- documentMarkdown + (docTChainSync :: Documented + (BlockFetch.TraceLabelPeer Peer + (TraceSendRecv + (ChainSync (SerialisedHeader blk) (Point blk) (Tip blk))))) + [tcssTr] + tbfTrDoc <- documentMarkdown + (docTBlockFetch :: Documented + (BlockFetch.TraceLabelPeer Peer + (TraceSendRecv + (BlockFetch blk (Point blk))))) + [tbfTr] + tbfsTrDoc <- documentMarkdown + (docTBlockFetch :: Documented + (BlockFetch.TraceLabelPeer Peer + (TraceSendRecv + (BlockFetch (Serialised blk) (Point blk))))) + [tbfsTr] + tsnTrDoc <- documentMarkdown + (docTTxSubmissionNode :: Documented + (BlockFetch.TraceLabelPeer Peer + (TraceSendRecv + (TxSubmission (GenTxId blk) (GenTx blk))))) + [tsnTr] + ts2nTrDoc <- documentMarkdown + (docTTxSubmission2Node :: Documented + (BlockFetch.TraceLabelPeer Peer + (TraceSendRecv + (TxSubmission2 (GenTxId blk) (GenTx blk))))) + [ts2nTr] + ipsTrDoc <- documentMarkdown + (docIPSubscription :: Documented + (WithIPList (SubscriptionTrace Socket.SockAddr))) + [ipsTr] + dnssTrDoc <- documentMarkdown + (docDNSSubscription :: Documented + (WithDomainName (SubscriptionTrace Socket.SockAddr))) + [dnssTr] + dnsrTrDoc <- documentMarkdown + (docDNSResolver :: Documented (WithDomainName DnsTrace)) + [dnsrTr] + errpTrDoc <- documentMarkdown + (docErrorPolicy :: Documented + (WithAddr Socket.SockAddr ErrorPolicyTrace)) + [errpTr] + lerrpTrDoc <- documentMarkdown + (docLocalErrorPolicy :: Documented + (WithAddr LocalAddress ErrorPolicyTrace)) + [lerrpTr] + apTrDoc <- documentMarkdown + (docAcceptPolicy :: Documented + NtN.AcceptConnectionsPolicyTrace) + [apTr] + muxTrDoc <- documentMarkdown + (docMux :: Documented + (WithMuxBearer Peer MuxTrace)) + [muxTr] + muxLTrDoc <- documentMarkdown + (docMux :: Documented + (WithMuxBearer Peer MuxTrace)) + [muxLTr] + hsTrDoc <- documentMarkdown + (docHandshake :: Documented NtN.HandshakeTr) + [hsTr] + lhsTrDoc <- documentMarkdown + (docLocalHandshake :: Documented NtC.HandshakeTr) + [lhsTr] + diTrDoc <- documentMarkdown + (docDiffusionInit :: Documented ND.DiffusionInitializationTracer) + [diTr] + rsTrDoc <- documentMarkdown + (docResourceStats :: Documented ResourceStats) + [rsTr] + biTrDoc <- documentMarkdown + (docBasicInfo :: Documented BasicInfo) + [biTr] + + let bl = cdbmTrDoc + ++ cscTrDoc + ++ csshTrDoc + ++ cssbTrDoc + ++ bfdTrDoc + ++ bfcTrDoc + ++ bfsTrDoc +-- ++ fsiTrDoc + ++ txiTrDoc + ++ txoTrDoc + ++ ltxsTrDoc +-- ++ mpTrDoc + ++ fTrDoc + ++ btTrDoc + ++ kacTrDoc + ++ tcsTrDoc + ++ ttsTrDoc + ++ tsqTrDoc + ++ tcsnTrDoc + ++ tcssTrDoc + ++ tbfTrDoc + ++ tbfsTrDoc + ++ tsnTrDoc + ++ ts2nTrDoc + ++ ipsTrDoc + ++ dnssTrDoc + ++ dnsrTrDoc + ++ errpTrDoc + ++ lerrpTrDoc + ++ apTrDoc + ++ muxTrDoc + ++ muxLTrDoc + ++ hsTrDoc + ++ lhsTrDoc + ++ diTrDoc + ++ rsTrDoc + ++ biTrDoc + + res <- buildersToText bl trConfig + T.writeFile outputFileName res + pure () diff --git a/cardano-node/src/Cardano/Tracing/Config.hs b/cardano-node/src/Cardano/Tracing/Config.hs index a370e4b6782..944bc698ffa 100644 --- a/cardano-node/src/Cardano/Tracing/Config.hs +++ b/cardano-node/src/Cardano/Tracing/Config.hs @@ -4,7 +4,6 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} - module Cardano.Tracing.Config ( TraceOptions (..) , TraceSelection (..) @@ -19,13 +18,13 @@ import Data.Aeson.Types (Parser) import Data.Text (pack) import Cardano.BM.Tracing (TracingVerbosity (..)) - import Cardano.Node.Orphans () data TraceOptions = TracingOff | TracingOn TraceSelection + | TraceDispatcher TraceSelection deriving (Eq, Show) type TraceAcceptPolicy = ("TraceAcceptPolicy" :: Symbol) @@ -114,8 +113,8 @@ data TraceSelection } deriving (Eq, Show) -traceConfigParser :: Object -> Parser TraceOptions -traceConfigParser v = +traceConfigParser :: Object -> (TraceSelection -> TraceOptions) -> Parser TraceOptions +traceConfigParser v ctor = let acceptPolicy :: OnOff TraceAcceptPolicy acceptPolicy = OnOff False blockFetchClient :: OnOff TraceBlockFetchClient @@ -185,7 +184,7 @@ traceConfigParser v = txSubmission2Protocol :: OnOff TraceTxSubmission2Protocol txSubmission2Protocol = OnOff False in - TracingOn <$> (TraceSelection + ctor <$> (TraceSelection <$> v .:? "TracingVerbosity" .!= NormalVerbosity -- Per-trace toggles, alpha-sorted. <*> v .:? getName acceptPolicy .!= acceptPolicy diff --git a/cardano-node/src/Cardano/Tracing/Constraints.hs b/cardano-node/src/Cardano/Tracing/Constraints.hs index 1306b25a8d4..b31d0b82c1b 100644 --- a/cardano-node/src/Cardano/Tracing/Constraints.hs +++ b/cardano-node/src/Cardano/Tracing/Constraints.hs @@ -1,5 +1,6 @@ -{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MonoLocalBinds #-} module Cardano.Tracing.Constraints ( TraceConstraints @@ -10,7 +11,15 @@ import Prelude (Show) import Data.Aeson import Cardano.BM.Tracing (ToObject) +import Cardano.Logging (LogFormatting) +import Cardano.TraceDispatcher.Consensus.Formatting (GetKESInfoX (..), + HasKESInfoX (..)) +import Cardano.TraceDispatcher.Consensus.StartLeadershipCheck + (LedgerQueriesX) +import Cardano.TraceDispatcher.Era.ConvertTxId (ConvertTxId') import Cardano.Tracing.ConvertTxId (ConvertTxId) +import Cardano.Tracing.Metrics (HasKESInfo (..), + HasKESMetricsData (..)) import Cardano.Tracing.Queries (LedgerQueries) import Cardano.Ledger.Alonzo (AlonzoEra) @@ -19,25 +28,35 @@ import Cardano.Ledger.Alonzo.Rules.Bbody (AlonzoBbodyPredFail) import Cardano.Ledger.Alonzo.Rules.Utxo (UtxoPredicateFailure) import Cardano.Ledger.Alonzo.Rules.Utxow (AlonzoPredFail) import Cardano.Ledger.Alonzo.TxBody (TxOut) +import Ouroboros.Consensus.Block (BlockProtocol, CannotForge, + ForgeStateUpdateError, Header) import Cardano.Ledger.Crypto (StandardCrypto) -import Ouroboros.Consensus.Block (BlockProtocol, CannotForge, ForgeStateUpdateError, - Header) import Ouroboros.Consensus.HeaderValidation (OtherHeaderEnvelopeError) import Ouroboros.Consensus.Ledger.Abstract (LedgerError) -import Ouroboros.Consensus.Ledger.Inspect (LedgerEvent) -import Ouroboros.Consensus.Ledger.SupportsMempool (ApplyTxErr, HasTxId, HasTxs (..)) +import Ouroboros.Consensus.Ledger.Inspect (LedgerEvent, LedgerUpdate, + LedgerWarning) +import Ouroboros.Consensus.Ledger.SupportsMempool (ApplyTxErr, + HasTxId, HasTxs (..)) import Ouroboros.Consensus.Protocol.Abstract (ValidationErr) import Ouroboros.Consensus.Shelley.Ledger.Mempool (GenTx, TxId) -- | Tracing-related constraints for monitoring purposes. type TraceConstraints blk = - ( ConvertTxId blk + ( ConvertTxId' blk + , ConvertTxId blk , HasTxs blk , HasTxId (GenTx blk) , LedgerQueries blk + , LedgerQueriesX blk , ToJSON (TxId (GenTx blk)) , ToJSON (TxOut (AlonzoEra StandardCrypto)) , ToJSON (PParamsUpdate (AlonzoEra StandardCrypto)) + , HasKESMetricsData blk + , HasKESInfo blk + , HasKESInfoX blk + , GetKESInfoX blk + + , ToObject (ApplyTxErr blk) , ToObject (GenTx blk) , ToObject (Header blk) @@ -47,9 +66,27 @@ type TraceConstraints blk = , ToObject (ValidationErr (BlockProtocol blk)) , ToObject (CannotForge blk) , ToObject (ForgeStateUpdateError blk) + + -- TODO: handle the implications in the new logging , ToObject (UtxoPredicateFailure (AlonzoEra StandardCrypto)) , ToObject (AlonzoBbodyPredFail (AlonzoEra StandardCrypto)) , ToObject (AlonzoPredFail (AlonzoEra StandardCrypto)) + + , LogFormatting (LedgerUpdate blk) + , LogFormatting (LedgerWarning blk) + , LogFormatting (ApplyTxErr blk) + , LogFormatting (GenTx blk) + , LogFormatting (Header blk) + , LogFormatting (LedgerError blk) + , LogFormatting (LedgerEvent blk) + , LogFormatting (OtherHeaderEnvelopeError blk) + , LogFormatting (ValidationErr (BlockProtocol blk)) + , LogFormatting (CannotForge blk) + , LogFormatting (ForgeStateUpdateError blk) + , LogFormatting (UtxoPredicateFailure (AlonzoEra StandardCrypto)) + , LogFormatting (AlonzoBbodyPredFail (AlonzoEra StandardCrypto)) + , LogFormatting (AlonzoPredFail (AlonzoEra StandardCrypto)) + , Show blk , Show (Header blk) ) diff --git a/cardano-node/src/Cardano/Tracing/OrphanInstances/Common.hs b/cardano-node/src/Cardano/Tracing/OrphanInstances/Common.hs index c4a3f40cede..81e461be38b 100644 --- a/cardano-node/src/Cardano/Tracing/OrphanInstances/Common.hs +++ b/cardano-node/src/Cardano/Tracing/OrphanInstances/Common.hs @@ -58,7 +58,6 @@ import Cardano.BM.Stats import Cardano.BM.Tracing (HasPrivacyAnnotation (..), HasSeverityAnnotation (..), Severity (..), ToObject (..), Tracer (..), TracingVerbosity (..), Transformable (..)) -import qualified Cardano.Chain.Update as Update import Cardano.Slotting.Block (BlockNo (..)) import Ouroboros.Consensus.Byron.Ledger.Block (ByronHash (..)) import Ouroboros.Consensus.HardFork.Combinator (OneEraHash (..)) @@ -89,11 +88,11 @@ instance FromJSON PortNumber where parseJSON invalid = fail $ "Parsing of port number failed due to type mismatch. " <> "Encountered: " <> show invalid -instance FromJSON Update.ApplicationName where - parseJSON (String x) = pure $ Update.ApplicationName x - parseJSON invalid = - fail $ "Parsing of application name failed due to type mismatch. " - <> "Encountered: " <> show invalid +-- instance FromJSON Update.ApplicationName where +-- parseJSON (String x) = pure $ Update.ApplicationName x +-- parseJSON invalid = +-- fail $ "Parsing of application name failed due to type mismatch. " +-- <> "Encountered: " <> show invalid instance ToJSON (HeaderHash blk) => ToJSON (Tip blk) where toJSON TipGenesis = object [ "genesis" .= True ] diff --git a/cardano-node/src/Cardano/Tracing/Tracers.hs b/cardano-node/src/Cardano/Tracing/Tracers.hs index 4c17fefec84..72f0193a506 100644 --- a/cardano-node/src/Cardano/Tracing/Tracers.hs +++ b/cardano-node/src/Cardano/Tracing/Tracers.hs @@ -7,6 +7,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} {-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} @@ -42,8 +43,9 @@ import qualified System.Remote.Monitoring as EKG import Network.Mux (MuxTrace, WithMuxBearer) import qualified Network.Socket as Socket (SockAddr) -import Control.Tracer +import "contra-tracer" Control.Tracer import Control.Tracer.Transformers +import Cardano.TraceDispatcher.BasicInfo.Types (BasicInfo) import Cardano.Slotting.Slot (EpochNo (..), SlotNo (..)) @@ -96,6 +98,7 @@ import Cardano.Tracing.Metrics import Cardano.Tracing.Queries import Cardano.Node.Configuration.Logging + -- For tracing instances import Cardano.Node.Protocol.Byron () import Cardano.Node.Protocol.Shelley () @@ -139,6 +142,7 @@ data Tracers peer localPeer blk = Tracers , handshakeTracer :: Tracer IO NtN.HandshakeTr , localHandshakeTracer :: Tracer IO NtC.HandshakeTr , diffusionInitializationTracer :: Tracer IO ND.DiffusionInitializationTracer + , basicInfoTracer :: Tracer IO BasicInfo } data ForgeTracers = ForgeTracers @@ -173,6 +177,7 @@ nullTracers = Tracers , handshakeTracer = nullTracer , localHandshakeTracer = nullTracer , diffusionInitializationTracer = nullTracer + , basicInfoTracer = nullTracer } @@ -276,11 +281,11 @@ instance (StandardHash header, Eq peer) => ElidingTracer mkTracers :: forall peer localPeer blk. ( Consensus.RunNode blk - , HasKESMetricsData blk - , HasKESInfo blk , TraceConstraints blk - , Show peer, Eq peer, ToObject peer - , Show localPeer, ToObject localPeer + , Show peer, Eq peer + , Show localPeer + , ToObject peer + , ToObject localPeer ) => BlockConfig blk -> TraceOptions @@ -316,12 +321,14 @@ mkTracers blockConfig tOpts@(TracingOn trSel) tr nodeKern ekgDirect = do , handshakeTracer = tracerOnOff (traceHandshake trSel) verb "Handshake" tr , localHandshakeTracer = tracerOnOff (traceLocalHandshake trSel) verb "LocalHandshake" tr , diffusionInitializationTracer = tracerOnOff (traceDiffusionInitialization trSel) verb "DiffusionInitializationTracer" tr + , basicInfoTracer = nullTracer } where verb :: TracingVerbosity verb = traceVerbosity trSel -mkTracers _ TracingOff _ _ _ = +-- otherwise tracing off +mkTracers _ _ _ _ _ = pure Tracers { chainDBTracer = nullTracer , consensusTracers = Consensus.Tracers @@ -364,6 +371,7 @@ mkTracers _ TracingOff _ _ _ = , handshakeTracer = nullTracer , localHandshakeTracer = nullTracer , diffusionInitializationTracer = nullTracer + , basicInfoTracer = nullTracer } -------------------------------------------------------------------------------- @@ -386,6 +394,7 @@ teeTraceChainTip -> Trace IO Text -> Tracer IO (WithSeverity (ChainDB.TraceEvent blk)) teeTraceChainTip _ _ TracingOff _ _ _ _ = nullTracer +teeTraceChainTip _ _ TraceDispatcher{} _ _ _ _ = nullTracer teeTraceChainTip blockConfig fStats (TracingOn trSel) elided ekgDirect trTrc trMet = Tracer $ \ev -> do traceWith (teeTraceChainTipElide (traceVerbosity trSel) elided trTrc) ev @@ -501,6 +510,7 @@ mkConsensusTracers :: forall blk peer localPeer. ( Show peer , Eq peer + , ToObject peer , LedgerQueries blk , ToJSON (GenTxId blk) , ToObject (ApplyTxErr blk) @@ -510,7 +520,6 @@ mkConsensusTracers , ToObject (OtherHeaderEnvelopeError blk) , ToObject (ValidationErr (BlockProtocol blk)) , ToObject (ForgeStateUpdateError blk) - , ToObject peer , Consensus.RunNode blk , HasKESMetricsData blk , HasKESInfo blk @@ -964,8 +973,8 @@ forgeStateInfoTracer p _ts tracer = Tracer $ \ev -> do -------------------------------------------------------------------------------- nodeToClientTracers' - :: ( ToObject localPeer - , ShowQuery (BlockQuery blk) + :: ( ShowQuery (BlockQuery blk) + , ToObject localPeer ) => TraceSelection -> TracingVerbosity diff --git a/scripts/lite/configuration/shelley-1.yaml b/scripts/lite/configuration/shelley-1.yaml index 00514723bde..cd41a224b18 100644 --- a/scripts/lite/configuration/shelley-1.yaml +++ b/scripts/lite/configuration/shelley-1.yaml @@ -255,3 +255,36 @@ options: mapSeverity: cardano.node.ChainDB: Notice cardano.node.DnsSubscription: Debug + +##### New logging model ##### + +UseTraceDispatcher: True + +TraceOptionSeverity: + - ns: '' + severity: InfoF + - ns: Node.AcceptPolicy + severity: SilenceF + - ns: Node.ChainDB + severity: DebugF +TraceOptionDetail: + - ns: '' + detail: DNormal + - ns: Node.BlockFetchClient + detail: DMinimal +TraceOptionBackend: + - ns: '' + backends: + - Stdout HumanFormatColoured + - Forwarder + - EKGBackend + - ns: Node.ChainDB + backends: + - Forwarder +TraceOptionLimiter: + - ns: Node.Resources + limiterName: ResourceLimiter + limiterFrequency: 1.0 +TraceOptionForwarder: + filePath: "/tmp/forwarder-1.sock" +TraceOptionForwardQueueSize: 780 diff --git a/scripts/lite/configuration/shelley-2.yaml b/scripts/lite/configuration/shelley-2.yaml index 00514723bde..d21327088b8 100644 --- a/scripts/lite/configuration/shelley-2.yaml +++ b/scripts/lite/configuration/shelley-2.yaml @@ -255,3 +255,36 @@ options: mapSeverity: cardano.node.ChainDB: Notice cardano.node.DnsSubscription: Debug + +##### New logging model ##### + +UseTraceDispatcher: True + +TraceOptionSeverity: + - ns: '' + severity: InfoF + - ns: Node.AcceptPolicy + severity: SilenceF + - ns: Node.ChainDB + severity: DebugF +TraceOptionDetail: + - ns: '' + detail: DNormal + - ns: Node.BlockFetchClient + detail: DMinimal +TraceOptionBackend: + - ns: '' + backends: + - Stdout HumanFormatColoured + - Forwarder + - EKGBackend + - ns: Node.ChainDB + backends: + - Forwarder +TraceOptionLimiter: + - ns: Node.Resources + limiterName: ResourceLimiter + limiterFrequency: 1.0 +TraceOptionForwarder: + filePath: "/tmp/forwarder-2.sock" +TraceOptionForwardQueueSize: 780 diff --git a/scripts/lite/configuration/shelley-3.yaml b/scripts/lite/configuration/shelley-3.yaml index 00514723bde..35241775dc6 100644 --- a/scripts/lite/configuration/shelley-3.yaml +++ b/scripts/lite/configuration/shelley-3.yaml @@ -255,3 +255,36 @@ options: mapSeverity: cardano.node.ChainDB: Notice cardano.node.DnsSubscription: Debug + +##### New logging model ##### + +UseTraceDispatcher: True + +TraceOptionSeverity: + - ns: '' + severity: InfoF + - ns: Node.AcceptPolicy + severity: SilenceF + - ns: Node.ChainDB + severity: DebugF +TraceOptionDetail: + - ns: '' + detail: DNormal + - ns: Node.BlockFetchClient + detail: DMinimal +TraceOptionBackend: + - ns: '' + backends: + - Stdout HumanFormatColoured + - Forwarder + - EKGBackend + - ns: Node.ChainDB + backends: + - Forwarder +TraceOptionLimiter: + - ns: Node.Resources + limiterName: ResourceLimiter + limiterFrequency: 1.0 +TraceOptionForwarder: + filePath: "/tmp/forwarder-3.sock" +TraceOptionForwardQueueSize: 780