diff --git a/README.md b/README.md index 1562249e7ef..5abbfe4c30b 100644 --- a/README.md +++ b/README.md @@ -23,7 +23,7 @@ This is an approximate diagram of the dependencies among the different component ```mermaid stateDiagram-v2 cn: cardano-node - tr: trace-dispatcher/iohk-monitoring-framework + tr: trace-dispatcher ca: cardano-api co: ouroboros-consensus on: ouroboros-network diff --git a/bench/cardano-profile/data/all-profiles-coay.json b/bench/cardano-profile/data/all-profiles-coay.json index fdb6b71697b..b6ac3c98162 100644 --- a/bench/cardano-profile/data/all-profiles-coay.json +++ b/bench/cardano-profile/data/all-profiles-coay.json @@ -7304,7 +7304,7 @@ "shutdown_on_slot_synced": 38901589, "ssd_directory": null, "tracer": false, - "tracing_backend": "iohk-monitoring", + "tracing_backend": "trace-dispatcher", "utxo_lmdb": false, "utxo_lsmt": false, "verbatim": { @@ -8483,7 +8483,7 @@ "shutdown_on_slot_synced": 237599, "ssd_directory": null, "tracer": false, - "tracing_backend": "iohk-monitoring", + "tracing_backend": "trace-dispatcher", "utxo_lmdb": false, "utxo_lsmt": false, "verbatim": { @@ -11275,7 +11275,7 @@ "shutdown_on_slot_synced": null, "ssd_directory": null, "tracer": false, - "tracing_backend": "iohk-monitoring", + "tracing_backend": "trace-dispatcher", "utxo_lmdb": false, "utxo_lsmt": false, "verbatim": { @@ -19089,7 +19089,7 @@ "shutdown_on_slot_synced": null, "ssd_directory": null, "tracer": true, - "tracing_backend": "iohk-monitoring", + "tracing_backend": "trace-dispatcher", "utxo_lmdb": false, "utxo_lsmt": false, "verbatim": { @@ -25425,7 +25425,7 @@ "shutdown_on_slot_synced": null, "ssd_directory": null, "tracer": true, - "tracing_backend": "iohk-monitoring", + "tracing_backend": "trace-dispatcher", "utxo_lmdb": false, "utxo_lsmt": false, "verbatim": { @@ -46190,7 +46190,7 @@ "shutdown_on_slot_synced": null, "ssd_directory": null, "tracer": true, - "tracing_backend": "iohk-monitoring", + "tracing_backend": "trace-dispatcher", "utxo_lmdb": false, "utxo_lsmt": false, "verbatim": { @@ -46614,7 +46614,7 @@ "shutdown_on_slot_synced": null, "ssd_directory": null, "tracer": true, - "tracing_backend": "iohk-monitoring", + "tracing_backend": "trace-dispatcher", "utxo_lmdb": false, "utxo_lsmt": false, "verbatim": { @@ -75372,7 +75372,7 @@ "shutdown_on_slot_synced": null, "ssd_directory": null, "tracer": true, - "tracing_backend": "iohk-monitoring", + "tracing_backend": "trace-dispatcher", "utxo_lmdb": false, "utxo_lsmt": false, "verbatim": { @@ -82455,7 +82455,7 @@ "shutdown_on_slot_synced": 64000, "ssd_directory": null, "tracer": true, - "tracing_backend": "iohk-monitoring", + "tracing_backend": "trace-dispatcher", "utxo_lmdb": false, "utxo_lsmt": false, "verbatim": { diff --git a/bench/cardano-profile/src/Cardano/Benchmarking/Profile/Primitives.hs b/bench/cardano-profile/src/Cardano/Benchmarking/Profile/Primitives.hs index 7f45339454a..36bee49f6b4 100644 --- a/bench/cardano-profile/src/Cardano/Benchmarking/Profile/Primitives.hs +++ b/bench/cardano-profile/src/Cardano/Benchmarking/Profile/Primitives.hs @@ -622,7 +622,7 @@ oldTracing = node (\n -> if Types.tracing_backend n /= "" then error "oldTracing: `tracing_backend` already set (not empty)." - else n {Types.tracing_backend = "iohk-monitoring"} + else n {Types.tracing_backend = "trace-dispatcher"} ) -- "--shutdown-on-*". diff --git a/bench/cardano-topology/src/Cardano/Benchmarking/Topology/Projection.hs b/bench/cardano-topology/src/Cardano/Benchmarking/Topology/Projection.hs index 0fbe8a4692e..692ed5e0b72 100644 --- a/bench/cardano-topology/src/Cardano/Benchmarking/Topology/Projection.hs +++ b/bench/cardano-topology/src/Cardano/Benchmarking/Topology/Projection.hs @@ -359,9 +359,7 @@ data AfterSlot = | After SlotNo deriving (Eq, Show) --- `FromJSON`/`ToJSON` from "Cardano.Tracing.OrphanInstances.Network". - --- https://github.com/IntersectMBO/cardano-node/blob/52b708f37cd3dc92a188717deae2a6a60117f696/cardano-node/src/Cardano/Tracing/OrphanInstances/Network.hs#L2784 +-- `FromJSON`/`ToJSON`. instance Aeson.FromJSON UseLedgerPeers where parseJSON (Aeson.Number slot) = return $ @@ -372,8 +370,6 @@ instance Aeson.FromJSON UseLedgerPeers where parseJSON invalid = fail $ "Parsing of slot number failed due to type mismatch. " <> "Encountered: " <> show invalid --- https://github.com/IntersectMBO/cardano-node/blob/52b708f37cd3dc92a188717deae2a6a60117f696/cardano-node/src/Cardano/Tracing/OrphanInstances/Network.hs#L2811 - instance Aeson.ToJSON UseLedgerPeers where toJSON DontUseLedgerPeers = Aeson.Number (-1) toJSON (UseLedgerPeers Always) = Aeson.Number 0 @@ -409,11 +405,9 @@ newtype HotValency = HotValency { getHotValency :: Int } newtype WarmValency = WarmValency { getWarmValency :: Int } deriving (Show, Eq, Ord) --- `FromJSON`/`ToJSON` from "Cardano.Tracing.OrphanInstances.Network". +-- `FromJSON`/`ToJSON`. -- Replaced `HotValency` and `WarmValency` with `Valency`. --- https://github.com/IntersectMBO/cardano-node/blob/52b708f37cd3dc92a188717deae2a6a60117f696/cardano-node/src/Cardano/Tracing/OrphanInstances/Network.hs#L1638 - instance Aeson.ToJSON Valency where toJSON (Valency v) = Aeson.toJSON v @@ -449,9 +443,7 @@ data PeerTrustable = | IsNotTrustable deriving (Eq, Show, Ord, Generic) --- `FromJSON`/`ToJSON` from "Cardano.Tracing.OrphanInstances.Network". - --- https://github.com/IntersectMBO/cardano-node/blob/52b708f37cd3dc92a188717deae2a6a60117f696/cardano-node/src/Cardano/Tracing/OrphanInstances/Network.hs#L2824 +-- `FromJSON`/`ToJSON`. instance Aeson.FromJSON PeerTrustable where parseJSON = Aeson.withBool "PeerTrustable" $ \b -> @@ -473,9 +465,7 @@ data UseBootstrapPeers = | UseBootstrapPeers [RelayAccessPoint] deriving (Eq, Show, Ord, Generic) --- `FromJSON`/`ToJSON` from "Cardano.Tracing.OrphanInstances.Network". - --- https://github.com/IntersectMBO/cardano-node/blob/52b708f37cd3dc92a188717deae2a6a60117f696/cardano-node/src/Cardano/Tracing/OrphanInstances/Network.hs#L2816 +-- `FromJSON`/`ToJSON`. instance Aeson.ToJSON UseBootstrapPeers where toJSON DontUseBootstrapPeers = Aeson.Null diff --git a/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/Submission.hs b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/Submission.hs index af229b362f0..35512fdfe8e 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/Submission.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/Submission.hs @@ -39,11 +39,6 @@ import qualified Streaming.Prelude as Streaming import Data.Time.Clock (NominalDiffTime, UTCTime) import qualified Data.Time.Clock as Clock -import Cardano.Tracing.OrphanInstances.Byron () -import Cardano.Tracing.OrphanInstances.Common () -import Cardano.Tracing.OrphanInstances.Consensus () -import Cardano.Tracing.OrphanInstances.Network () -import Cardano.Tracing.OrphanInstances.Shelley () import Ouroboros.Network.Protocol.TxSubmission2.Type (SingBlockingStyle (..)) diff --git a/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/SubmissionClient.hs b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/SubmissionClient.hs index b7bf32fd6ba..312466573ad 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/SubmissionClient.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/SubmissionClient.hs @@ -30,11 +30,6 @@ import Cardano.Benchmarking.Types import qualified Cardano.Ledger.Core as Ledger import Cardano.Logging import Cardano.Prelude hiding (ByteString, atomically, retry, state, threadDelay) -import Cardano.Tracing.OrphanInstances.Byron () -import Cardano.Tracing.OrphanInstances.Common () -import Cardano.Tracing.OrphanInstances.Consensus () -import Cardano.Tracing.OrphanInstances.Network () -import Cardano.Tracing.OrphanInstances.Shelley () import qualified Ouroboros.Consensus.Cardano as Consensus (CardanoBlock) import qualified Ouroboros.Consensus.Cardano.Block as Block (TxId (GenTxIdAllegra, GenTxIdAlonzo, GenTxIdBabbage, GenTxIdConway, GenTxIdMary, GenTxIdShelley)) diff --git a/bench/tx-generator/src/Cardano/Benchmarking/LogTypes.hs b/bench/tx-generator/src/Cardano/Benchmarking/LogTypes.hs index 61b642d5b8d..6a67daea14d 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/LogTypes.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/LogTypes.hs @@ -29,11 +29,6 @@ import Cardano.Benchmarking.Types import Cardano.Benchmarking.Version as Version import Cardano.Logging import Cardano.Network.NodeToNode (NodeToNodeVersion, RemoteConnectionId) -import Cardano.Tracing.OrphanInstances.Byron () -import Cardano.Tracing.OrphanInstances.Common () -import Cardano.Tracing.OrphanInstances.Consensus () -import Cardano.Tracing.OrphanInstances.Network () -import Cardano.Tracing.OrphanInstances.Shelley () import Cardano.TxGenerator.PlutusContext (PlutusBudgetSummary) import Cardano.TxGenerator.Setup.NixService (NixServiceOptions (..)) import Cardano.TxGenerator.Types (TPSRate) diff --git a/bench/tx-generator/src/Cardano/Benchmarking/OuroborosImports.hs b/bench/tx-generator/src/Cardano/Benchmarking/OuroborosImports.hs index f16d6dd0f69..abd5a10c54f 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/OuroborosImports.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/OuroborosImports.hs @@ -7,7 +7,6 @@ module Cardano.Benchmarking.OuroborosImports ( CardanoBlock , LocalSubmitTx - , LoggingLayer , PaymentKey , ShelleyGenesis , SigningKey @@ -27,7 +26,6 @@ import Cardano.Api (BlockType (..), ConsensusModeParams (..), EpochSlo import Cardano.CLI.Type.Common (SigningKeyFile) import Cardano.Ledger.Shelley.Genesis (ShelleyGenesis) -import Cardano.Node.Configuration.Logging (LoggingLayer) import Cardano.Node.Protocol.Types (SomeConsensusProtocol (..)) import Ouroboros.Consensus.Block.Abstract import qualified Ouroboros.Consensus.Cardano as Consensus diff --git a/cabal.project b/cabal.project index 7d699e8d362..089394c51af 100644 --- a/cabal.project +++ b/cabal.project @@ -78,9 +78,6 @@ package bitvec package plutus-scripts-bench haddock-options: "--optghc=-fplugin-opt PlutusTx.Plugin:defer-errors" -allow-newer: - , katip:Win32 - -- There is a suspected bug in `cabal` (https://github.com/haskell/cabal/issues/11663) -- that can be worked around with the following allow-newer stanzas allow-newer: @@ -90,4 +87,3 @@ allow-newer: -- IMPORTANT -- Do NOT add more source-repository-package stanzas here unless they are strictly -- temporary! Please read the section in CONTRIBUTING about updating dependencies. - diff --git a/cardano-node/cardano-node.cabal b/cardano-node/cardano-node.cabal index da3d9cc7b07..2614d7d7884 100644 --- a/cardano-node/cardano-node.cabal +++ b/cardano-node/cardano-node.cabal @@ -55,13 +55,11 @@ library if os(linux) && flag(systemd) cpp-options: -DSYSTEMD - build-depends: lobemo-scribe-systemd - , systemd >= 2.3.0 + build-depends: systemd >= 2.3.0 hs-source-dirs: src - exposed-modules: Cardano.Node.Configuration.Logging - Cardano.Node.Configuration.NodeAddress + exposed-modules: Cardano.Node.Configuration.NodeAddress Cardano.Node.Configuration.POM Cardano.Node.Configuration.LedgerDB Cardano.Node.Configuration.Socket @@ -88,7 +86,6 @@ library Cardano.Node.TraceConstraints Cardano.Node.Tracing Cardano.Node.Tracing.API - Cardano.Node.Tracing.Compat Cardano.Node.Tracing.Consistency Cardano.Node.Tracing.DefaultTraceConfig Cardano.Node.Tracing.Documentation @@ -114,21 +111,9 @@ library Cardano.Node.Tracing.Tracers.Resources Cardano.Node.Tracing.Tracers.Rpc Cardano.Node.Tracing.Tracers.Shutdown + Cardano.Node.Tracing.Tracers.HasIssuer Cardano.Node.Tracing.Tracers.Startup Cardano.Node.Types - Cardano.Tracing.Config - Cardano.Tracing.HasIssuer - Cardano.Tracing.Metrics - Cardano.Tracing.OrphanInstances.Byron - Cardano.Tracing.OrphanInstances.Common - Cardano.Tracing.OrphanInstances.Consensus - Cardano.Tracing.OrphanInstances.HardFork - Cardano.Tracing.OrphanInstances.Network - Cardano.Tracing.OrphanInstances.Shelley - Cardano.Tracing.Render - Cardano.Tracing.Shutdown - Cardano.Tracing.Startup - Cardano.Tracing.Tracers other-modules: Paths_cardano_node autogen-modules: Paths_cardano_node @@ -164,38 +149,30 @@ library , deepseq , directory , dns - , ekg-wai , ekg-core , filepath , generic-data , hashable , hostname , io-classes:{io-classes,strict-stm,si-timers} ^>= 1.8 - , iohk-monitoring ^>= 0.2 , kes-agent ^>=1.2 , microlens , mmap , network-mux , iproute - , lobemo-backend-aggregation - , lobemo-backend-ekg ^>= 0.2 - , lobemo-backend-monitoring - , lobemo-backend-trace-forwarder - , mtl , network , network-mux >= 0.8 , nothunks , optparse-applicative , ouroboros-consensus:{ouroboros-consensus, lmdb, lsm, cardano, diffusion, protocol} ^>= 3.0.1 , ouroboros-network:{api, ouroboros-network, orphan-instances, framework, protocols, framework-tracing, tracing} ^>= 1.1 - , cardano-diffusion:{api, cardano-diffusion, orphan-instances, tracing} ^>=1.0 + , cardano-diffusion:{api, cardano-diffusion, tracing, orphan-instances} ^>=1.0 , prettyprinter , prettyprinter-ansi-terminal , psqueues , random , resource-registry , safe-exceptions - , scientific , sop-core -- avoid stm-2.5.2 https://github.com/haskell/stm/issues/76 , stm <2.5.2 || >=2.5.3 @@ -207,7 +184,6 @@ library , trace-dispatcher ^>= 2.12.0 , trace-forward ^>= 2.4.0 , trace-resources ^>= 0.2.4 - , tracer-transformers , transformers , transformers-except , typed-protocols:{typed-protocols, stateful} >= 1.2 @@ -250,7 +226,6 @@ test-suite cardano-node-test , cardano-api , cardano-rpc , cardano-diffusion:{api, cardano-diffusion, orphan-instances} - , cardano-protocol-tpraos , cardano-node , cardano-slotting , contra-tracer @@ -261,9 +236,8 @@ test-suite cardano-node-test , hedgehog-extras ^>= 0.10 , iproute , mtl - , ouroboros-consensus:{ouroboros-consensus, cardano, diffusion} + , ouroboros-consensus:{ouroboros-consensus, diffusion} , ouroboros-network:{api, framework, ouroboros-network} - , strict-sop-core , text , trace-dispatcher , transformers @@ -276,6 +250,5 @@ test-suite cardano-node-test Test.Cardano.Node.Json Test.Cardano.Node.POM Test.Cardano.Tracing.NewTracing.Consistency - Test.Cardano.Tracing.OrphanInstances.HardFork ghc-options: -threaded -rtsopts "-with-rtsopts=-N -T" diff --git a/cardano-node/src/Cardano/Node/Configuration/Logging.hs b/cardano-node/src/Cardano/Node/Configuration/Logging.hs deleted file mode 100644 index 065f7d379f1..00000000000 --- a/cardano-node/src/Cardano/Node/Configuration/Logging.hs +++ /dev/null @@ -1,381 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PackageImports #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} - -module Cardano.Node.Configuration.Logging - ( LoggingLayer (..) - , EKGDirect(..) - , createLoggingLayer - , nodeBasicInfo - , shutdownLoggingLayer - , traceCounter - -- re-exports - , Trace - , Configuration - , LoggerName - , Severity (..) - , mkLOMeta - , LOMeta (..) - , LOContent (..) - ) where - -import Cardano.Api (textShow) -import qualified Cardano.Api as Api - -import Cardano.BM.Backend.Aggregation (plugin) -import Cardano.BM.Backend.EKGView (plugin) -import Cardano.BM.Backend.Monitoring (plugin) -import Cardano.BM.Backend.Switchboard (Switchboard) -import qualified Cardano.BM.Backend.Switchboard as Switchboard -import Cardano.BM.Backend.TraceForwarder (plugin) -import Cardano.BM.Configuration (Configuration) -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 qualified Cardano.BM.Observer.Monadic as Monadic -import qualified Cardano.BM.Observer.STM as Stm -import Cardano.BM.Plugin (loadPlugin) -#ifdef SYSTEMD -import Cardano.BM.Scribe.Systemd (plugin) -#endif -import Cardano.BM.Setup (setupTrace_, shutdown) -import Cardano.BM.Stats -import Cardano.BM.Stats.Resources -import qualified Cardano.BM.Trace as Trace -import Cardano.BM.Tracing -import qualified Cardano.Chain.Genesis as Gen -import Cardano.Git.Rev (gitRev) -import qualified Cardano.Ledger.Shelley.API as SL -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 qualified Ouroboros.Consensus.BlockchainTime.WallClock.Types as WCT -import Ouroboros.Consensus.Byron.ByronHFC (byronLedgerConfig) -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.HardFork.Combinator.Degenerate -import Ouroboros.Consensus.Node.ProtocolInfo -import Ouroboros.Consensus.Shelley.Ledger.Ledger - -import qualified Control.Concurrent as Conc -import qualified Control.Concurrent.Async as Async -import Control.Concurrent.MVar (MVar, newMVar) -import Control.Concurrent.STM (STM) -import Control.Exception (IOException) -import Control.Exception.Safe (MonadCatch) -import Control.Monad -import Control.Monad.Except (ExceptT) -import Control.Monad.IO.Class (MonadIO (..)) -import Control.Monad.Trans.Except.Extra (catchIOExceptT) -import Data.List (nub) -import qualified Data.Map.Strict as Map -import Data.Maybe (isJust) -import Data.Text (Text, pack) -import Data.Time.Clock (UTCTime, getCurrentTime) -import Data.Version (showVersion) -import GHC.Conc (labelThread, myThreadId) -import System.Metrics.Counter (Counter) -import System.Metrics.Gauge (Gauge) -import System.Metrics.Label (Label) -import qualified System.Remote.Monitoring.Wai as EKG - -import Paths_cardano_node (version) - --------------------------------- --- Layer --------------------------------- - --- | The LoggingLayer interface that we can expose. --- We want to do this since we want to be able to mock out any function tied to logging. --- --- The good side of this is that _each function has it's own effects_ --- and that is ideal for tracking the functions effects and constraining --- the user (programmer) of those function to use specific effects in them. --- https://github.com/input-output-hk/cardano-sl/blob/develop/util/src/Pos/Util/Log/LogSafe.hs -data LoggingLayer = LoggingLayer - { llBasicTrace :: forall m. (MonadIO m) => Trace m Text - , llLogDebug :: forall m a. (MonadIO m, Show a) => Trace m a -> a -> m () - , llLogInfo :: forall m a. (MonadIO m, Show a) => Trace m a -> a -> m () - , llLogNotice :: forall m a. (MonadIO m, Show a) => Trace m a -> a -> m () - , llLogWarning :: forall m a. (MonadIO m, Show a) => Trace m a -> a -> m () - , llLogError :: forall m a. (MonadIO m, Show a) => Trace m a -> a -> m () - , llAppendName :: forall m a. (Show a) => LoggerName -> Trace m a -> Trace m a - , llBracketMonadIO :: forall a t. (Show a) => Trace IO a -> Severity -> Text -> IO t -> IO t - , llBracketMonadM - :: forall m a t. (MonadCatch m, MonadIO m, Show a) - => Trace m a -> Severity -> Text -> m t -> m t - , llBracketMonadX - :: forall m a t. (MonadIO m, Show a) => Trace m a -> Severity -> Text -> m t -> m t - , llBracketStmIO :: forall a t. (Show a) => Trace IO a -> Severity -> Text -> STM t -> IO t - , llBracketStmLogIO - :: forall a t. (Show a) - => Trace IO a -> Severity -> Text -> STM (t,[(LOMeta, LOContent a)]) -> IO t - , llConfiguration :: Configuration - , llAddBackend :: Backend Text -> BackendKind -> IO () - , llSwitchboard :: Switchboard Text - , llEKGDirect :: Maybe EKGDirect - } - -data EKGDirect = EKGDirect - { ekgServer :: EKG.Server - , ekgGauges :: MVar (Map.Map Text Gauge) - , ekgLabels :: MVar (Map.Map Text Label) - , ekgCounters :: MVar (Map.Map Text Counter) - } - --------------------------------- --- Feature --------------------------------- - --- | Either parse a filepath into a logging 'Configuration', --- or supply a mute 'Configuration'. -loggingCLIConfiguration - :: Maybe FilePath - -> ExceptT ConfigError IO Configuration -loggingCLIConfiguration = maybe emptyConfig readConfig - where - readConfig :: FilePath -> ExceptT ConfigError IO Configuration - readConfig fp = - catchIOExceptT (Config.setup fp) $ \(_ :: IOException) -> ConfigErrorFileNotFound fp - - emptyConfig :: ExceptT ConfigError IO Configuration - emptyConfig = liftIO $ do - c <- Config.empty - Config.setMinSeverity c Info - pure c - --- | Create logging feature for `cardano-node` -createLoggingLayer - :: Text - -> NodeConfiguration - -> SomeConsensusProtocol - -> ExceptT ConfigError IO LoggingLayer -createLoggingLayer ver nodeConfig' p = do - logConfig <- loggingCLIConfiguration $ - if ncLoggingSwitch nodeConfig' - -- Re-interpret node config again, as logging 'Configuration': - then Just . unConfigPath $ ncConfigFile nodeConfig' - else Nothing - - -- These have to be set before the switchboard is set up. - liftIO $ do - Config.setTextOption logConfig "appversion" ver - Config.setTextOption logConfig "appcommit" $(gitRev) - - (baseTrace', switchBoard) <- liftIO $ setupTrace_ logConfig "cardano" - - let loggingEnabled :: Bool - loggingEnabled = ncLoggingSwitch nodeConfig' - trace :: Trace IO Text - trace = if loggingEnabled - then baseTrace' - else Trace.nullTracer - - when loggingEnabled $ liftIO $ - loggingPreInit nodeConfig' logConfig switchBoard trace - - mbEKGServer <- liftIO $ Switchboard.getSbEKGServer switchBoard - - mbEkgDirect <- case mbEKGServer of - Nothing -> pure Nothing - Just sv -> do - refGauge <- liftIO $ newMVar Map.empty - refLabel <- liftIO $ newMVar Map.empty - refCounter <- liftIO $ newMVar Map.empty - pure $ Just EKGDirect { - ekgServer = sv - , ekgGauges = refGauge - , ekgLabels = refLabel - , ekgCounters = refCounter - } - - pure $ mkLogLayer logConfig switchBoard mbEkgDirect trace - where - loggingPreInit - :: NodeConfiguration - -> Configuration - -> Switchboard Text - -> Trace IO Text - -> IO () - loggingPreInit nodeConfig logConfig switchBoard trace = do - Config.getEKGBindAddr logConfig >>= \mbEndpoint -> - when (isJust mbEndpoint) $ - Cardano.BM.Backend.EKGView.plugin logConfig trace switchBoard - >>= loadPlugin switchBoard - - Config.getForwardTo logConfig >>= \forwardTo -> - when (isJust forwardTo) $ do - -- Since the configuration contains 'traceForwardTo' section, - -- node's information (metrics/peers/errors) should be forwarded - -- to an external process (for example, RTView). - - -- Activate TraceForwarder plugin (there is no need to add 'TraceForwarderBK' - -- to 'setupBackends' list). - nodeStartTime <- getCurrentTime - Cardano.BM.Backend.TraceForwarder.plugin logConfig - trace - switchBoard - "forwarderMinSeverity" - (nodeBasicInfo nodeConfig p nodeStartTime) - >>= loadPlugin switchBoard - - -- Forward all the metrics/peers/errors to 'TraceForwarderBK' using 'mapBackends'. - -- If 'TraceForwarderBK' is already added in 'mapBackends' - ignore it. - let metricsLogger = "cardano.node.metrics" -- All metrics and peers info are here. - errorsLoggers = "cardano.node" -- All errors (messages with 'Warning+' severity) are here. - - forM_ [metricsLogger, errorsLoggers] $ \loggerName -> - Config.getBackends logConfig loggerName >>= \backends -> - unless (TraceForwarderBK `elem` backends) $ - Config.setBackends logConfig loggerName $ Just (TraceForwarderBK : backends) - - Cardano.BM.Backend.Aggregation.plugin logConfig trace switchBoard - >>= loadPlugin switchBoard - Cardano.BM.Backend.Monitoring.plugin logConfig trace switchBoard - >>= loadPlugin switchBoard - -#if defined(SYSTEMD) - Cardano.BM.Scribe.Systemd.plugin logConfig trace switchBoard "cardano" - >>= loadPlugin switchBoard -#endif - - when (ncLogMetrics nodeConfig) $ - -- Record node metrics, if configured - startCapturingResources (ncTraceConfig nodeConfig) trace - - mkLogLayer :: Configuration -> Switchboard Text -> Maybe EKGDirect -> Trace IO Text -> LoggingLayer - mkLogLayer logConfig switchBoard mbEkgDirect trace = - LoggingLayer - { llBasicTrace = Trace.natTrace liftIO trace - , llLogDebug = Trace.logDebug - , llLogInfo = Trace.logInfo - , llLogNotice = Trace.logNotice - , llLogWarning = Trace.logWarning - , llLogError = Trace.logError - , llAppendName = Trace.appendName - , llBracketMonadIO = Monadic.bracketObserveIO logConfig - , llBracketMonadM = Monadic.bracketObserveM logConfig - , llBracketMonadX = Monadic.bracketObserveX logConfig - , llBracketStmIO = Stm.bracketObserveIO logConfig - , llBracketStmLogIO = Stm.bracketObserveLogIO logConfig - , llConfiguration = logConfig - , llAddBackend = Switchboard.addExternalBackend switchBoard - , llSwitchboard = switchBoard - , llEKGDirect = mbEkgDirect - } - - startCapturingResources :: TraceOptions - -> Trace IO Text - -> IO () - startCapturingResources (TraceDispatcher _) _tr = do - pure () - - startCapturingResources _ tr = do - void . Async.async $ do - myThreadId >>= flip labelThread "Resource capturing (old tracing)" - forever $ do - readResourceStats - >>= maybe (pure ()) - (traceResourceStats - (appendName "node" tr)) - Conc.threadDelay 1000000 -- microseconds = 1 sec - - traceResourceStats :: Trace IO Text -> ResourceStats -> IO () - traceResourceStats tr rs = do - traceWith (toLogObject' NormalVerbosity $ appendName "resources" tr) rs - traceCounter "Stat.cputicks" tr . fromIntegral $ rCentiCpu rs - traceCounter "Mem.resident" tr . fromIntegral $ rRSS rs - traceCounter "RTS.gcLiveBytes" tr . fromIntegral $ rLive rs - traceCounter "RTS.gcHeapBytes" tr . fromIntegral $ rHeap rs - traceCounter "RTS.gcMajorNum" tr . fromIntegral $ rGcsMajor rs - traceCounter "RTS.gcMinorNum" tr . fromIntegral $ rGcsMinor rs - traceCounter "RTS.gcticks" tr . fromIntegral $ rCentiGC rs - traceCounter "RTS.mutticks" tr . fromIntegral $ rCentiMut rs - traceCounter "Stat.threads" tr . fromIntegral $ rThreads rs - -traceCounter - :: Text - -> Trace IO Text - -> Int - -> IO () -traceCounter logValueName tracer aCounter = do - meta <- mkLOMeta Notice Public - Trace.traceNamedObject - (appendName "metrics" tracer) - (meta, LogValue logValueName (PureI $ fromIntegral aCounter)) - -shutdownLoggingLayer :: LoggingLayer -> IO () -shutdownLoggingLayer = shutdown . llSwitchboard - --- The node provides the basic node's information for TraceForwarderBK. --- It will be sent once TraceForwarderBK is connected to an external process --- (for example, RTView). --- --- TODO: it should return 'StartupTrace' rather than raw 'LogObject's. --- -nodeBasicInfo :: NodeConfiguration - -> SomeConsensusProtocol - -> UTCTime - -> IO [LogObject Text] -nodeBasicInfo nc (SomeConsensusProtocol whichP pForInfo) nodeStartTime' = do - meta <- mkLOMeta Notice Public - let cfg = pInfoConfig $ fst $ Api.protocolInfo @IO pForInfo - protocolDependentItems = - case whichP of - Api.ByronBlockType -> - let DegenLedgerConfig cfgByron = Consensus.configLedger cfg - in getGenesisValuesByron cfg cfgByron - Api.ShelleyBlockType -> - let DegenLedgerConfig cfgShelley = Consensus.configLedger cfg - in getGenesisValues "Shelley" cfgShelley - Api.CardanoBlockType -> - let CardanoLedgerConfig cfgByron cfgShelley cfgAllegra cfgMary cfgAlonzo - cfgBabbage cfgConway cfgDjikstra = Consensus.configLedger cfg - in getGenesisValuesByron cfg cfgByron - ++ getGenesisValues "Shelley" cfgShelley - ++ getGenesisValues "Allegra" cfgAllegra - ++ getGenesisValues "Mary" cfgMary - ++ getGenesisValues "Alonzo" cfgAlonzo - ++ getGenesisValues "Babbage" cfgBabbage - ++ getGenesisValues "Conway" cfgConway - ++ getGenesisValues "Djikstra" cfgDjikstra - items = nub $ - [ ("protocol", pack . show $ ncProtocol nc) - , ("version", pack . showVersion $ version) - , ("commit", $(gitRev)) - , ("nodeStartTime", textShow nodeStartTime') - ] ++ protocolDependentItems - logObjects = - map (\(nm, msg) -> LogObject ("basicInfo." <> nm) meta (LogMessage msg)) items - return logObjects - where - getGenesisValuesByron cfg config = - let genesis = byronLedgerConfig config - in [ ("systemStartTime", textShow (WCT.getSystemStart . getSystemStart $ Consensus.configBlock cfg)) - , ("slotLengthByron", textShow (WCT.getSlotLength . fromByronSlotLength $ genesisSlotLength genesis)) - , ("epochLengthByron", textShow (unEpochSize . fromByronEpochSlots $ Gen.configEpochSlots genesis)) - ] - getGenesisValues era config = - let genesis = shelleyLedgerGenesis $ shelleyLedgerConfig config - in [ ("systemStartTime", textShow (SL.sgSystemStart genesis)) - , ("slotLength" <> era, textShow (WCT.getSlotLength - . WCT.mkSlotLength - . SL.fromNominalDiffTimeMicro - $ SL.sgSlotLength genesis)) - , ("epochLength" <> era, textShow (unEpochSize . SL.sgEpochLength $ genesis)) - , ("slotsPerKESPeriod" <> era, textShow (SL.sgSlotsPerKESPeriod genesis)) - ] diff --git a/cardano-node/src/Cardano/Node/Configuration/POM.hs b/cardano-node/src/Cardano/Node/Configuration/POM.hs index 980b30003ba..c49f4533273 100644 --- a/cardano-node/src/Cardano/Node/Configuration/POM.hs +++ b/cardano-node/src/Cardano/Node/Configuration/POM.hs @@ -39,8 +39,6 @@ import Cardano.Node.Protocol.Types (Protocol (..)) import Cardano.Node.Types import Cardano.Rpc.Server.Config (PartialRpcConfig, RpcConfig, RpcConfigF (..), makeRpcConfig) -import Cardano.Tracing.Config -import Cardano.Tracing.OrphanInstances.Network () import Ouroboros.Consensus.Ledger.SupportsMempool import Ouroboros.Consensus.Mempool (MempoolCapacityBytesOverride (..)) import Ouroboros.Consensus.Node (NodeDatabasePaths (..)) @@ -61,7 +59,6 @@ import Control.Concurrent (getNumCapabilities) import Control.Monad (unless, void, when) import Data.Aeson import qualified Data.Aeson.Types as Aeson -import Data.Bifunctor (Bifunctor (..)) import Data.Hashable (Hashable) import Data.Maybe import Data.Monoid (Last (..)) @@ -121,10 +118,6 @@ data NodeConfiguration , ncMaxConcurrencyBulkSync :: !(Maybe MaxConcurrencyBulkSync) , ncMaxConcurrencyDeadline :: !(Maybe MaxConcurrencyDeadline) - -- Logging parameters: - , ncLoggingSwitch :: !Bool - , ncLogMetrics :: !Bool - , ncTraceConfig :: !TraceOptions , ncTraceForwardSocket :: !(Maybe (HowToConnect, ForwarderMode)) , ncMaybeMempoolCapacityOverride :: !(Maybe MempoolCapacityBytesOverride) @@ -253,10 +246,6 @@ data PartialNodeConfiguration , pncMaxConcurrencyBulkSync :: !(Last MaxConcurrencyBulkSync) , pncMaxConcurrencyDeadline :: !(Last MaxConcurrencyDeadline) - -- Logging parameters: - , pncLoggingSwitch :: !(Last Bool) - , pncLogMetrics :: !(Last Bool) - , pncTraceConfig :: !(Last PartialTraceOptions) , pncTraceForwardSocket :: !(Last (HowToConnect, ForwarderMode)) -- Configuration for testing purposes @@ -352,18 +341,6 @@ instance FromJSON PartialNodeConfiguration where pncMaxConcurrencyBulkSync <- Last <$> v .:? "MaxConcurrencyBulkSync" pncMaxConcurrencyDeadline <- Last <$> v .:? "MaxConcurrencyDeadline" - -- Logging parameters - pncLoggingSwitch' <- v .:? "TurnOnLogging" .!= True - pncLogMetrics <- Last <$> v .:? "TurnOnLogMetrics" - useTraceDispatcher <- v .:? "UseTraceDispatcher" .!= True - pncTraceConfig <- if pncLoggingSwitch' - then do - partialTraceSelection <- parseJSON $ Object v - if useTraceDispatcher - then return $ Last $ Just $ PartialTraceDispatcher partialTraceSelection - else return $ Last $ Just $ PartialTracingOnLegacy partialTraceSelection - else return $ Last $ Just PartialTracingOff - -- Protocol parameters protocol <- v .:? "Protocol" .!= CardanoProtocol pncProtocolConfig <- @@ -392,7 +369,7 @@ instance FromJSON PartialNodeConfiguration where -- AcceptedConnectionsLimit pncAcceptedConnectionsLimit - <- Last <$> v .:? "AcceptedConnectionsLimit" + <- Last <$> optionalField parseAcceptedConnectionsLimit v "AcceptedConnectionsLimit" -- P2P Governor parameters, with conservative defaults. pncDeadlineTargetOfRootPeers <- Last <$> v .:? "TargetNumberOfRootPeers" @@ -422,7 +399,7 @@ instance FromJSON PartialNodeConfiguration where pncMempoolTimeoutCapacity <- Last <$> v .:? "MempoolTimeoutCapacity" -- Peer Sharing - pncPeerSharing <- Last <$> v .:? "PeerSharing" + pncPeerSharing <- Last . fmap peerSharingFromBool <$> v .:? "PeerSharing" -- pncConsensusMode determines whether Genesis is enabled in the first place. pncGenesisConfigFlags <- Last <$> v .:? "LowLevelGenesisOptions" @@ -438,7 +415,7 @@ instance FromJSON PartialNodeConfiguration where <*> (Last <$> v .:? "RpcSocketPath") <*> pure mempty - txSubmissionLogicVersion <- Last <$> v .:? "TxSubmissionLogicVersion" + txSubmissionLogicVersion <- Last <$> optionalField parseTxSubmissionLogicVersion v "TxSubmissionLogicVersion" let parseInitDelay = maybe (pncTxSubmissionInitDelay defaultPartialNodeConfiguration) (fmap TxSubmissionInitDelay) <$> v .:? "TxSubmissionInitDelay" @@ -450,9 +427,6 @@ instance FromJSON PartialNodeConfiguration where , pncExperimentalProtocolsEnabled , pncMaxConcurrencyBulkSync , pncMaxConcurrencyDeadline - , pncLoggingSwitch = Last $ Just pncLoggingSwitch' - , pncLogMetrics - , pncTraceConfig , pncTraceForwardSocket = mempty , pncConfigFile = mempty , pncTopologyFile = mempty @@ -693,7 +667,6 @@ defaultPartialNodeConfiguration = PartialNodeConfiguration { pncConfigFile = Last . Just $ ConfigYamlFilePath "configuration/cardano/mainnet-config.json" , pncDatabaseFile = Last . Just $ OnePathForAllDbs "mainnet/db/" - , pncLoggingSwitch = Last $ Just True , pncSocketConfig = Last . Just $ SocketConfig mempty mempty mempty mempty , pncDiffusionMode = Last $ Just InitiatorAndResponderDiffusionMode , pncExperimentalProtocolsEnabled = Last $ Just False @@ -705,8 +678,6 @@ defaultPartialNodeConfiguration = , pncProtocolConfig = mempty , pncMaxConcurrencyBulkSync = mempty , pncMaxConcurrencyDeadline = mempty - , pncLogMetrics = mempty - , pncTraceConfig = mempty , pncTraceForwardSocket = mempty , pncMaybeMempoolCapacityOverride = mempty , pncLedgerDbConfig = @@ -767,6 +738,30 @@ defaultPartialNodeConfiguration = lastOption :: Parser a -> Parser (Last a) lastOption = fmap Last . optional +lastToEither :: String -> Last a -> Either String a +lastToEither msg = maybe (Left msg) Right . getLast + +optionalField :: (Value -> Aeson.Parser a) -> Object -> Key -> Aeson.Parser (Maybe a) +optionalField parseValue obj key = + obj .:? key >>= traverse parseValue + +peerSharingFromBool :: Bool -> PeerSharing +peerSharingFromBool True = PeerSharingEnabled +peerSharingFromBool False = PeerSharingDisabled + +parseAcceptedConnectionsLimit :: Value -> Aeson.Parser AcceptedConnectionsLimit +parseAcceptedConnectionsLimit = withObject "AcceptedConnectionsLimit" $ \v -> + AcceptedConnectionsLimit + <$> v .: "acceptedConnectionsHardLimit" + <*> v .: "acceptedConnectionsSoftLimit" + <*> v .: "acceptedConnectionsDelay" + +parseTxSubmissionLogicVersion :: Value -> Aeson.Parser TxSubmissionLogicVersion +parseTxSubmissionLogicVersion = withText "TxSubmissionLogicVersion" $ \case + "TxSubmissionLogicV1" -> pure TxSubmissionLogicV1 + "TxSubmissionLogicV2" -> pure TxSubmissionLogicV2 + invalid -> fail $ "Invalid TxSubmissionLogicVersion: " <> Text.unpack invalid + makeNodeConfiguration :: PartialNodeConfiguration -> Either String NodeConfiguration makeNodeConfiguration pnc = do configFile <- lastToEither "Missing YAML config file" $ pncConfigFile pnc @@ -776,9 +771,6 @@ makeNodeConfiguration pnc = do startAsNonProducingNode <- lastToEither "Missing StartAsNonProducingNode" $ pncStartAsNonProducingNode pnc protocolConfig <- lastToEither "Missing ProtocolConfig" $ pncProtocolConfig pnc protocolFiles <- lastToEither "Missing ProtocolFiles" $ pncProtocolFiles pnc - loggingSwitch <- lastToEither "Missing LoggingSwitch" $ pncLoggingSwitch pnc - logMetrics <- lastToEither "Missing LogMetrics" $ pncLogMetrics pnc - traceConfig <- first Text.unpack $ partialTraceSelectionToEither $ pncTraceConfig pnc diffusionMode <- lastToEither "Missing DiffusionMode" $ pncDiffusionMode pnc shutdownConfig <- lastToEither "Missing ShutdownConfig" $ pncShutdownConfig pnc socketConfig <- lastToEither "Missing SocketConfig" $ pncSocketConfig pnc @@ -932,10 +924,6 @@ makeNodeConfiguration pnc = do , ncExperimentalProtocolsEnabled = experimentalProtocols , ncMaxConcurrencyBulkSync = getLast $ pncMaxConcurrencyBulkSync pnc , ncMaxConcurrencyDeadline = getLast $ pncMaxConcurrencyDeadline pnc - , ncLoggingSwitch = loggingSwitch - , ncLogMetrics = logMetrics - , ncTraceConfig = if loggingSwitch then traceConfig - else TracingOff , ncTraceForwardSocket = getLast $ pncTraceForwardSocket pnc , ncMaybeMempoolCapacityOverride = getLast $ pncMaybeMempoolCapacityOverride pnc , ncLedgerDbConfig diff --git a/cardano-node/src/Cardano/Node/Configuration/TopologyP2P.hs b/cardano-node/src/Cardano/Node/Configuration/TopologyP2P.hs index fac56918504..eeb4bef28b9 100644 --- a/cardano-node/src/Cardano/Node/Configuration/TopologyP2P.hs +++ b/cardano-node/src/Cardano/Node/Configuration/TopologyP2P.hs @@ -22,14 +22,23 @@ import Cardano.Network.ConsensusMode (ConsensusMode (..)) import Cardano.Network.Diffusion.Topology (CardanoNetworkTopology, isValidTrustedPeerConfiguration) import Cardano.Network.PeerSelection.Bootstrap (UseBootstrapPeers (..)) +import Cardano.Network.PeerSelection.PeerTrustable (PeerTrustable (..)) import Cardano.Node.Configuration.POM (NodeConfiguration (..)) import Cardano.Node.Startup (StartupTrace (..)) import Cardano.Node.Types -import Cardano.Tracing.OrphanInstances.Network () import Ouroboros.Network.Diffusion.Topology (NetworkTopology (..)) +import Ouroboros.Network.Diffusion.Topology + (LocalRootPeersGroup (..), LocalRootPeersGroups (..), LocalRoots (..), + RootConfig (..)) +import Ouroboros.Network.DiffusionMode (DiffusionMode (..)) +import Ouroboros.Network.ConnectionManager.Types (Provenance (..)) +import Cardano.Network.OrphanInstances () import Ouroboros.Network.OrphanInstances () +import Ouroboros.Network.PeerSelection.PeerAdvertise (PeerAdvertise (..)) import Ouroboros.Network.PeerSelection.LedgerPeers.Type (LedgerPeerSnapshot (..), LedgerPeersKind (..), isLedgerPeersEnabled) +import Ouroboros.Network.PeerSelection.State.LocalRootPeers (HotValency (..), + WarmValency (..)) import Control.Exception.Safe (Exception (..), IOException, try) import Control.Monad @@ -48,6 +57,32 @@ instance AdjustFilePaths CardanoNetworkTopology where adjustFilePaths f nt@NetworkTopology{peerSnapshotPath} = nt{peerSnapshotPath = f <$> peerSnapshotPath} +instance FromJSON (LocalRootPeersGroups PeerTrustable) where + parseJSON v = LocalRootPeersGroups <$> parseJSON v + +instance FromJSON (LocalRootPeersGroup PeerTrustable) where + parseJSON = withObject "LocalRootPeersGroup" $ \v -> do + accessPoints <- v .: "accessPoints" + advertise <- peerAdvertiseFromBool <$> v .:? "advertise" .!= False + trustable <- peerTrustableFromBool <$> v .:? "trustable" .!= False + valency <- v .: "valency" + pure $ + LocalRootPeersGroup + (LocalRoots (RootConfig accessPoints advertise) Outbound) + (HotValency valency) + (WarmValency valency) + InitiatorAndResponderDiffusionMode + trustable + + +peerAdvertiseFromBool :: Bool -> PeerAdvertise +peerAdvertiseFromBool True = DoAdvertisePeer +peerAdvertiseFromBool False = DoNotAdvertisePeer + +peerTrustableFromBool :: Bool -> PeerTrustable +peerTrustableFromBool True = IsTrustable +peerTrustableFromBool False = IsNotTrustable + -- | Read the `NetworkTopology` configuration from the specified file. readTopologyFile :: () => NodeConfiguration diff --git a/cardano-node/src/Cardano/Node/Parsers.hs b/cardano-node/src/Cardano/Node/Parsers.hs index 76220a54dfa..0b42c77dc62 100644 --- a/cardano-node/src/Cardano/Node/Parsers.hs +++ b/cardano-node/src/Cardano/Node/Parsers.hs @@ -113,9 +113,6 @@ nodeRunParser = do , pncProtocolConfig = mempty , pncMaxConcurrencyBulkSync = mempty , pncMaxConcurrencyDeadline = mempty - , pncLoggingSwitch = mempty - , pncLogMetrics = mempty - , pncTraceConfig = mempty , pncTraceForwardSocket = traceForwardSocket , pncMaybeMempoolCapacityOverride = maybeMempoolCapacityOverride , pncLedgerDbConfig = mempty diff --git a/cardano-node/src/Cardano/Node/Protocol/Alonzo.hs b/cardano-node/src/Cardano/Node/Protocol/Alonzo.hs index 04c063471fc..6ada138edca 100644 --- a/cardano-node/src/Cardano/Node/Protocol/Alonzo.hs +++ b/cardano-node/src/Cardano/Node/Protocol/Alonzo.hs @@ -14,8 +14,6 @@ import qualified Cardano.Ledger.Alonzo.Genesis as Alonzo import Cardano.Node.Orphans () import Cardano.Node.Protocol.Shelley (GenesisReadError, readGenesisAny) import Cardano.Node.Types -import Cardano.Tracing.OrphanInstances.HardFork () -import Cardano.Tracing.OrphanInstances.Shelley () -- -- Alonzo genesis diff --git a/cardano-node/src/Cardano/Node/Protocol/Byron.hs b/cardano-node/src/Cardano/Node/Protocol/Byron.hs index 6c1ff2e29b5..9a8550ab47e 100644 --- a/cardano-node/src/Cardano/Node/Protocol/Byron.hs +++ b/cardano-node/src/Cardano/Node/Protocol/Byron.hs @@ -31,9 +31,6 @@ import Cardano.Node.Tracing.Era.HardFork () import Cardano.Node.Tracing.Tracers.ChainDB () import Cardano.Node.Types as Node import Cardano.Prelude (canonicalDecodePretty) -import Cardano.Tracing.OrphanInstances.Byron () -import Cardano.Tracing.OrphanInstances.HardFork () -import Cardano.Tracing.OrphanInstances.Shelley () import Ouroboros.Consensus.Cardano import qualified Ouroboros.Consensus.Cardano as Consensus import Ouroboros.Consensus.HardFork.Combinator.AcrossEras () diff --git a/cardano-node/src/Cardano/Node/Protocol/Cardano.hs b/cardano-node/src/Cardano/Node/Protocol/Cardano.hs index 09dd3b3088f..9e5598b6b50 100644 --- a/cardano-node/src/Cardano/Node/Protocol/Cardano.hs +++ b/cardano-node/src/Cardano/Node/Protocol/Cardano.hs @@ -29,8 +29,6 @@ import qualified Cardano.Node.Protocol.Dijkstra as Dijkstra import qualified Cardano.Node.Protocol.Shelley as Shelley import Cardano.Node.Protocol.Types import Cardano.Node.Types -import Cardano.Tracing.OrphanInstances.Byron () -import Cardano.Tracing.OrphanInstances.Shelley () import Ouroboros.Consensus.Cardano import qualified Ouroboros.Consensus.Cardano as Consensus import Ouroboros.Consensus.Cardano.Condense () diff --git a/cardano-node/src/Cardano/Node/Protocol/Conway.hs b/cardano-node/src/Cardano/Node/Protocol/Conway.hs index d5f84563f4a..ef75e1c0c49 100644 --- a/cardano-node/src/Cardano/Node/Protocol/Conway.hs +++ b/cardano-node/src/Cardano/Node/Protocol/Conway.hs @@ -24,8 +24,6 @@ import qualified Cardano.Ledger.Plutus.Language as L import Cardano.Node.Orphans () import Cardano.Node.Protocol.Shelley (GenesisReadError, readGenesisAny) import Cardano.Node.Types -import Cardano.Tracing.OrphanInstances.HardFork () -import Cardano.Tracing.OrphanInstances.Shelley () import qualified Data.ByteString.Lazy as LB import qualified Data.Default.Class as DefaultClass diff --git a/cardano-node/src/Cardano/Node/Protocol/Dijkstra.hs b/cardano-node/src/Cardano/Node/Protocol/Dijkstra.hs index 7650371bc8a..39c146ed50c 100644 --- a/cardano-node/src/Cardano/Node/Protocol/Dijkstra.hs +++ b/cardano-node/src/Cardano/Node/Protocol/Dijkstra.hs @@ -20,8 +20,6 @@ import Cardano.Ledger.Dijkstra.PParams import Cardano.Node.Orphans () import Cardano.Node.Protocol.Shelley (GenesisReadError, readGenesisAny) import Cardano.Node.Types -import Cardano.Tracing.OrphanInstances.HardFork () -import Cardano.Tracing.OrphanInstances.Shelley () import qualified Data.ByteString.Lazy as LB diff --git a/cardano-node/src/Cardano/Node/Protocol/Shelley.hs b/cardano-node/src/Cardano/Node/Protocol/Shelley.hs index c80f15a9363..22ccebee181 100644 --- a/cardano-node/src/Cardano/Node/Protocol/Shelley.hs +++ b/cardano-node/src/Cardano/Node/Protocol/Shelley.hs @@ -39,8 +39,6 @@ import Cardano.Node.Tracing.Formatting () import Cardano.Node.Tracing.Tracers.ChainDB () import Cardano.Node.Types import Cardano.Protocol.Crypto (StandardCrypto) -import Cardano.Tracing.OrphanInstances.HardFork () -import Cardano.Tracing.OrphanInstances.Shelley () import qualified Ouroboros.Consensus.Cardano as Consensus import Ouroboros.Consensus.HardFork.Combinator.AcrossEras () import Ouroboros.Consensus.Protocol.Praos.Common (PraosCanBeLeader (..), diff --git a/cardano-node/src/Cardano/Node/Run.hs b/cardano-node/src/Cardano/Node/Run.hs index 5298d926c9d..8642436492e 100644 --- a/cardano-node/src/Cardano/Node/Run.hs +++ b/cardano-node/src/Cardano/Node/Run.hs @@ -29,14 +29,8 @@ import Cardano.Api.Error (displayError) import qualified Cardano.Api as Api import System.Random (randomIO) -import Cardano.BM.Data.LogItem (LogObject (..)) -import Cardano.BM.Data.Tracer (ToLogObject (..), TracingVerbosity (..)) -import Cardano.BM.Data.Transformers (setHostname) -import Cardano.BM.Trace import qualified Cardano.Crypto.Init as Crypto import Cardano.Node.Configuration.LedgerDB -import Cardano.Node.Configuration.Logging (LoggingLayer (..), createLoggingLayer, - nodeBasicInfo, shutdownLoggingLayer) import Cardano.Node.Configuration.NodeAddress import Cardano.Node.Configuration.POM (NodeConfiguration (..), PartialNodeConfiguration (..), TimeoutOverride (..), @@ -59,6 +53,7 @@ import Cardano.Rpc.Server import Cardano.Rpc.Server.Config import Cardano.Node.Startup import Cardano.Node.TraceConstraints (TraceConstraints) +import Cardano.Node.Tracing (Tracers (..)) import Cardano.Node.Tracing.API import Cardano.Node.Tracing.StateRep (NodeState (NodeKernelOnline)) import Cardano.Node.Tracing.Tracers.NodeVersion (getNodeVersion) @@ -66,8 +61,6 @@ import Cardano.Node.Tracing.Tracers.Startup (getStartupInfo) import Cardano.Node.Types import Cardano.Prelude (ExitCode (..), FatalError (..), bool, (:~:) (..)) import Cardano.Slotting.Slot (WithOrigin (..)) -import Cardano.Tracing.Config (TraceOptions (..), TraceSelection (..)) -import Cardano.Tracing.Tracers import Cardano.Logging.Types (LogFormatting) import Cardano.Logging.Utils (showT) @@ -154,18 +147,14 @@ import Data.Monoid (Last (..)) import Data.Proxy (Proxy (..)) import qualified Data.Set as Set import Data.SOP.Dict -import Data.Text (Text, breakOn, pack) +import Data.Text (Text, pack) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import qualified Data.Text.IO as Text import Data.Time.Clock (getCurrentTime) -import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds) -import Data.Version (showVersion) import Network.DNS (Resolver) -import Network.HostName (getHostName) import Network.Socket (Socket) import System.Directory (canonicalizePath, createDirectoryIfMissing, makeAbsolute) -import System.Environment (lookupEnv) import System.FilePath (takeDirectory, ()) import System.IO (hPutStrLn) #ifdef UNIX @@ -176,7 +165,6 @@ import System.Posix.Types (FileMode) #else import System.Win32.File #endif -import Paths_cardano_node (version) import Ouroboros.Consensus.Mempool (MempoolTimeoutConfig(..)) import GHC.Stack @@ -256,84 +244,32 @@ handleNodeWithTracers cmdPc nc p@(SomeConsensusProtocol blockType runP) = do -- This IORef contains node kernel structure which holds node kernel. -- Used for ledger queries and peer connection status. nodeKernelData <- mkNodeKernelData - let ProtocolInfo { pInfoConfig = cfg } = fst $ Api.protocolInfo @IO runP let fp = maybe "No file path found!" unConfigPath (getLast (pncConfigFile cmdPc)) - case ncTraceConfig nc of - TraceDispatcher{} -> do - blockForging <- snd (Api.protocolInfo runP) nullTracer - tracers <- - initTraceDispatcher - nc - p - networkMagic - nodeKernelData - (null blockForging) - - startupInfo <- getStartupInfo nc p fp - mapM_ (traceWith $ startupTracer tracers) startupInfo - traceNodeStartupInfo (nodeStartupInfoTracer tracers) startupInfo - -- sends initial BlockForgingUpdate - let isNonProducing = ncStartAsNonProducingNode nc - traceWith (startupTracer tracers) - (BlockForgingUpdate (if isNonProducing || null blockForging - then DisabledBlockForging - else EnabledBlockForging)) - - handleSimpleNode blockType runP tracers nc networkMagic - (\nk -> do - setNodeKernel nodeKernelData nk - traceWith (nodeStateTracer tracers) NodeKernelOnline) - - _ -> do - eLoggingLayer <- runExceptT $ createLoggingLayer - (Text.pack (showVersion version)) - nc - p - - loggingLayer <- case eLoggingLayer of - Left err -> Exception.throwIO err - Right res -> return res - !trace <- setupTrace loggingLayer - let tracer = contramap pack $ toLogObject trace - logTracingVerbosity nc tracer - - -- Legacy logging infrastructure must trace 'nodeStartTime' and 'nodeBasicInfo'. - startTime <- getCurrentTime - traceCounter "nodeStartTime" trace (ceiling $ utcTimeToPOSIXSeconds startTime) - nbi <- nodeBasicInfo nc p startTime - forM_ nbi $ \(LogObject nm mt content) -> - traceNamedObject (appendName nm trace) (mt, content) - - tracers <- - mkTracers - (Consensus.configBlock cfg) - (ncTraceConfig nc) - trace - nodeKernelData - (llEKGDirect loggingLayer) - - getStartupInfo nc p fp - >>= mapM_ (traceWith $ startupTracer tracers) - - traceWith (nodeVersionTracer tracers) getNodeVersion - let isNonProducing = ncStartAsNonProducingNode nc - blockForging <- snd (Api.protocolInfo runP) nullTracer - traceWith (startupTracer tracers) - (BlockForgingUpdate (if isNonProducing || null blockForging - then DisabledBlockForging - else EnabledBlockForging)) - - -- We ignore peer logging thread if it dies, but it will be killed - -- when 'handleSimpleNode' terminates. - handleSimpleNode blockType runP tracers nc networkMagic - (\nk -> do - setNodeKernel nodeKernelData nk - traceWith (nodeStateTracer tracers) NodeKernelOnline) - `finally` do - forM_ eLoggingLayer - shutdownLoggingLayer + blockForging <- snd (Api.protocolInfo runP) nullTracer + tracers <- + initTraceDispatcher + nc + p + networkMagic + nodeKernelData + (null blockForging) + + startupInfo <- getStartupInfo nc p fp + mapM_ (traceWith $ startupTracer tracers) startupInfo + traceNodeStartupInfo (nodeStartupInfoTracer tracers) startupInfo + -- sends initial BlockForgingUpdate + let isNonProducing = ncStartAsNonProducingNode nc + traceWith (startupTracer tracers) + (BlockForgingUpdate (if isNonProducing || null blockForging + then DisabledBlockForging + else EnabledBlockForging)) + + handleSimpleNode blockType runP tracers nc networkMagic + (\nk -> do + setNodeKernel nodeKernelData nk + traceWith (nodeStateTracer tracers) NodeKernelOnline) -- | Currently, we trace only 'ShelleyBased'-info which will be asked -- by 'cardano-tracer' service as a datapoint. It can be extended in the future. @@ -347,36 +283,6 @@ traceNodeStartupInfo t startupTrace = traceWith t $ NodeStartupInfo era sl el spkp _ -> return () -logTracingVerbosity :: NodeConfiguration -> Tracer IO String -> IO () -logTracingVerbosity nc tracer = - case ncTraceConfig nc of - TracingOff -> return () - TracingOnLegacy traceConf -> - case traceVerbosity traceConf of - 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. --- --- If the @CARDANO_NODE_LOGGING_HOSTNAME@ environment variable is set, --- it overrides the system hostname. This is useful when running a --- local test cluster with all nodes on the same host. -setupTrace - :: LoggingLayer - -> IO (Trace IO Text) -setupTrace loggingLayer = do - hn <- maybe hostname (pure . pack) =<< lookupEnv "CARDANO_NODE_LOGGING_HOSTNAME" - return $ - setHostname hn $ - llAppendName loggingLayer "node" (llBasicTrace loggingLayer) - where - hostname = do - hn0 <- pack <$> getHostName - return $ Text.take 8 $ fst $ breakOn "." hn0 - {- -- TODO: needs to be finished (issue #4362) handlePeersListSimple diff --git a/cardano-node/src/Cardano/Node/TraceConstraints.hs b/cardano-node/src/Cardano/Node/TraceConstraints.hs index 5e32faf6215..2dca935692a 100644 --- a/cardano-node/src/Cardano/Node/TraceConstraints.hs +++ b/cardano-node/src/Cardano/Node/TraceConstraints.hs @@ -7,28 +7,26 @@ module Cardano.Node.TraceConstraints (TraceConstraints) where -import Cardano.BM.Tracing (ToObject) import Cardano.Ledger.Credential import Cardano.Ledger.Keys import Cardano.Logging (LogFormatting) import Cardano.Node.Queries (ConvertTxId, GetKESInfo (..), HasKESInfo (..), HasKESMetricsData (..), LedgerQueries) +import Cardano.Node.Tracing.Tracers.HasIssuer (HasIssuer) +import Cardano.Node.Tracing.Tracers.KESInfo () import qualified Cardano.Node.Tracing.Tracers.Consensus as ConsensusTracers import Cardano.Protocol.Crypto (StandardCrypto) -import Cardano.Tracing.HasIssuer (HasIssuer) import Ouroboros.Consensus.Block (BlockProtocol, CannotForge, ForgeStateUpdateError, GetHeader, HasHeader, Header, HeaderHash) import Ouroboros.Consensus.HeaderValidation (OtherHeaderEnvelopeError) import Ouroboros.Consensus.Ledger.Abstract (LedgerError) import Ouroboros.Consensus.Ledger.Inspect (LedgerEvent, LedgerUpdate, LedgerWarning) import Ouroboros.Consensus.Ledger.SupportsMempool (ApplyTxErr, HasTxId, HasTxs (..)) -import Ouroboros.Consensus.Node.NetworkProtocolVersion - (HasNetworkProtocolVersion (BlockNodeToClientVersion, BlockNodeToNodeVersion)) import Ouroboros.Consensus.Node.Run (RunNode, SerialiseNodeToNodeConstraints) import Ouroboros.Consensus.Peras.SelectView import Ouroboros.Consensus.Protocol.Abstract (ReasonForSwitch, SelectView, SelectViewReasonForSwitch, TiebreakerView, ValidationErr) -import Ouroboros.Consensus.Shelley.Ledger.Mempool (GenTx, TxId) +import Ouroboros.Consensus.Shelley.Ledger.Mempool (GenTx) import Ouroboros.Network.Block (Serialised) import Data.Aeson @@ -38,30 +36,16 @@ import Data.Set -- | Tracing-related constraints for monitoring purposes. type TraceConstraints blk = ( ConvertTxId blk - , HasIssuer blk , HasKESMetricsData blk , HasTxs blk , HasTxId (GenTx blk) , LedgerQueries blk - , ToJSON (TxId (GenTx blk)) , HasKESMetricsData blk , HasKESInfo blk , GetKESInfo blk , RunNode blk + , HasIssuer blk - , ToObject (ApplyTxErr blk) - , ToObject (GenTx blk) - , ToObject (Header blk) - , ToObject (LedgerError blk) - , ToObject (LedgerEvent blk) - , ToObject (OtherHeaderEnvelopeError blk) - , ToObject (WeightedSelectView (BlockProtocol blk)) - , ToObject (ValidationErr (BlockProtocol blk)) - , ToObject (CannotForge blk) - , ToObject (ForgeStateUpdateError blk) - - , ToJSON (BlockNodeToClientVersion blk) - , ToJSON (BlockNodeToNodeVersion blk) , ToJSON (HeaderHash blk) , LogFormatting (ApplyTxErr blk) diff --git a/cardano-node/src/Cardano/Node/Tracing/Compat.hs b/cardano-node/src/Cardano/Node/Tracing/Compat.hs deleted file mode 100644 index 692f6857792..00000000000 --- a/cardano-node/src/Cardano/Node/Tracing/Compat.hs +++ /dev/null @@ -1,22 +0,0 @@ -{-# LANGUAGE LambdaCase #-} - -module Cardano.Node.Tracing.Compat - ( toDetailLevel - , fromDetailLevel - ) where - -import qualified Cardano.BM.Data.Tracer as IOMF -import qualified Cardano.Logging.Types as TD - -toDetailLevel :: IOMF.TracingVerbosity -> TD.DetailLevel -toDetailLevel = \case - IOMF.MinimalVerbosity -> TD.DMinimal - IOMF.NormalVerbosity -> TD.DNormal - IOMF.MaximalVerbosity -> TD.DMaximum - -fromDetailLevel :: TD.DetailLevel -> IOMF.TracingVerbosity -fromDetailLevel = \case - TD.DMinimal -> IOMF.MinimalVerbosity - TD.DNormal -> IOMF.NormalVerbosity - TD.DDetailed -> IOMF.NormalVerbosity - TD.DMaximum -> IOMF.MaximalVerbosity diff --git a/cardano-node/src/Cardano/Node/Tracing/Documentation.hs b/cardano-node/src/Cardano/Node/Tracing/Documentation.hs index c8478b5d8d6..e5b0a998ad6 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Documentation.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Documentation.hs @@ -33,6 +33,7 @@ import qualified Cardano.Network.PeerSelection.ExtraRootPeers as Cardano.PublicR import qualified Cardano.Network.PeerSelection.Governor.PeerSelectionState as Cardano import qualified Cardano.Network.PeerSelection.Governor.Types as Cardano import Cardano.Network.PeerSelection.PeerTrustable (PeerTrustable (..)) +import Cardano.Node.Configuration.TopologyP2P () import Cardano.Node.Handlers.Shutdown (ShutdownTrace) import Cardano.Node.Startup import Cardano.Node.Tracing.DefaultTraceConfig (defaultCardanoConfig) @@ -54,7 +55,6 @@ import Cardano.Node.Tracing.Tracers.Rpc () import Cardano.Node.Tracing.Tracers.Shutdown () import Cardano.Node.Tracing.Tracers.Startup () import Cardano.Rpc.Server (TraceRpc) -import Cardano.Tracing.OrphanInstances.Network () import Ouroboros.Consensus.Block.SupportsSanityCheck (SanityCheckIssue) import Ouroboros.Consensus.BlockchainTime.WallClock.Types (RelativeTime) import Ouroboros.Consensus.BlockchainTime.WallClock.Util (TraceBlockchainTimeEvent (..)) @@ -92,6 +92,7 @@ import Ouroboros.Network.PeerSelection.Governor (DebugPeerSelection (. PeerSelectionCounters, TracePeerSelection) import Ouroboros.Network.PeerSelection.LedgerPeers (TraceLedgerPeers) import Ouroboros.Network.PeerSelection.PeerStateActions (PeerSelectionActionsTrace (..)) +import Ouroboros.Network.PeerSelection.PublicRootPeers () import Ouroboros.Network.PeerSelection.RootPeersDNS.LocalRootPeers (TraceLocalRootPeers (..)) import Ouroboros.Network.PeerSelection.RootPeersDNS.PublicRootPeers @@ -114,7 +115,7 @@ import Network.Mux.Tracing () import qualified Network.Mux as Mux import Control.Monad (forM_) -import Data.Aeson.Types (ToJSON) +import Data.Aeson (ToJSON (..)) import Data.Proxy (Proxy (..)) import Data.Text (pack) import qualified Data.Text.IO as T @@ -175,6 +176,7 @@ parseTraceDocumentationCmd = instance ToJSON UnversionedProtocol instance ToJSON UnversionedProtocolData + runTraceDocumentationCmd :: TraceDocumentationCmd -> IO () diff --git a/cardano-node/src/Cardano/Node/Tracing/Era/Byron.hs b/cardano-node/src/Cardano/Node/Tracing/Era/Byron.hs index 95e290c8553..4414faa10df 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Era/Byron.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Era/Byron.hs @@ -22,7 +22,7 @@ import Cardano.Chain.Byron.API (ApplyMempoolPayloadErr (..)) import Cardano.Chain.Delegation (delegateVK) import Cardano.Crypto.Signing (VerificationKey) import Cardano.Logging -import Cardano.Tracing.OrphanInstances.Byron () +import Cardano.Node.Tracing.Render (renderTxId) import Ouroboros.Consensus.Block (Header) import Ouroboros.Consensus.Block.EBB (fromIsEBB) import Ouroboros.Consensus.Byron.Ledger (ByronBlock (..), @@ -119,7 +119,7 @@ instance LogFormatting UpdateState where instance LogFormatting (GenTx ByronBlock) where forMachine dtal tx = mconcat $ - ( "txid" .= txId tx ) + ( "txid" .= (Text.take 8 . renderTxId $ txId tx) ) : [ "tx" .= condense tx | dtal == DDetailed ] instance LogFormatting ChainValidationError where diff --git a/cardano-node/src/Cardano/Node/Tracing/Era/HardFork.hs b/cardano-node/src/Cardano/Node/Tracing/Era/HardFork.hs index 970894eacbd..66300579bc4 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Era/HardFork.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Era/HardFork.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -5,6 +6,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} @@ -17,7 +19,6 @@ module Cardano.Node.Tracing.Era.HardFork () import Cardano.Logging import Cardano.Slotting.Slot (EpochSize (..)) -import Cardano.Tracing.OrphanInstances.HardFork () import Ouroboros.Consensus.Block (BlockProtocol, CannotForge, ForgeStateInfo, ForgeStateUpdateError, PerasWeight (..)) import Ouroboros.Consensus.BlockchainTime (getSlotLength) @@ -30,7 +31,7 @@ import Ouroboros.Consensus.HardFork.Combinator.AcrossEras (EraMismatch OneEraValidationErr (..), mkEraMismatch) import Ouroboros.Consensus.HardFork.Combinator.Condense () import Ouroboros.Consensus.HardFork.History - (EraParams (eraEpochSize, eraSafeZone, eraSlotLength)) + (EraParams (eraEpochSize, eraSafeZone, eraSlotLength), SafeZone) import Ouroboros.Consensus.HardFork.History.EraParams (EraParams (EraParams)) import Ouroboros.Consensus.HeaderValidation (OtherHeaderEnvelopeError) import Ouroboros.Consensus.Ledger.Abstract (LedgerError) @@ -179,7 +180,7 @@ instance LogFormatting EraParams where , "safeZone" .= eraSafeZone ] --- deriving instance ToJSON SafeZone +deriving instance ToJSON SafeZone -- diff --git a/cardano-node/src/Cardano/Node/Tracing/Era/Shelley.hs b/cardano-node/src/Cardano/Node/Tracing/Era/Shelley.hs index 88f35951713..b048c027c0a 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Era/Shelley.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Era/Shelley.hs @@ -42,8 +42,9 @@ import qualified Cardano.Ledger.Hashes as Hashes import Cardano.Ledger.Shelley.API import Cardano.Ledger.Shelley.Rules import Cardano.Logging +import Cardano.Node.Queries (ConvertTxId) import Cardano.Node.Tracing.Render (renderIncompleteWithdrawals, renderMissingRedeemers, - renderScriptHash, renderScriptIntegrityHash) + renderScriptHash, renderScriptIntegrityHash, renderTxId) import qualified Cardano.Protocol.Crypto as Ledger import Cardano.Protocol.TPraos.API (ChainTransitionError (ChainTransitionError)) import Cardano.Protocol.TPraos.BHeader (LastAppliedBlock, labBlockNo) @@ -56,9 +57,7 @@ import Cardano.Protocol.TPraos.Rules.Prtcl import Cardano.Protocol.TPraos.Rules.Tickn (TicknPredicateFailure) import Cardano.Protocol.TPraos.Rules.Updn (UpdnPredicateFailure) import Cardano.Slotting.Block (BlockNo (..)) -import Cardano.Tracing.OrphanInstances.Shelley () import Ouroboros.Consensus.Ledger.SupportsMempool (txId) -import qualified Ouroboros.Consensus.Ledger.SupportsMempool as SupportsMempool import qualified Ouroboros.Consensus.Protocol.Praos as Praos import qualified Ouroboros.Consensus.Protocol.Praos.Common as Praos import Ouroboros.Consensus.Protocol.TPraos (TPraosCannotForge (..)) @@ -80,7 +79,8 @@ import Data.Set (Set) import qualified Data.Set as Set import qualified Data.Set.NonEmpty as NonEmptySet import Data.Text (Text) -import qualified Data.Text.Encoding as Text +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text.Encoding {- HLINT ignore "Use :" -} @@ -90,14 +90,17 @@ import qualified Data.Text.Encoding as Text -- NOTE: this list is sorted in roughly topological order. instance - ( ToJSON (SupportsMempool.TxId (GenTx (ShelleyBlock protocol era))) + ( ConvertTxId (ShelleyBlock protocol era) , ShelleyBasedEra era ) => LogFormatting (GenTx (ShelleyBlock protocol era)) where forMachine dtal tx = mconcat $ - ( "txid" .= txId tx ) + ( "txid" .= (Text.take 8 . renderTxId $ txId tx) ) : [ "tx" .= condense tx | dtal == DDetailed ] +kesPeriodValue :: KESPeriod -> Value +kesPeriodValue (KESPeriod period) = toJSON period + instance LogFormatting (Set (Credential Staking)) where forMachine _dtal creds = mconcat [ "kind" .= String "StakeCreds" @@ -234,8 +237,8 @@ instance forMachine _dtal (TPraosCannotForgeKeyNotUsableYet wallClockPeriod keyStartPeriod) = mconcat [ "kind" .= String "TPraosCannotForgeKeyNotUsableYet" - , "keyStart" .= keyStartPeriod - , "wallClock" .= wallClockPeriod + , "keyStart" .= kesPeriodValue keyStartPeriod + , "wallClock" .= kesPeriodValue wallClockPeriod ] forMachine _dtal (TPraosCannotForgeWrongVRF genDlgVRFHash coreNodeVRFHash) = mconcat @@ -1277,13 +1280,13 @@ instance ] Praos.KESBeforeStartOCERT startKesPeriod currKesPeriod -> mconcat [ "kind" .= String "KESBeforeStartOCERT" - , "opCertStartingKesPeriod" .= startKesPeriod - , "currentKesPeriod" .= currKesPeriod + , "opCertStartingKesPeriod" .= kesPeriodValue startKesPeriod + , "currentKesPeriod" .= kesPeriodValue currKesPeriod ] Praos.KESAfterEndOCERT currKesPeriod startKesPeriod maxKesKeyEvos -> mconcat [ "kind" .= String "KESAfterEndOCERT" - , "opCertStartingKesPeriod" .= startKesPeriod - , "currentKesPeriod" .= currKesPeriod + , "opCertStartingKesPeriod" .= kesPeriodValue startKesPeriod + , "currentKesPeriod" .= kesPeriodValue currKesPeriod , "maxKesKeyEvolutions" .= maxKesKeyEvos ] Praos.CounterTooSmallOCERT lastCounter currentCounter -> @@ -1299,7 +1302,7 @@ instance Praos.InvalidSignatureOCERT counter oCertStartKesPeriod err -> mconcat [ "kind" .= String "InvalidSignatureOCERT" , "counter" .= counter - , "opCertStartingKesPeriod" .= oCertStartKesPeriod + , "opCertStartingKesPeriod" .= kesPeriodValue oCertStartKesPeriod , "error" .= err ] Praos.InvalidKesSignatureOCERT currentKesPeriod opCertStartKesPeriod expectedKesEvos maxKesEvos err -> @@ -1318,8 +1321,8 @@ instance instance LogFormatting (Praos.PraosCannotForge crypto) where forMachine _ (Praos.PraosCannotForgeKeyNotUsableYet currentKesPeriod startingKesPeriod) = mconcat [ "kind" .= String "PraosCannotForgeKeyNotUsableYet" - , "currentKesPeriod" .= currentKesPeriod - , "opCertStartingKesPeriod" .= startingKesPeriod + , "currentKesPeriod" .= kesPeriodValue currentKesPeriod + , "opCertStartingKesPeriod" .= kesPeriodValue startingKesPeriod ] instance LogFormatting Praos.PraosEnvelopeError where @@ -1582,7 +1585,7 @@ instance LogFormatting (Praos.PraosTiebreakerView crypto) where , "tieBreakVRF" .= renderVRF ptvTieBreakVRF ] where - renderVRF = Text.decodeUtf8 . B16.encode . Crypto.getOutputVRFBytes + renderVRF = Text.Encoding.decodeUtf8 . B16.encode . Crypto.getOutputVRFBytes -------------------------------------------------------------------------------- -- Helper functions diff --git a/cardano-node/src/Cardano/Node/Tracing/Formatting.hs b/cardano-node/src/Cardano/Node/Tracing/Formatting.hs index b2b77b1190d..012eb0bf67a 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Formatting.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Formatting.hs @@ -2,6 +2,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -11,7 +12,7 @@ module Cardano.Node.Tracing.Formatting import Cardano.Logging (LogFormatting (..)) import Cardano.Node.Tracing.Render (renderHeaderHashForDetails) -import Ouroboros.Consensus.Block (ConvertRawHash (..), RealPoint, realPointHash, +import Ouroboros.Consensus.Block (ConvertRawHash (..), Header, RealPoint, realPointHash, realPointSlot) import qualified Ouroboros.Network.AnchoredFragment as AF import Ouroboros.Network.Block @@ -20,6 +21,13 @@ import Data.Aeson (Value (String), toJSON, (.=)) import Data.Proxy (Proxy (..)) import Data.Void (Void) +-- | Derives ConvertRawHash for Header blk from ConvertRawHash blk. +-- Safe because HeaderHash (Header blk) = HeaderHash blk. +instance ConvertRawHash blk => ConvertRawHash (Header blk) where + toShortRawHash _ = toShortRawHash (Proxy @blk) + fromShortRawHash _ = fromShortRawHash (Proxy @blk) + hashSize _ = hashSize (Proxy @blk) + -- | 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. diff --git a/cardano-node/src/Cardano/Node/Tracing/StateRep.hs b/cardano-node/src/Cardano/Node/Tracing/StateRep.hs index 019408164cc..a5273e77628 100644 --- a/cardano-node/src/Cardano/Node/Tracing/StateRep.hs +++ b/cardano-node/src/Cardano/Node/Tracing/StateRep.hs @@ -27,7 +27,6 @@ import Cardano.Node.Handlers.Shutdown (ShutdownTrace) import Cardano.Node.Protocol.Types (SomeConsensusProtocol (..)) import qualified Cardano.Node.Startup as Startup import Cardano.Slotting.Slot (EpochNo, SlotNo (..), WithOrigin, withOrigin) -import Cardano.Tracing.OrphanInstances.Network () import qualified Ouroboros.Consensus.Block.RealPoint as RP import qualified Ouroboros.Consensus.Node.NetworkProtocolVersion as NPV import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB @@ -37,6 +36,7 @@ import qualified Ouroboros.Consensus.Storage.LedgerDB as LgrDb import Ouroboros.Network.Block (pointSlot) import Control.DeepSeq (NFData) +import Cardano.Network.OrphanInstances () import Data.Aeson hiding (Result (..)) import Data.Text as T (Text, pack) import Data.Time.Clock @@ -49,6 +49,7 @@ deriving instance ToJSON ChunkNo deriving instance NFData ChunkNo + deriving instance Generic TracePrometheusSimple deriving instance FromJSON TracePrometheusSimple deriving instance ToJSON TracePrometheusSimple diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers.hs index b3a24a9f034..cbf985df114 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers.hs @@ -10,6 +10,7 @@ {-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -fno-warn-redundant-constraints #-} +{-# OPTIONS_GHC -Wno-orphans #-} -- needs different instances on ghc8 and on ghc9 module Cardano.Node.Tracing.Tracers @@ -19,7 +20,9 @@ module Cardano.Node.Tracing.Tracers import Cardano.Logging import qualified Cardano.Network.Diffusion as Cardano.Diffusion import Cardano.Network.NodeToClient (LocalAddress) +import Cardano.Network.NodeToClient.Version () import Cardano.Network.NodeToNode (RemoteAddress) +import Cardano.Network.NodeToNode.Version () import Cardano.Node.Protocol.Types (SomeConsensusProtocol) import Cardano.Node.Queries (NodeKernelData) import Cardano.Node.TraceConstraints @@ -58,12 +61,14 @@ import qualified Ouroboros.Network.Diffusion as Diffusion import Codec.CBOR.Read (DeserialiseFailure) import Control.Monad (unless) import "contra-tracer" Control.Tracer (Tracer (..)) -import Data.Aeson (ToJSON) +import Cardano.Network.OrphanInstances () +import Data.Aeson (ToJSON (..)) import Data.Proxy (Proxy (..)) import Network.Mux.Trace (TraceLabelPeer (..)) import qualified Network.Mux.Trace as Mux import Network.Mux.Tracing () + -- | Construct tracers for all system components. -- mkDispatchTracers @@ -317,8 +322,8 @@ mkConsensusTracers configReflection trBase trForward mbTrEKG _trDataPoint trConf configureTracers configReflection trConfig [consensusStartupErrorTr] !consensusGddTr <- mkCardanoTracer - trBase trForward mbTrEKG - ["Consensus", "GDD"] + trBase trForward mbTrEKG + ["Consensus", "GDD"] configureTracers configReflection trConfig [consensusGddTr] !consensusGsmTr <- mkCardanoTracer diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/ChainDB.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/ChainDB.hs index 0e2a0dfa947..1427af94e67 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/ChainDB.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/ChainDB.hs @@ -19,8 +19,8 @@ import Cardano.Node.Tracing.Era.Byron () import Cardano.Node.Tracing.Era.Shelley () import Cardano.Node.Tracing.Formatting () import Cardano.Node.Tracing.Render +import Cardano.Node.Tracing.Tracers.HasIssuer import Cardano.Prelude (maximumDef) -import Cardano.Tracing.HasIssuer import Ouroboros.Consensus.Block import Ouroboros.Consensus.HardFork.Combinator.Abstract.CanHardFork import Ouroboros.Consensus.HardFork.Combinator.Abstract.SingleEraBlock @@ -56,7 +56,7 @@ import Ouroboros.Consensus.Util.Enclose import qualified Ouroboros.Network.AnchoredFragment as AF import Ouroboros.Network.Block (MaxSlotNo (..)) -import Data.Aeson (Object, Value (String), object, toJSON, (.=)) +import Data.Aeson (Object, ToJSON, Value (Object, String), object, toJSON, (.=)) import qualified Data.ByteString.Base16 as B16 import Data.Int (Int64) import Data.SOP (All, K (..), hcmap, hcollapse) @@ -101,7 +101,6 @@ instance ( LogFormatting (Header blk) , InspectLedger blk , HasIssuer blk , LogFormatting (ReasonForSwitch (TiebreakerView (BlockProtocol blk))) - ) => LogFormatting (ChainDB.TraceEvent blk) where forHuman ChainDB.TraceLastShutdownUnclean = "ChainDB is not clean. Validating all immutable chunks" @@ -1182,7 +1181,7 @@ instance MetaTrace (ChainDB.TraceGCEvent blk) where -- -- TraceInitChainSelEvent -- -------------------------------------------------------------------------------- -instance (ConvertRawHash blk, LedgerSupportsProtocol blk) +instance (ConvertRawHash blk, ConvertRawHash (Header blk), LedgerSupportsProtocol blk) => LogFormatting (ChainDB.TraceInitChainSelEvent blk) where forHuman (ChainDB.InitChainSelValidation v) = forHuman v forHuman ChainDB.InitialChainSelected{} = @@ -1190,7 +1189,8 @@ instance (ConvertRawHash blk, LedgerSupportsProtocol blk) forHuman ChainDB.StartedInitChainSelection {} = "Started initial chain selection" - forMachine dtal (ChainDB.InitChainSelValidation v) = forMachine dtal v + forMachine dtal (ChainDB.InitChainSelValidation v) = + forMachine dtal v forMachine _dtal ChainDB.InitialChainSelected = mconcat ["kind" .= String "Follower.InitialChainSelected"] forMachine _dtal ChainDB.StartedInitChainSelection = @@ -1754,7 +1754,7 @@ instance ( StandardHash blk mconcat [ "kind" .= String "TookSnapshot" , "snapshot" .= forMachine dtals snap , "tip" .= show pt - , "enclosedTime" .= enclosedTiming + , "enclosedTime" .= enclosingValue enclosedTiming ] forMachine dtals (LedgerDB.DeletedSnapshot snap) = mconcat [ "kind" .= String "DeletedSnapshot" @@ -2320,12 +2320,18 @@ instance MetaTrace V1.BackingStoreValueHandleTrace where -------------------------------------------------------------------------------} instance LogFormatting EnclosingTimed where - forMachine _dtal RisingEdge = mconcat [ "edge" .= String "Starting" ] - forMachine _dtal (FallingEdgeWith a) = mconcat [ "edge" .= toJSON a ] + forMachine _dtal = enclosingObject forHuman RisingEdge = "Starting" forHuman (FallingEdgeWith a) = "Completed in " <> showT a <> " seconds" +enclosingObject :: ToJSON a => Enclosing' a -> Object +enclosingObject RisingEdge = mconcat [ "edge" .= String "Starting" ] +enclosingObject (FallingEdgeWith a) = mconcat [ "edge" .= toJSON a ] + +enclosingValue :: ToJSON a => Enclosing' a -> Value +enclosingValue = Object . enclosingObject + instance LogFormatting V2.LedgerDBV2Trace where forMachine dtal (V2.TraceLedgerTablesHandleCreate enc) = mconcat [ "kind" .= String "LedgerTablesHandleCreate", "enclosing" .= forMachine dtal enc ] @@ -3134,7 +3140,7 @@ instance ConvertRawHash blk => LogFormatting (ChainDB.TraceAddPerasCertEvent blk mconcat ["kind" .= String "AddedPerasCertToQueue", "round" .= String (Text.pack $ show roundNo), "boostedBlock" .= String (renderPoint boostedBlock), - "queueSize" .= toJSON queueSize] + "queueSize" .= enclosingValue queueSize] forMachine _dtal (ChainDB.PoppedPerasCertFromQueue roundNo boostedBlock) = mconcat ["kind" .= String "PoppedPerasCertFromQueue", "round" .= String (Text.pack $ show roundNo), diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/Consensus.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/Consensus.hs index 73441a77393..5cd1f6656d7 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/Consensus.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/Consensus.hs @@ -35,7 +35,6 @@ import Cardano.Node.Tracing.Render import Cardano.Node.Tracing.Tracers.ConsensusStartupException () import Cardano.Protocol.TPraos.OCert (KESPeriod (..)) import Cardano.Slotting.Slot (WithOrigin (..)) -import Cardano.Tracing.OrphanInstances.Network (Verbose (..)) import Ouroboros.Consensus.Block import Ouroboros.Consensus.BlockchainTime (SystemStart (..)) import Ouroboros.Consensus.BlockchainTime.WallClock.Util (TraceBlockchainTimeEvent (..)) @@ -66,6 +65,7 @@ import Ouroboros.Consensus.Util.Enclose import qualified Ouroboros.Network.AnchoredFragment as AF import qualified Ouroboros.Network.AnchoredSeq as AS import Ouroboros.Network.Block hiding (blockPrevHash) +import Ouroboros.Network.OrphanInstances () import Ouroboros.Network.BlockFetch.ClientState (TraceLabelPeer (..)) import qualified Ouroboros.Network.BlockFetch.ClientState as BlockFetch import Ouroboros.Network.BlockFetch.Decision @@ -73,7 +73,7 @@ import Ouroboros.Network.BlockFetch.Decision.Trace (TraceDecisionEvent import Ouroboros.Network.SizeInBytes (SizeInBytes (..)) import Control.Monad (guard) -import Data.Aeson (ToJSON, Value (..), toJSON, (.=)) +import Data.Aeson (ToJSON, Value (..), object, toJSON, (.=)) import qualified Data.Aeson as Aeson import Data.Foldable (Foldable (toList)) import Data.Int (Int64) @@ -85,6 +85,10 @@ import Data.Time (NominalDiffTime) import Data.Word (Word32, Word64) import Network.TypedProtocol.Core +enclosingValue :: ToJSON a => Enclosing' a -> Value +enclosingValue RisingEdge = object [ "edge" .= String "Starting" ] +enclosingValue (FallingEdgeWith a) = object [ "edge" .= toJSON a ] + -------------------------------------------------------------------------------- -- TraceLabelCreds peer a -------------------------------------------------------------------------------- @@ -152,7 +156,7 @@ instance (LogFormatting (LedgerUpdate blk), LogFormatting (LedgerWarning blk)) -- ChainSyncClient Tracer -------------------------------------------------------------------------------- -instance (ConvertRawHash blk, LedgerSupportsProtocol blk) +instance (ConvertRawHash blk, ConvertRawHash (Header blk), LedgerSupportsProtocol blk) => LogFormatting (TraceChainSyncClientEvent blk) where forHuman = \case TraceDownloadedHeader pt -> @@ -658,15 +662,15 @@ instance MetaTrace (TraceDecisionEvent peer (Header blk)) where allNamespaces = [ Namespace [] ["PeersFetch"], Namespace [] ["PeerStarvedUs"] ] -instance (Show peer, ToJSON peer, ConvertRawHash (Header blk), HasHeader blk, ToJSON (HeaderHash blk)) +instance (Show peer, ToJSON peer, LogFormatting peer, HasHeader blk) => LogFormatting (TraceDecisionEvent peer (Header blk)) where forHuman = Text.pack . show forMachine dtal (PeersFetch xs) = mconcat [ "kind" .= String "PeerFetch" , "decisions" .= if dtal >= DMaximum - then toJSON (Verbose <$> xs) - else toJSON xs + then toJSON (map (forMachine DMaximum) xs) + else toJSON (map (forMachine dtal) xs) ] forMachine _dtal (PeerStarvedUs peer) = mconcat [ "kind" .= String "PeerStarvedUs" @@ -1102,7 +1106,7 @@ impliesMempoolTimeoutSoft = \case instance ( LogFormatting (ApplyTxErr blk) , LogFormatting (GenTx blk) - , ToJSON (GenTxId blk) + , Show (GenTxId blk) , LedgerSupportsMempool blk , ConvertRawHash blk ) => LogFormatting (TraceEventMempool blk) where @@ -1141,7 +1145,7 @@ instance forMachine dtal (TraceMempoolManuallyRemovedTxs txs0 txs1 mpSz) = mconcat [ "kind" .= String "TraceMempoolManuallyRemovedTxs" - , "txsRemoved" .= txs0 + , "txsRemoved" .= map (String . Text.pack . show) (toList txs0) , "txsInvalidated" .= map (forMachine dtal . txForgetValidated) txs1 , "mempoolSize" .= forMachine dtal mpSz ] @@ -1159,7 +1163,7 @@ instance forMachine _dtal (TraceMempoolSynced et) = mconcat [ "kind" .= String "TraceMempoolSynced" - , "enclosingTime" .= et + , "enclosingTime" .= enclosingValue et ] forMachine _dtal TraceMempoolTipMovedBetweenSTMBlocks = mconcat diff --git a/cardano-node/src/Cardano/Tracing/HasIssuer.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/HasIssuer.hs similarity index 98% rename from cardano-node/src/Cardano/Tracing/HasIssuer.hs rename to cardano-node/src/Cardano/Node/Tracing/Tracers/HasIssuer.hs index f41f64a56fe..2205e9d2339 100644 --- a/cardano-node/src/Cardano/Tracing/HasIssuer.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/HasIssuer.hs @@ -6,7 +6,7 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -module Cardano.Tracing.HasIssuer +module Cardano.Node.Tracing.Tracers.HasIssuer ( BlockIssuerVerificationKeyHash (..) , HasIssuer (..) ) where diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/Startup.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/Startup.hs index 3577fe2ed2b..5578356ff21 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/Startup.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/Startup.hs @@ -17,6 +17,7 @@ module Cardano.Node.Tracing.Tracers.Startup import Cardano.Api (NetworkMagic (..), SlotNo (..)) import qualified Cardano.Api as Api +import Cardano.Network.OrphanInstances () import qualified Cardano.Chain.Genesis as Gen import Cardano.Git.Rev (gitRev) @@ -129,23 +130,21 @@ getStartupInfo nc (SomeConsensusProtocol whichP pForInfo) fp = do -- data ConsensusNetworkVersionTuple a b = ConsensusNetworkVersionTuple a b -instance ToJSON blkVersion => ToJSON (ConsensusNetworkVersionTuple NodeToClientVersion blkVersion) where +instance Show blkVersion => ToJSON (ConsensusNetworkVersionTuple NodeToClientVersion blkVersion) where toJSON (ConsensusNetworkVersionTuple nodeToClientVersion blockVersion) = Aeson.object [ "nodeToClientVersion" .= nodeToClientVersion - , "blockVersion" .= blockVersion + , "blockVersion" .= String (pack $ show blockVersion) ] -instance ToJSON blkVersion => ToJSON (ConsensusNetworkVersionTuple NodeToNodeVersion blkVersion) where - toJSON (ConsensusNetworkVersionTuple nodeToClientVersion blockVersion) = - Aeson.object [ "nodeToNodeVersion" .= nodeToClientVersion - , "blockVersion" .= blockVersion +instance Show blkVersion => ToJSON (ConsensusNetworkVersionTuple NodeToNodeVersion blkVersion) where + toJSON (ConsensusNetworkVersionTuple nodeToNodeVersion blockVersion) = + Aeson.object [ "nodeToNodeVersion" .= nodeToNodeVersion + , "blockVersion" .= String (pack $ show blockVersion) ] instance ( Show (BlockNodeToNodeVersion blk) , Show (BlockNodeToClientVersion blk) - , ToJSON (BlockNodeToNodeVersion blk) - , ToJSON (BlockNodeToClientVersion blk) ) => LogFormatting (StartupTrace blk) where forHuman = ppStartupInfoTrace @@ -172,12 +171,12 @@ instance ( Show (BlockNodeToNodeVersion blk) _ -> [ "maxNodeToNodeVersion" .= case Map.maxViewWithKey supportedNodeToNodeVersions of - Nothing -> String "no-supported-version" - Just (v, _) -> String (pack . show $ v) + Nothing -> String "no-supported-version" + Just ((k, _), _) -> toJSON k , "maxNodeToClientVersion" .= case Map.maxViewWithKey supportedNodeToClientVersions of - Nothing -> String "no-supported-version" - Just (v, _) -> String (pack . show $ v) + Nothing -> String "no-supported-version" + Just ((k, _), _) -> toJSON k ]) forMachine _dtal (StartupP2PInfo diffusionMode) = mconcat [ "kind" .= String "StartupP2PInfo" @@ -233,9 +232,9 @@ instance ( Show (BlockNodeToNodeVersion blk) , "message" .= String msg ] forMachine _dtal (NetworkConfig localRoots publicRoots useLedgerPeers peerSnapshotFileMaybe) = mconcat [ "kind" .= String "NetworkConfig" - , "localRoots" .= toJSON localRoots - , "publicRoots" .= toJSON publicRoots - , "useLedgerAfter" .= useLedgerPeers + , "localRoots" .= String (showT localRoots) + , "publicRoots" .= String (showT publicRoots) + , "useLedgerAfter" .= String (showT useLedgerPeers) , "peerSnapshotFile" .= case peerSnapshotFileMaybe of Nothing -> Null diff --git a/cardano-node/src/Cardano/Tracing/Config.hs b/cardano-node/src/Cardano/Tracing/Config.hs deleted file mode 100644 index 09e01488756..00000000000 --- a/cardano-node/src/Cardano/Tracing/Config.hs +++ /dev/null @@ -1,832 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} - -{- HLINT ignore "Redundant <$>" -} - -module Cardano.Tracing.Config - ( TraceOptions (..) - , TraceSelection (..) - , OnOff (..) - , PartialTraceOptions (..) - , PartialTraceSelection (..) - , partialTraceSelectionToEither - , defaultPartialTraceConfiguration - , lastToEither - - -- * Trace symbols - , TraceAcceptPolicy - , TraceBlockchainTime - , TraceBlockFetchClient - , TraceBlockFetchDecisions - , TraceBlockFetchProtocol - , TraceBlockFetchProtocolSerialised - , TraceBlockFetchServer - , TraceChainDB - , TraceChainSyncClient - , TraceChainSyncBlockServer - , TraceChainSyncHeaderServer - , TraceChainSyncProtocol - , TraceConnectionManager - , TraceConnectionManagerCounters - , TraceConnectionManagerTransitions - , DebugPeerSelectionInitiator - , DebugPeerSelectionInitiatorResponder - , TraceDiffusionInitialization - , TraceDnsResolver - , TraceDnsSubscription - , TraceErrorPolicy - , TraceForge - , TraceForgeStateInfo - , TraceHandshake - , TraceIpSubscription - , TraceKeepAliveClient - , TraceLedgerPeers - , TraceLocalChainSyncProtocol - , TraceLocalConnectionManager - , TraceLocalErrorPolicy - , TraceLocalHandshake - , TraceLocalInboundGovernor - , TraceLocalRootPeers - , TraceLocalServer - , TraceLocalStateQueryProtocol - , TraceLocalTxMonitorProtocol - , TraceLocalTxSubmissionProtocol - , TraceLocalTxSubmissionServer - , TraceMempool - , TraceMux - , TraceMuxBearer - , TraceMuxChannel - , TraceLocalMux - , TraceLocalMuxBearer - , TraceLocalMuxChannel - , TracePeerSelection - , TracePeerSelectionCounters - , TracePeerSelectionActions - , TracePublicRootPeers - , TraceServer - , TraceInboundGovernor - , TraceInboundGovernorCounters - , TraceInboundGovernorTransitions - , TraceTxInbound - , TraceTxOutbound - , TraceTxSubmissionProtocol - , TraceTxSubmission2Protocol - , TraceKeepAliveProtocol - , TracePeerSharingProtocol - , proxyName - ) where - -import Cardano.BM.Tracing (TracingVerbosity (..)) -import Cardano.Node.Orphans () - -import Control.Monad (MonadPlus (..)) -import Data.Aeson -import qualified Data.Aeson.Key as Aeson -import Data.Aeson.Types -import Data.Bifunctor (Bifunctor (..)) -import Data.Monoid (Last (..)) -import Data.Proxy (Proxy (..)) -import Data.Text (Text) -import qualified Data.Text as Text -import GHC.Generics (Generic) -import GHC.TypeLits (KnownSymbol, Symbol, symbolVal) - -import Generic.Data (gmappend) - -{- HLINT ignore "Functor law" -} - -data TraceOptions - = TracingOff - | TracingOnLegacy TraceSelection - | TraceDispatcher TraceSelection - deriving (Eq, Show) - -data PartialTraceOptions - = PartialTracingOff - | PartialTracingOnLegacy PartialTraceSelection - | PartialTraceDispatcher PartialTraceSelection - deriving (Eq, Show) - -instance Monoid PartialTraceOptions where - mempty = PartialTracingOff - --- Mimics Last's semantics -instance Semigroup PartialTraceOptions where - - tracingA <> tracingB = - case (tracingA, tracingB) of - (PartialTracingOnLegacy ptsA, PartialTracingOnLegacy ptsB) -> - PartialTracingOnLegacy (ptsA <> ptsB) - - (PartialTraceDispatcher ptsA, PartialTraceDispatcher ptsB) -> - PartialTraceDispatcher (ptsA <> ptsB) - - (_, tracing) -> tracing - -type TraceAcceptPolicy = ("TraceAcceptPolicy" :: Symbol) -type TraceBlockchainTime = ("TraceBlockchainTime" :: Symbol) -type TraceBlockFetchClient = ("TraceBlockFetchClient" :: Symbol) -type TraceBlockFetchDecisions = ("TraceBlockFetchDecisions" :: Symbol) -type TraceBlockFetchProtocol = ("TraceBlockFetchProtocol" :: Symbol) -type TraceBlockFetchProtocolSerialised = ("TraceBlockFetchProtocolSerialised" :: Symbol) -type TraceBlockFetchServer = ("TraceBlockFetchServer" :: Symbol) -type TraceChainDB = ("TraceChainDb" :: Symbol) -type TraceChainSyncClient = ("TraceChainSyncClient" :: Symbol) -type TraceChainSyncBlockServer = ("TraceChainSyncBlockServer" :: Symbol) -type TraceChainSyncHeaderServer = ("TraceChainSyncHeaderServer" :: Symbol) -type TraceChainSyncProtocol = ("TraceChainSyncProtocol" :: Symbol) -type TraceConnectionManager = ("TraceConnectionManager" :: Symbol) -type TraceConnectionManagerCounters = ("TraceConnectionManagerCounters" :: Symbol) -type TraceConnectionManagerTransitions = ("TraceConnectionManagerTransitions" :: Symbol) -type DebugPeerSelectionInitiator = ("DebugPeerSelectionInitiator" :: Symbol) -type DebugPeerSelectionInitiatorResponder = ("DebugPeerSelectionInitiatorResponder" :: Symbol) -type TraceDiffusionInitialization = ("TraceDiffusionInitialization" :: Symbol) -type TraceDnsResolver = ("TraceDnsResolver" :: Symbol) -type TraceDnsSubscription = ("TraceDnsSubscription" :: Symbol) -type TraceErrorPolicy = ("TraceErrorPolicy" :: Symbol) -type TraceForge = ("TraceForge" :: Symbol) -type TraceForgeStateInfo = ("TraceForgeStateInfo" :: Symbol) -type TraceGDD = ("TraceGDD" :: Symbol) -type TraceHandshake = ("TraceHandshake" :: Symbol) -type TraceIpSubscription = ("TraceIpSubscription" :: Symbol) -type TraceKeepAliveClient = ("TraceKeepAliveClient" :: Symbol) -type TraceLedgerPeers = ("TraceLedgerPeers" :: Symbol) -type TraceLocalChainSyncProtocol = ("TraceLocalChainSyncProtocol" :: Symbol) -type TraceLocalConnectionManager = ("TraceLocalConnectionManager" :: Symbol) -type TraceLocalErrorPolicy = ("TraceLocalErrorPolicy" :: Symbol) -type TraceLocalHandshake = ("TraceLocalHandshake" :: Symbol) -type TraceLocalInboundGovernor = ("TraceLocalInboundGovernor" :: Symbol) -type TraceLocalRootPeers = ("TraceLocalRootPeers" :: Symbol) -type TraceLocalServer = ("TraceLocalServer" :: Symbol) -type TraceLocalStateQueryProtocol = ("TraceLocalStateQueryProtocol" :: Symbol) -type TraceLocalTxMonitorProtocol = ("TraceLocalTxMonitorProtocol" :: Symbol) -type TraceLocalTxSubmissionProtocol = ("TraceLocalTxSubmissionProtocol" :: Symbol) -type TraceLocalTxSubmissionServer = ("TraceLocalTxSubmissionServer" :: Symbol) -type TraceMempool = ("TraceMempool" :: Symbol) -type TraceBackingStore = ("TraceBackingStore" :: Symbol) -type TraceMux = ("TraceMux" :: Symbol) -type TraceMuxBearer = ("TraceMuxBearer" :: Symbol) -type TraceMuxChannel = ("TraceMuxChannel" :: Symbol) -type TraceLocalMux = ("TraceLocalMux" :: Symbol) -type TraceLocalMuxBearer = ("TraceLocalMuxBearer" :: Symbol) -type TraceLocalMuxChannel = ("TraceLocalMuxChannel" :: Symbol) -type TracePeerSelection = ("TracePeerSelection" :: Symbol) -type TracePeerSelectionCounters = ("TracePeerSelectionCounters" :: Symbol) -type TracePeerSelectionActions = ("TracePeerSelectionActions" :: Symbol) -type TracePublicRootPeers = ("TracePublicRootPeers" :: Symbol) -type TraceSanityCheckIssue = ("TraceSanityCheckIssue" :: Symbol) -type TraceServer = ("TraceServer" :: Symbol) -type TraceInboundGovernor = ("TraceInboundGovernor" :: Symbol) -type TraceInboundGovernorCounters = ("TraceInboundGovernorCounters" :: Symbol) -type TraceInboundGovernorTransitions = ("TraceInboundGovernorTransitions" :: Symbol) -type TraceTxInbound = ("TraceTxInbound" :: Symbol) -type TraceTxOutbound = ("TraceTxOutbound" :: Symbol) -type TraceTxSubmissionProtocol = ("TraceTxSubmissionProtocol" :: Symbol) -type TraceTxSubmission2Protocol = ("TraceTxSubmission2Protocol" :: Symbol) -type TraceKeepAliveProtocol = ("TraceKeepAliveProtocol" :: Symbol) -type TracePeerSharingProtocol = ("TracePeerSharingProtocol" :: Symbol) -type TraceGsm = ("TraceGsm" :: Symbol) -type TraceCsj = ("TraceCsj" :: Symbol) -type TraceKesAgent = ("TraceKesAgent" :: Symbol) -type TraceDevotedBlockFetch = ("TraceDevotedBlockFetch" :: Symbol) -type TraceChurnMode = ("TraceChurnMode" :: Symbol) -type TraceDNS = ("TraceDNS" :: Symbol) -type TraceTxLogic = ("TraceTxLogic" :: Symbol) -type TraceTxCounters = ("TraceTxCounters" :: Symbol) - -newtype OnOff (name :: Symbol) = OnOff { isOn :: Bool } deriving (Eq, Show) - -instance FromJSON (OnOff a) where - parseJSON (Data.Aeson.Bool b)= return $ OnOff b - parseJSON _ = mzero - -proxyName :: KnownSymbol name => Proxy name -> Text -proxyName p = Text.pack (symbolVal p) - -data TraceSelection - = TraceSelection - { traceVerbosity :: !TracingVerbosity - - -- Per-trace toggles, alpha-sorted. - , traceAcceptPolicy :: OnOff TraceAcceptPolicy - , traceBlockFetchClient :: OnOff TraceBlockFetchClient - , traceBlockFetchDecisions :: OnOff TraceBlockFetchDecisions - , traceBlockFetchProtocol :: OnOff TraceBlockFetchProtocol - , traceBlockFetchProtocolSerialised :: OnOff TraceBlockFetchProtocolSerialised - , traceBlockFetchServer :: OnOff TraceBlockFetchServer - , traceBlockchainTime :: OnOff TraceBlockchainTime - , traceChainDB :: OnOff TraceChainDB - , traceChainSyncBlockServer :: OnOff TraceChainSyncBlockServer - , traceChainSyncClient :: OnOff TraceChainSyncClient - , traceChainSyncHeaderServer :: OnOff TraceChainSyncHeaderServer - , traceChainSyncProtocol :: OnOff TraceChainSyncProtocol - , traceConnectionManager :: OnOff TraceConnectionManager - , traceConnectionManagerCounters :: OnOff TraceConnectionManagerCounters - , traceConnectionManagerTransitions :: OnOff TraceConnectionManagerTransitions - , traceDebugPeerSelectionInitiatorTracer :: OnOff DebugPeerSelectionInitiator - , traceDebugPeerSelectionInitiatorResponderTracer :: OnOff DebugPeerSelectionInitiatorResponder - , traceDiffusionInitialization :: OnOff TraceDiffusionInitialization - , traceDnsResolver :: OnOff TraceDnsResolver - , traceDnsSubscription :: OnOff TraceDnsSubscription - , traceErrorPolicy :: OnOff TraceErrorPolicy - , traceForge :: OnOff TraceForge - , traceForgeStateInfo :: OnOff TraceForgeStateInfo - , traceGDD :: OnOff TraceGDD - , traceHandshake :: OnOff TraceHandshake - , traceInboundGovernor :: OnOff TraceInboundGovernor - , traceInboundGovernorCounters :: OnOff TraceInboundGovernorCounters - , traceInboundGovernorTransitions :: OnOff TraceInboundGovernorTransitions - , traceIpSubscription :: OnOff TraceIpSubscription - , traceKeepAliveClient :: OnOff TraceKeepAliveClient - , traceLedgerPeers :: OnOff TraceLedgerPeers - , traceLocalChainSyncProtocol :: OnOff TraceLocalChainSyncProtocol - , traceLocalConnectionManager :: OnOff TraceLocalConnectionManager - , traceLocalErrorPolicy :: OnOff TraceLocalErrorPolicy - , traceLocalHandshake :: OnOff TraceLocalHandshake - , traceLocalInboundGovernor :: OnOff TraceLocalInboundGovernor - , traceLocalMux :: OnOff TraceLocalMux - , traceLocalMuxBearer :: OnOff TraceLocalMuxBearer - , traceLocalMuxChannel :: OnOff TraceLocalMuxChannel - , traceLocalRootPeers :: OnOff TraceLocalRootPeers - , traceLocalServer :: OnOff TraceLocalServer - , traceLocalStateQueryProtocol :: OnOff TraceLocalStateQueryProtocol - , traceLocalTxMonitorProtocol :: OnOff TraceLocalTxMonitorProtocol - , traceLocalTxSubmissionProtocol :: OnOff TraceLocalTxSubmissionProtocol - , traceLocalTxSubmissionServer :: OnOff TraceLocalTxSubmissionServer - , traceMempool :: OnOff TraceMempool - , traceBackingStore :: OnOff TraceBackingStore - , traceMux :: OnOff TraceMux - , traceMuxBearer :: OnOff TraceMuxBearer - , traceMuxChannel :: OnOff TraceMuxChannel - , tracePeerSelection :: OnOff TracePeerSelection - , tracePeerSelectionCounters :: OnOff TracePeerSelectionCounters - , tracePeerSelectionActions :: OnOff TracePeerSelectionActions - , tracePublicRootPeers :: OnOff TracePublicRootPeers - , traceSanityCheckIssue :: OnOff TraceSanityCheckIssue - , traceServer :: OnOff TraceServer - , traceTxInbound :: OnOff TraceTxInbound - , traceTxOutbound :: OnOff TraceTxOutbound - , traceTxSubmissionProtocol :: OnOff TraceTxSubmissionProtocol - , traceTxSubmission2Protocol :: OnOff TraceTxSubmission2Protocol - , traceKeepAliveProtocol :: OnOff TraceKeepAliveProtocol - , tracePeerSharingProtocol :: OnOff TracePeerSharingProtocol - , traceGsm :: OnOff TraceGsm - , traceCsj :: OnOff TraceCsj - , traceKesAgent :: OnOff TraceKesAgent - , traceDevotedBlockFetch :: OnOff TraceDevotedBlockFetch - , traceChurnMode :: OnOff TraceChurnMode - , traceDNS :: OnOff TraceDNS - , traceTxLogic :: OnOff TraceTxLogic - , traceTxCounters :: OnOff TraceTxCounters - } deriving (Eq, Show) - - - -data PartialTraceSelection - = PartialTraceSelection - { pTraceVerbosity :: !(Last TracingVerbosity) - - -- Per-trace toggles, alpha-sorted. - , pTraceAcceptPolicy :: Last (OnOff TraceAcceptPolicy) - , pTraceBlockchainTime :: Last (OnOff TraceBlockchainTime) - , pTraceBlockFetchClient :: Last (OnOff TraceBlockFetchClient) - , pTraceBlockFetchDecisions :: Last (OnOff TraceBlockFetchDecisions) - , pTraceBlockFetchProtocol :: Last (OnOff TraceBlockFetchProtocol) - , pTraceBlockFetchProtocolSerialised :: Last (OnOff TraceBlockFetchProtocolSerialised) - , pTraceBlockFetchServer :: Last (OnOff TraceBlockFetchServer) - , pTraceChainDB :: Last (OnOff TraceChainDB) - , pTraceChainSyncBlockServer :: Last (OnOff TraceChainSyncBlockServer) - , pTraceChainSyncClient :: Last (OnOff TraceChainSyncClient) - , pTraceChainSyncHeaderServer :: Last (OnOff TraceChainSyncHeaderServer) - , pTraceChainSyncProtocol :: Last (OnOff TraceChainSyncProtocol) - , pTraceConnectionManager :: Last (OnOff TraceConnectionManager) - , pTraceConnectionManagerCounters :: Last (OnOff TraceConnectionManagerCounters) - , pTraceConnectionManagerTransitions :: Last (OnOff TraceConnectionManagerTransitions) - , pTraceDebugPeerSelectionInitiatorTracer :: Last (OnOff DebugPeerSelectionInitiator) - , pTraceDiffusionInitialization :: Last (OnOff TraceDiffusionInitialization) - , pTraceDebugPeerSelectionInitiatorResponderTracer :: Last (OnOff DebugPeerSelectionInitiatorResponder) - , pTraceDnsResolver :: Last (OnOff TraceDnsResolver) - , pTraceDnsSubscription :: Last (OnOff TraceDnsSubscription) - , pTraceErrorPolicy :: Last (OnOff TraceErrorPolicy) - , pTraceForge :: Last (OnOff TraceForge) - , pTraceForgeStateInfo :: Last (OnOff TraceForgeStateInfo) - , pTraceGDD :: Last (OnOff TraceGDD) - , pTraceHandshake :: Last (OnOff TraceHandshake) - , pTraceInboundGovernor :: Last (OnOff TraceInboundGovernor) - , pTraceInboundGovernorCounters :: Last (OnOff TraceInboundGovernorCounters) - , pTraceInboundGovernorTransitions :: Last (OnOff TraceInboundGovernorTransitions) - , pTraceIpSubscription :: Last (OnOff TraceIpSubscription) - , pTraceKeepAliveClient :: Last (OnOff TraceKeepAliveClient) - , pTraceLedgerPeers :: Last (OnOff TraceLedgerPeers) - , pTraceLocalChainSyncProtocol :: Last (OnOff TraceLocalChainSyncProtocol) - , pTraceLocalConnectionManager :: Last (OnOff TraceLocalConnectionManager) - , pTraceLocalErrorPolicy :: Last (OnOff TraceLocalErrorPolicy) - , pTraceLocalHandshake :: Last (OnOff TraceLocalHandshake) - , pTraceLocalInboundGovernor :: Last (OnOff TraceLocalInboundGovernor) - , pTraceLocalMux :: Last (OnOff TraceLocalMux) - , pTraceLocalMuxBearer :: Last (OnOff TraceLocalMuxBearer) - , pTraceLocalMuxChannel :: Last (OnOff TraceLocalMuxChannel) - , pTraceLocalRootPeers :: Last (OnOff TraceLocalRootPeers) - , pTraceLocalServer :: Last (OnOff TraceLocalServer) - , pTraceLocalStateQueryProtocol :: Last (OnOff TraceLocalStateQueryProtocol) - , pTraceLocalTxMonitorProtocol :: Last (OnOff TraceLocalTxMonitorProtocol) - , pTraceLocalTxSubmissionProtocol :: Last (OnOff TraceLocalTxSubmissionProtocol) - , pTraceLocalTxSubmissionServer :: Last (OnOff TraceLocalTxSubmissionServer) - , pTraceMempool :: Last (OnOff TraceMempool) - , pTraceBackingStore :: Last (OnOff TraceBackingStore) - , pTraceMux :: Last (OnOff TraceMux) - , pTraceMuxBearer :: Last (OnOff TraceMuxBearer) - , pTraceMuxChannel :: Last (OnOff TraceMuxChannel) - , pTracePeerSelection :: Last (OnOff TracePeerSelection) - , pTracePeerSelectionCounters :: Last (OnOff TracePeerSelectionCounters) - , pTracePeerSelectionActions :: Last (OnOff TracePeerSelectionActions) - , pTracePublicRootPeers :: Last (OnOff TracePublicRootPeers) - , pTraceSanityCheckIssue :: Last (OnOff TraceSanityCheckIssue) - , pTraceServer :: Last (OnOff TraceServer) - , pTraceTxInbound :: Last (OnOff TraceTxInbound) - , pTraceTxOutbound :: Last (OnOff TraceTxOutbound) - , pTraceTxSubmissionProtocol :: Last (OnOff TraceTxSubmissionProtocol) - , pTraceTxSubmission2Protocol :: Last (OnOff TraceTxSubmission2Protocol) - , pTraceKeepAliveProtocol :: Last (OnOff TraceKeepAliveProtocol) - , pTracePeerSharingProtocol :: Last (OnOff TracePeerSharingProtocol) - , pTraceGsm :: Last (OnOff TraceGsm) - , pTraceCsj :: Last (OnOff TraceCsj) - , pTraceDevotedBlockFetch :: Last (OnOff TraceDevotedBlockFetch) - , pTraceChurnMode :: Last (OnOff TraceChurnMode) - , pTraceDNS :: Last (OnOff TraceDNS) - , pTraceKesAgent :: Last (OnOff TraceKesAgent) - , pTraceTxLogic :: Last (OnOff TraceTxLogic) - , pTraceTxCounters :: Last (OnOff TraceTxCounters) - } deriving (Eq, Generic, Show) - - -instance Semigroup PartialTraceSelection where - (<>) = gmappend - -instance FromJSON PartialTraceSelection where - parseJSON = withObject "PartialTraceSelection" $ \v -> do - PartialTraceSelection - <$> Last <$> v .:? "TracingVerbosity" - <*> parseTracer (Proxy @TraceAcceptPolicy) v - <*> parseTracer (Proxy @TraceBlockchainTime) v - <*> parseTracer (Proxy @TraceBlockFetchClient) v - <*> parseTracer (Proxy @TraceBlockFetchDecisions) v - <*> parseTracer (Proxy @TraceBlockFetchProtocol) v - <*> parseTracer (Proxy @TraceBlockFetchProtocolSerialised) v - <*> parseTracer (Proxy @TraceBlockFetchServer) v - <*> parseTracer (Proxy @TraceChainDB) v - <*> parseTracer (Proxy @TraceChainSyncBlockServer) v - <*> parseTracer (Proxy @TraceChainSyncClient) v - <*> parseTracer (Proxy @TraceChainSyncHeaderServer) v - <*> parseTracer (Proxy @TraceChainSyncProtocol) v - <*> parseTracer (Proxy @TraceConnectionManager) v - <*> parseTracer (Proxy @TraceConnectionManagerCounters) v - <*> parseTracer (Proxy @TraceConnectionManagerTransitions) v - <*> parseTracer (Proxy @DebugPeerSelectionInitiator) v - <*> parseTracer (Proxy @TraceDiffusionInitialization) v - <*> parseTracer (Proxy @DebugPeerSelectionInitiatorResponder) v - <*> parseTracer (Proxy @TraceDnsResolver) v - <*> parseTracer (Proxy @TraceDnsSubscription) v - <*> parseTracer (Proxy @TraceErrorPolicy) v - <*> parseTracer (Proxy @TraceForge) v - <*> parseTracer (Proxy @TraceForgeStateInfo) v - <*> parseTracer (Proxy @TraceGDD) v - <*> parseTracer (Proxy @TraceHandshake) v - <*> parseTracer (Proxy @TraceInboundGovernor) v - <*> parseTracer (Proxy @TraceInboundGovernorCounters) v - <*> parseTracer (Proxy @TraceInboundGovernorTransitions) v - <*> parseTracer (Proxy @TraceIpSubscription) v - <*> parseTracer (Proxy @TraceKeepAliveClient) v - <*> parseTracer (Proxy @TraceLedgerPeers) v - <*> parseTracer (Proxy @TraceLocalChainSyncProtocol) v - <*> parseTracer (Proxy @TraceLocalConnectionManager) v - <*> parseTracer (Proxy @TraceLocalErrorPolicy) v - <*> parseTracer (Proxy @TraceLocalHandshake) v - <*> parseTracer (Proxy @TraceLocalInboundGovernor) v - <*> parseTracer (Proxy @TraceLocalMux) v - <*> parseTracer (Proxy @TraceLocalMuxBearer) v - <*> parseTracer (Proxy @TraceLocalMuxChannel) v - <*> parseTracer (Proxy @TraceLocalRootPeers) v - <*> parseTracer (Proxy @TraceLocalServer) v - <*> parseTracer (Proxy @TraceLocalStateQueryProtocol) v - <*> parseTracer (Proxy @TraceLocalTxMonitorProtocol) v - <*> parseTracer (Proxy @TraceLocalTxSubmissionProtocol) v - <*> parseTracer (Proxy @TraceLocalTxSubmissionServer) v - <*> parseTracer (Proxy @TraceMempool) v - <*> parseTracer (Proxy @TraceBackingStore) v - <*> parseTracer (Proxy @TraceMux) v - <*> parseTracer (Proxy @TraceMuxBearer) v - <*> parseTracer (Proxy @TraceMuxChannel) v - <*> parseTracer (Proxy @TracePeerSelection) v - <*> parseTracer (Proxy @TracePeerSelectionCounters) v - <*> parseTracer (Proxy @TracePeerSelectionActions) v - <*> parseTracer (Proxy @TracePublicRootPeers) v - <*> parseTracer (Proxy @TraceSanityCheckIssue) v - <*> parseTracer (Proxy @TraceServer) v - <*> parseTracer (Proxy @TraceTxInbound) v - <*> parseTracer (Proxy @TraceTxOutbound) v - <*> parseTracer (Proxy @TraceTxSubmissionProtocol) v - <*> parseTracer (Proxy @TraceTxSubmission2Protocol) v - <*> parseTracer (Proxy @TraceKeepAliveProtocol) v - <*> parseTracer (Proxy @TracePeerSharingProtocol) v - <*> parseTracer (Proxy @TraceGsm) v - <*> parseTracer (Proxy @TraceCsj) v - <*> parseTracer (Proxy @TraceDevotedBlockFetch) v - <*> parseTracer (Proxy @TraceChurnMode) v - <*> parseTracer (Proxy @TraceDNS) v - <*> parseTracer (Proxy @TraceKesAgent) v - <*> parseTracer (Proxy @TraceTxLogic) v - <*> parseTracer (Proxy @TraceTxCounters) v - - -defaultPartialTraceConfiguration :: PartialTraceSelection -defaultPartialTraceConfiguration = - PartialTraceSelection - { pTraceVerbosity = Last $ Just NormalVerbosity - -- Per-trace toggles, alpha-sorted. - , pTraceAcceptPolicy = pure $ OnOff False - , pTraceBlockchainTime = pure $ OnOff False - , pTraceBlockFetchClient = pure $ OnOff False - , pTraceBlockFetchDecisions = pure $ OnOff True - , pTraceBlockFetchProtocol = pure $ OnOff False - , pTraceBlockFetchProtocolSerialised = pure $ OnOff False - , pTraceBlockFetchServer = pure $ OnOff False - , pTraceChainDB = pure $ OnOff True - , pTraceChainSyncBlockServer = pure $ OnOff False - , pTraceChainSyncClient = pure $ OnOff True - , pTraceChainSyncHeaderServer = pure $ OnOff False - , pTraceChainSyncProtocol = pure $ OnOff False - , pTraceConnectionManager = pure $ OnOff True - , pTraceConnectionManagerCounters = pure $ OnOff True - , pTraceConnectionManagerTransitions = pure $ OnOff False - , pTraceDebugPeerSelectionInitiatorTracer = pure $ OnOff False - , pTraceDebugPeerSelectionInitiatorResponderTracer = pure $ OnOff False - , pTraceDiffusionInitialization = pure $ OnOff False - , pTraceDnsResolver = pure $ OnOff False - , pTraceDnsSubscription = pure $ OnOff True - , pTraceErrorPolicy = pure $ OnOff True - , pTraceForge = pure $ OnOff True - , pTraceForgeStateInfo = pure $ OnOff True - , pTraceGDD = pure $ OnOff False - , pTraceHandshake = pure $ OnOff False - , pTraceInboundGovernor = pure $ OnOff True - , pTraceInboundGovernorCounters = pure $ OnOff True - , pTraceInboundGovernorTransitions = pure $ OnOff True - , pTraceIpSubscription = pure $ OnOff True - , pTraceKeepAliveClient = pure $ OnOff False - , pTraceLedgerPeers = pure $ OnOff False - , pTraceLocalChainSyncProtocol = pure $ OnOff False - , pTraceLocalConnectionManager = pure $ OnOff True - , pTraceLocalErrorPolicy = pure $ OnOff True - , pTraceLocalHandshake = pure $ OnOff True - , pTraceLocalInboundGovernor = pure $ OnOff True - , pTraceLocalMux = pure $ OnOff False - , pTraceLocalMuxBearer = pure $ OnOff False - , pTraceLocalMuxChannel = pure $ OnOff False - , pTraceLocalTxMonitorProtocol = pure $ OnOff False - , pTraceLocalRootPeers = pure $ OnOff False - , pTraceLocalServer = pure $ OnOff True - , pTraceLocalStateQueryProtocol = pure $ OnOff False - , pTraceLocalTxSubmissionProtocol = pure $ OnOff False - , pTraceLocalTxSubmissionServer = pure $ OnOff False - , pTraceMempool = pure $ OnOff True - , pTraceBackingStore = pure $ OnOff False - , pTraceMux = pure $ OnOff False - , pTraceMuxBearer = pure $ OnOff False - , pTraceMuxChannel = pure $ OnOff False - , pTracePeerSelection = pure $ OnOff True - , pTracePeerSelectionCounters = pure $ OnOff True - , pTracePeerSelectionActions = pure $ OnOff True - , pTracePublicRootPeers = pure $ OnOff False - , pTraceSanityCheckIssue = pure $ OnOff False - , pTraceServer = pure $ OnOff True - , pTraceTxInbound = pure $ OnOff False - , pTraceTxOutbound = pure $ OnOff False - , pTraceTxSubmissionProtocol = pure $ OnOff False - , pTraceTxSubmission2Protocol = pure $ OnOff False - , pTraceKeepAliveProtocol = pure $ OnOff False - , pTracePeerSharingProtocol = pure $ OnOff False - , pTraceGsm = pure $ OnOff True - , pTraceCsj = pure $ OnOff True - , pTraceDevotedBlockFetch = pure $ OnOff True - , pTraceChurnMode = pure $ OnOff True - , pTraceDNS = pure $ OnOff True - , pTraceKesAgent = pure $ OnOff False - , pTraceTxLogic = pure $ OnOff False - , pTraceTxCounters = pure $ OnOff False - } - - -partialTraceSelectionToEither :: Last PartialTraceOptions -> Either Text TraceOptions -partialTraceSelectionToEither (Last Nothing) = Right TracingOff -partialTraceSelectionToEither (Last (Just PartialTracingOff)) = Right TracingOff -partialTraceSelectionToEither (Last (Just (PartialTraceDispatcher pTraceSelection))) = do - let PartialTraceSelection {..} = defaultPartialTraceConfiguration <> pTraceSelection - traceVerbosity <- first Text.pack $ lastToEither "Default value not specified for TracingVerbosity" pTraceVerbosity - traceAcceptPolicy <- proxyLastToEither (Proxy @TraceAcceptPolicy) pTraceAcceptPolicy - traceBlockchainTime <- proxyLastToEither (Proxy @TraceBlockchainTime) pTraceBlockchainTime - traceBlockFetchClient <- proxyLastToEither (Proxy @TraceBlockFetchClient) pTraceBlockFetchClient - traceBlockFetchDecisions <- proxyLastToEither (Proxy @TraceBlockFetchDecisions) pTraceBlockFetchDecisions - traceBlockFetchProtocol <- proxyLastToEither (Proxy @TraceBlockFetchProtocol) pTraceBlockFetchProtocol - traceBlockFetchProtocolSerialised <- proxyLastToEither (Proxy @TraceBlockFetchProtocolSerialised) pTraceBlockFetchProtocolSerialised - traceBlockFetchServer <- proxyLastToEither (Proxy @TraceBlockFetchServer) pTraceBlockFetchServer - traceChainDB <- proxyLastToEither (Proxy @TraceChainDB) pTraceChainDB - traceChainSyncClient <- proxyLastToEither (Proxy @TraceChainSyncClient) pTraceChainSyncClient - traceChainSyncBlockServer <- proxyLastToEither (Proxy @TraceChainSyncBlockServer) pTraceChainSyncBlockServer - traceChainSyncHeaderServer <- proxyLastToEither (Proxy @TraceChainSyncHeaderServer) pTraceChainSyncHeaderServer - traceChainSyncProtocol <- proxyLastToEither (Proxy @TraceChainSyncProtocol) pTraceChainSyncProtocol - traceConnectionManager <- proxyLastToEither (Proxy @TraceConnectionManager) pTraceConnectionManager - traceConnectionManagerCounters <- proxyLastToEither (Proxy @TraceConnectionManagerCounters) pTraceConnectionManagerCounters - traceConnectionManagerTransitions <- proxyLastToEither (Proxy @TraceConnectionManagerTransitions) pTraceConnectionManagerTransitions - traceDebugPeerSelectionInitiatorTracer <- proxyLastToEither (Proxy @DebugPeerSelectionInitiator) pTraceDebugPeerSelectionInitiatorTracer - traceDebugPeerSelectionInitiatorResponderTracer <- proxyLastToEither (Proxy @DebugPeerSelectionInitiatorResponder) pTraceDebugPeerSelectionInitiatorResponderTracer - traceDiffusionInitialization <- proxyLastToEither (Proxy @TraceDiffusionInitialization) pTraceDiffusionInitialization - traceDnsResolver <- proxyLastToEither (Proxy @TraceDnsResolver) pTraceDnsResolver - traceDnsSubscription <- proxyLastToEither (Proxy @TraceDnsSubscription) pTraceDnsSubscription - traceErrorPolicy <- proxyLastToEither (Proxy @TraceErrorPolicy) pTraceErrorPolicy - traceForge <- proxyLastToEither (Proxy @TraceForge) pTraceForge - traceForgeStateInfo <- proxyLastToEither (Proxy @TraceForgeStateInfo) pTraceForgeStateInfo - traceGDD <- proxyLastToEither (Proxy @TraceGDD) pTraceGDD - traceHandshake <- proxyLastToEither (Proxy @TraceHandshake) pTraceHandshake - traceInboundGovernor <- proxyLastToEither (Proxy @TraceInboundGovernor) pTraceInboundGovernor - traceInboundGovernorCounters <- proxyLastToEither (Proxy @TraceInboundGovernorCounters) pTraceInboundGovernorCounters - traceInboundGovernorTransitions <- proxyLastToEither (Proxy @TraceInboundGovernorTransitions) pTraceInboundGovernorTransitions - traceIpSubscription <- proxyLastToEither (Proxy @TraceIpSubscription) pTraceIpSubscription - traceKeepAliveClient <- proxyLastToEither (Proxy @TraceKeepAliveClient) pTraceKeepAliveClient - traceLedgerPeers <- proxyLastToEither (Proxy @TraceLedgerPeers) pTraceLedgerPeers - traceLocalChainSyncProtocol <- proxyLastToEither (Proxy @TraceLocalChainSyncProtocol) pTraceLocalChainSyncProtocol - traceLocalConnectionManager <- proxyLastToEither (Proxy @TraceLocalConnectionManager) pTraceLocalConnectionManager - traceLocalErrorPolicy <- proxyLastToEither (Proxy @TraceLocalErrorPolicy) pTraceLocalErrorPolicy - traceLocalHandshake <- proxyLastToEither (Proxy @TraceLocalHandshake) pTraceLocalHandshake - traceLocalInboundGovernor <- proxyLastToEither (Proxy @TraceLocalInboundGovernor) pTraceLocalInboundGovernor - traceLocalMux <- proxyLastToEither (Proxy @TraceLocalMux) pTraceLocalMux - traceLocalMuxBearer <- proxyLastToEither (Proxy @TraceLocalMuxBearer) pTraceLocalMuxBearer - traceLocalMuxChannel <- proxyLastToEither (Proxy @TraceLocalMuxChannel) pTraceLocalMuxChannel - traceLocalTxMonitorProtocol <- proxyLastToEither (Proxy @TraceLocalTxMonitorProtocol) pTraceLocalTxMonitorProtocol - traceLocalRootPeers <- proxyLastToEither (Proxy @TraceLocalRootPeers) pTraceLocalRootPeers - traceLocalServer <- proxyLastToEither (Proxy @TraceLocalServer) pTraceLocalServer - traceLocalStateQueryProtocol <- proxyLastToEither (Proxy @TraceLocalStateQueryProtocol) pTraceLocalStateQueryProtocol - traceLocalTxSubmissionProtocol <- proxyLastToEither (Proxy @TraceLocalTxSubmissionProtocol) pTraceLocalTxSubmissionProtocol - traceLocalTxSubmissionServer <- proxyLastToEither (Proxy @TraceLocalTxSubmissionServer) pTraceLocalTxSubmissionServer - traceMempool <- proxyLastToEither (Proxy @TraceMempool) pTraceMempool - traceBackingStore <- proxyLastToEither (Proxy @TraceBackingStore) pTraceBackingStore - traceMux <- proxyLastToEither (Proxy @TraceMux) pTraceMux - traceMuxBearer <- proxyLastToEither (Proxy @TraceMuxBearer) pTraceMuxBearer - traceMuxChannel <- proxyLastToEither (Proxy @TraceMuxChannel) pTraceMuxChannel - tracePeerSelection <- proxyLastToEither (Proxy @TracePeerSelection) pTracePeerSelection - tracePeerSelectionCounters <- proxyLastToEither (Proxy @TracePeerSelectionCounters) pTracePeerSelectionCounters - tracePeerSelectionActions <- proxyLastToEither (Proxy @TracePeerSelectionActions) pTracePeerSelectionActions - tracePublicRootPeers <- proxyLastToEither (Proxy @TracePublicRootPeers) pTracePublicRootPeers - traceSanityCheckIssue <- proxyLastToEither (Proxy @TraceSanityCheckIssue) pTraceSanityCheckIssue - traceServer <- proxyLastToEither (Proxy @TraceServer) pTraceServer - traceTxInbound <- proxyLastToEither (Proxy @TraceTxInbound) pTraceTxInbound - traceTxOutbound <- proxyLastToEither (Proxy @TraceTxOutbound) pTraceTxOutbound - traceTxSubmissionProtocol <- proxyLastToEither (Proxy @TraceTxSubmissionProtocol) pTraceTxSubmissionProtocol - traceTxSubmission2Protocol <- proxyLastToEither (Proxy @TraceTxSubmission2Protocol) pTraceTxSubmission2Protocol - traceKeepAliveProtocol <- proxyLastToEither (Proxy @TraceKeepAliveProtocol) pTraceKeepAliveProtocol - tracePeerSharingProtocol <- proxyLastToEither (Proxy @TracePeerSharingProtocol) pTracePeerSharingProtocol - traceGsm <- proxyLastToEither (Proxy @TraceGsm) pTraceGsm - traceCsj <- proxyLastToEither (Proxy @TraceCsj) pTraceCsj - traceKesAgent <- proxyLastToEither (Proxy @TraceKesAgent) pTraceKesAgent - traceDevotedBlockFetch <- proxyLastToEither (Proxy @TraceDevotedBlockFetch) pTraceDevotedBlockFetch - traceChurnMode <- proxyLastToEither (Proxy @TraceChurnMode) pTraceChurnMode - traceDNS <- proxyLastToEither (Proxy @TraceDNS) pTraceDNS - traceTxLogic <- proxyLastToEither (Proxy @TraceTxLogic) pTraceTxLogic - traceTxCounters <- proxyLastToEither (Proxy @TraceTxCounters) pTraceTxCounters - Right $ TraceDispatcher $ TraceSelection - { traceVerbosity = traceVerbosity - , traceAcceptPolicy = traceAcceptPolicy - , traceBlockFetchClient = traceBlockFetchClient - , traceBlockFetchDecisions = traceBlockFetchDecisions - , traceBlockFetchProtocol = traceBlockFetchProtocol - , traceBlockFetchProtocolSerialised = traceBlockFetchProtocolSerialised - , traceBlockFetchServer = traceBlockFetchServer - , traceBlockchainTime = traceBlockchainTime - , traceChainDB = traceChainDB - , traceChainSyncBlockServer = traceChainSyncBlockServer - , traceChainSyncClient = traceChainSyncClient - , traceChainSyncHeaderServer = traceChainSyncHeaderServer - , traceChainSyncProtocol = traceChainSyncProtocol - , traceConnectionManager = traceConnectionManager - , traceConnectionManagerCounters = traceConnectionManagerCounters - , traceConnectionManagerTransitions = traceConnectionManagerTransitions - , traceDebugPeerSelectionInitiatorTracer = traceDebugPeerSelectionInitiatorTracer - , traceDebugPeerSelectionInitiatorResponderTracer = traceDebugPeerSelectionInitiatorResponderTracer - , traceDiffusionInitialization = traceDiffusionInitialization - , traceDnsResolver = traceDnsResolver - , traceDnsSubscription = traceDnsSubscription - , traceErrorPolicy = traceErrorPolicy - , traceForge = traceForge - , traceForgeStateInfo = traceForgeStateInfo - , traceGDD = traceGDD - , traceHandshake = traceHandshake - , traceInboundGovernor = traceInboundGovernor - , traceInboundGovernorCounters = traceInboundGovernorCounters - , traceInboundGovernorTransitions = traceInboundGovernorTransitions - , traceIpSubscription = traceIpSubscription - , traceKeepAliveClient = traceKeepAliveClient - , traceLedgerPeers = traceLedgerPeers - , traceLocalChainSyncProtocol = traceLocalChainSyncProtocol - , traceLocalConnectionManager = traceLocalConnectionManager - , traceLocalErrorPolicy = traceLocalErrorPolicy - , traceLocalHandshake = traceLocalHandshake - , traceLocalInboundGovernor = traceLocalInboundGovernor - , traceLocalMux = traceLocalMux - , traceLocalMuxBearer = traceLocalMuxBearer - , traceLocalMuxChannel = traceLocalMuxChannel - , traceLocalTxMonitorProtocol = traceLocalTxMonitorProtocol - , traceLocalRootPeers = traceLocalRootPeers - , traceLocalServer = traceLocalServer - , traceLocalStateQueryProtocol = traceLocalStateQueryProtocol - , traceLocalTxSubmissionProtocol = traceLocalTxSubmissionProtocol - , traceLocalTxSubmissionServer = traceLocalTxSubmissionServer - , traceMempool = traceMempool - , traceBackingStore = traceBackingStore - , traceMux = traceMux - , traceMuxBearer = traceMuxBearer - , traceMuxChannel = traceMuxChannel - , tracePeerSelection = tracePeerSelection - , tracePeerSelectionCounters = tracePeerSelectionCounters - , tracePeerSelectionActions = tracePeerSelectionActions - , tracePublicRootPeers = tracePublicRootPeers - , traceSanityCheckIssue = traceSanityCheckIssue - , traceServer = traceServer - , traceTxInbound = traceTxInbound - , traceTxOutbound = traceTxOutbound - , traceTxSubmissionProtocol = traceTxSubmissionProtocol - , traceTxSubmission2Protocol = traceTxSubmission2Protocol - , traceKeepAliveProtocol = traceKeepAliveProtocol - , tracePeerSharingProtocol = tracePeerSharingProtocol - , traceGsm = traceGsm - , traceCsj = traceCsj - , traceDevotedBlockFetch = traceDevotedBlockFetch - , traceChurnMode - , traceDNS - , traceKesAgent = traceKesAgent - , traceTxLogic - , traceTxCounters - } - -partialTraceSelectionToEither (Last (Just (PartialTracingOnLegacy pTraceSelection))) = do - -- This will be removed once the old tracing system is deprecated. - let PartialTraceSelection {..} = defaultPartialTraceConfiguration <> pTraceSelection - traceVerbosity <- first Text.pack $ lastToEither "Default value not specified for TracingVerbosity" pTraceVerbosity - traceAcceptPolicy <- proxyLastToEither (Proxy @TraceAcceptPolicy) pTraceAcceptPolicy - traceBlockchainTime <- proxyLastToEither (Proxy @TraceBlockchainTime) pTraceBlockchainTime - traceBlockFetchClient <- proxyLastToEither (Proxy @TraceBlockFetchClient) pTraceBlockFetchClient - traceBlockFetchDecisions <- proxyLastToEither (Proxy @TraceBlockFetchDecisions) pTraceBlockFetchDecisions - traceBlockFetchProtocol <- proxyLastToEither (Proxy @TraceBlockFetchProtocol) pTraceBlockFetchProtocol - traceBlockFetchProtocolSerialised <- proxyLastToEither (Proxy @TraceBlockFetchProtocolSerialised) pTraceBlockFetchProtocolSerialised - traceBlockFetchServer <- proxyLastToEither (Proxy @TraceBlockFetchServer) pTraceBlockFetchServer - traceChainDB <- proxyLastToEither (Proxy @TraceChainDB) pTraceChainDB - traceChainSyncBlockServer <- proxyLastToEither (Proxy @TraceChainSyncBlockServer) pTraceChainSyncBlockServer - traceChainSyncClient <- proxyLastToEither (Proxy @TraceChainSyncClient) pTraceChainSyncClient - traceChainSyncHeaderServer <- proxyLastToEither (Proxy @TraceChainSyncHeaderServer) pTraceChainSyncHeaderServer - traceChainSyncProtocol <- proxyLastToEither (Proxy @TraceChainSyncProtocol) pTraceChainSyncProtocol - traceConnectionManager <- proxyLastToEither (Proxy @TraceConnectionManager) pTraceConnectionManager - traceConnectionManagerCounters <- proxyLastToEither (Proxy @TraceConnectionManagerCounters) pTraceConnectionManagerCounters - traceConnectionManagerTransitions <- proxyLastToEither (Proxy @TraceConnectionManagerTransitions) pTraceConnectionManagerTransitions - traceDebugPeerSelectionInitiatorTracer <- proxyLastToEither (Proxy @DebugPeerSelectionInitiator) pTraceDebugPeerSelectionInitiatorTracer - traceDebugPeerSelectionInitiatorResponderTracer <- proxyLastToEither (Proxy @DebugPeerSelectionInitiatorResponder) pTraceDebugPeerSelectionInitiatorResponderTracer - traceDiffusionInitialization <- proxyLastToEither (Proxy @TraceDiffusionInitialization) pTraceDiffusionInitialization - traceDnsResolver <- proxyLastToEither (Proxy @TraceDnsResolver) pTraceDnsResolver - traceDnsSubscription <- proxyLastToEither (Proxy @TraceDnsSubscription) pTraceDnsSubscription - traceErrorPolicy <- proxyLastToEither (Proxy @TraceErrorPolicy) pTraceErrorPolicy - traceForge <- proxyLastToEither (Proxy @TraceForge) pTraceForge - traceForgeStateInfo <- proxyLastToEither (Proxy @TraceForgeStateInfo) pTraceForgeStateInfo - traceGDD <- proxyLastToEither (Proxy @TraceGDD) pTraceGDD - traceHandshake <- proxyLastToEither (Proxy @TraceHandshake) pTraceHandshake - traceInboundGovernor <- proxyLastToEither (Proxy @TraceInboundGovernor) pTraceInboundGovernor - traceIpSubscription <- proxyLastToEither (Proxy @TraceIpSubscription) pTraceIpSubscription - traceInboundGovernorCounters <- proxyLastToEither (Proxy @TraceInboundGovernorCounters) pTraceInboundGovernorCounters - traceInboundGovernorTransitions <- proxyLastToEither (Proxy @TraceInboundGovernorTransitions) pTraceInboundGovernorTransitions - traceKeepAliveClient <- proxyLastToEither (Proxy @TraceKeepAliveClient) pTraceKeepAliveClient - traceLedgerPeers <- proxyLastToEither (Proxy @TraceLedgerPeers) pTraceLedgerPeers - traceLocalChainSyncProtocol <- proxyLastToEither (Proxy @TraceLocalChainSyncProtocol) pTraceLocalChainSyncProtocol - traceLocalConnectionManager <- proxyLastToEither (Proxy @TraceLocalConnectionManager) pTraceLocalConnectionManager - traceLocalErrorPolicy <- proxyLastToEither (Proxy @TraceLocalErrorPolicy) pTraceLocalErrorPolicy - traceLocalHandshake <- proxyLastToEither (Proxy @TraceLocalHandshake) pTraceLocalHandshake - traceLocalInboundGovernor <- proxyLastToEither (Proxy @TraceLocalInboundGovernor) pTraceLocalInboundGovernor - traceLocalMux <- proxyLastToEither (Proxy @TraceLocalMux) pTraceLocalMux - traceLocalMuxBearer <- proxyLastToEither (Proxy @TraceLocalMuxBearer) pTraceLocalMuxBearer - traceLocalMuxChannel <- proxyLastToEither (Proxy @TraceLocalMuxChannel) pTraceLocalMuxChannel - traceLocalRootPeers <- proxyLastToEither (Proxy @TraceLocalRootPeers) pTraceLocalRootPeers - traceLocalServer <- proxyLastToEither (Proxy @TraceLocalServer) pTraceLocalServer - traceLocalTxMonitorProtocol <- proxyLastToEither (Proxy @TraceLocalTxMonitorProtocol) pTraceLocalTxMonitorProtocol - traceLocalStateQueryProtocol <- proxyLastToEither (Proxy @TraceLocalStateQueryProtocol) pTraceLocalStateQueryProtocol - traceLocalTxSubmissionProtocol <- proxyLastToEither (Proxy @TraceLocalTxSubmissionProtocol) pTraceLocalTxSubmissionProtocol - traceLocalTxSubmissionServer <- proxyLastToEither (Proxy @TraceLocalTxSubmissionServer) pTraceLocalTxSubmissionServer - traceMempool <- proxyLastToEither (Proxy @TraceMempool) pTraceMempool - traceBackingStore <- proxyLastToEither (Proxy @TraceBackingStore) pTraceBackingStore - traceMux <- proxyLastToEither (Proxy @TraceMux) pTraceMux - traceMuxBearer <- proxyLastToEither (Proxy @TraceMuxBearer) pTraceMuxBearer - traceMuxChannel <- proxyLastToEither (Proxy @TraceMuxChannel) pTraceMuxChannel - tracePeerSelection <- proxyLastToEither (Proxy @TracePeerSelection) pTracePeerSelection - tracePeerSelectionCounters <- proxyLastToEither (Proxy @TracePeerSelectionCounters) pTracePeerSelectionCounters - tracePeerSelectionActions <- proxyLastToEither (Proxy @TracePeerSelectionActions) pTracePeerSelectionActions - tracePublicRootPeers <- proxyLastToEither (Proxy @TracePublicRootPeers) pTracePublicRootPeers - traceSanityCheckIssue <- proxyLastToEither (Proxy @TraceSanityCheckIssue) pTraceSanityCheckIssue - traceServer <- proxyLastToEither (Proxy @TraceServer) pTraceServer - traceTxInbound <- proxyLastToEither (Proxy @TraceTxInbound) pTraceTxInbound - traceTxOutbound <- proxyLastToEither (Proxy @TraceTxOutbound) pTraceTxOutbound - traceTxSubmissionProtocol <- proxyLastToEither (Proxy @TraceTxSubmissionProtocol) pTraceTxSubmissionProtocol - traceTxSubmission2Protocol <- proxyLastToEither (Proxy @TraceTxSubmission2Protocol) pTraceTxSubmission2Protocol - traceKeepAliveProtocol <- proxyLastToEither (Proxy @TraceKeepAliveProtocol) pTraceKeepAliveProtocol - tracePeerSharingProtocol <- proxyLastToEither (Proxy @TracePeerSharingProtocol) pTracePeerSharingProtocol - traceGsm <- proxyLastToEither (Proxy @TraceGsm) pTraceGsm - traceCsj <- proxyLastToEither (Proxy @TraceCsj) pTraceCsj - traceKesAgent <- proxyLastToEither (Proxy @TraceKesAgent) pTraceKesAgent - traceDevotedBlockFetch <- proxyLastToEither (Proxy @TraceDevotedBlockFetch) pTraceDevotedBlockFetch - traceChurnMode <- proxyLastToEither (Proxy @TraceChurnMode) pTraceChurnMode - traceDNS <- proxyLastToEither (Proxy @TraceDNS) pTraceDNS - traceTxLogic <- proxyLastToEither (Proxy @TraceTxLogic) pTraceTxLogic - traceTxCounters <- proxyLastToEither (Proxy @TraceTxCounters) pTraceTxCounters - Right $ TracingOnLegacy $ TraceSelection - { traceVerbosity = traceVerbosity - , traceAcceptPolicy = traceAcceptPolicy - , traceBlockFetchClient = traceBlockFetchClient - , traceBlockFetchDecisions = traceBlockFetchDecisions - , traceBlockFetchProtocol = traceBlockFetchProtocol - , traceBlockFetchProtocolSerialised = traceBlockFetchProtocolSerialised - , traceBlockFetchServer = traceBlockFetchServer - , traceBlockchainTime = traceBlockchainTime - , traceChainDB = traceChainDB - , traceChainSyncBlockServer = traceChainSyncBlockServer - , traceChainSyncClient = traceChainSyncClient - , traceChainSyncHeaderServer = traceChainSyncHeaderServer - , traceChainSyncProtocol = traceChainSyncProtocol - , traceConnectionManager = traceConnectionManager - , traceConnectionManagerCounters = traceConnectionManagerCounters - , traceConnectionManagerTransitions = traceConnectionManagerTransitions - , traceDebugPeerSelectionInitiatorTracer = traceDebugPeerSelectionInitiatorTracer - , traceDebugPeerSelectionInitiatorResponderTracer = traceDebugPeerSelectionInitiatorResponderTracer - , traceDiffusionInitialization = traceDiffusionInitialization - , traceDnsResolver = traceDnsResolver - , traceDnsSubscription = traceDnsSubscription - , traceErrorPolicy = traceErrorPolicy - , traceForge = traceForge - , traceForgeStateInfo = traceForgeStateInfo - , traceGDD = traceGDD - , traceHandshake = traceHandshake - , traceInboundGovernor = traceInboundGovernor - , traceInboundGovernorCounters = traceInboundGovernorCounters - , traceInboundGovernorTransitions = traceInboundGovernorTransitions - , traceIpSubscription = traceIpSubscription - , traceKeepAliveClient = traceKeepAliveClient - , traceLedgerPeers = traceLedgerPeers - , traceLocalChainSyncProtocol = traceLocalChainSyncProtocol - , traceLocalConnectionManager = traceLocalConnectionManager - , traceLocalErrorPolicy = traceLocalErrorPolicy - , traceLocalHandshake = traceLocalHandshake - , traceLocalInboundGovernor = traceLocalInboundGovernor - , traceLocalMux = traceLocalMux - , traceLocalMuxBearer = traceLocalMuxBearer - , traceLocalMuxChannel = traceLocalMuxChannel - , traceLocalRootPeers = traceLocalRootPeers - , traceLocalServer = traceLocalServer - , traceLocalStateQueryProtocol = traceLocalStateQueryProtocol - , traceLocalTxMonitorProtocol = traceLocalTxMonitorProtocol - , traceLocalTxSubmissionProtocol = traceLocalTxSubmissionProtocol - , traceLocalTxSubmissionServer = traceLocalTxSubmissionServer - , traceMempool = traceMempool - , traceBackingStore = traceBackingStore - , traceMux = traceMux - , traceMuxBearer = traceMuxBearer - , traceMuxChannel = traceMuxChannel - , tracePeerSelection = tracePeerSelection - , tracePeerSelectionCounters = tracePeerSelectionCounters - , tracePeerSelectionActions = tracePeerSelectionActions - , tracePublicRootPeers = tracePublicRootPeers - , traceSanityCheckIssue = traceSanityCheckIssue - , traceServer = traceServer - , traceTxInbound = traceTxInbound - , traceTxOutbound = traceTxOutbound - , traceTxSubmissionProtocol = traceTxSubmissionProtocol - , traceTxSubmission2Protocol = traceTxSubmission2Protocol - , traceKeepAliveProtocol = traceKeepAliveProtocol - , tracePeerSharingProtocol = tracePeerSharingProtocol - , traceGsm = traceGsm - , traceCsj = traceCsj - , traceDevotedBlockFetch = traceDevotedBlockFetch - , traceChurnMode - , traceDNS - , traceKesAgent = traceKesAgent - , traceTxLogic - , traceTxCounters - } - -proxyLastToEither :: KnownSymbol name => Proxy name -> Last (OnOff name) -> Either Text (OnOff name) -proxyLastToEither name (Last x) = - maybe (Left $ "Default value not specified for " <> proxyName name) Right x - -parseTracer :: KnownSymbol name => Proxy name -> Object -> Parser (Last (OnOff name)) -parseTracer p obj = Last <$> obj .:? Aeson.fromText (proxyName p) - -lastToEither :: String -> Last a -> Either String a -lastToEither errMsg (Last x) = maybe (Left errMsg) Right x diff --git a/cardano-node/src/Cardano/Tracing/Metrics.hs b/cardano-node/src/Cardano/Tracing/Metrics.hs deleted file mode 100644 index 7d860a79a38..00000000000 --- a/cardano-node/src/Cardano/Tracing/Metrics.hs +++ /dev/null @@ -1,122 +0,0 @@ - -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE DisambiguateRecordFields #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE UndecidableInstances #-} - -module Cardano.Tracing.Metrics - ( ForgingStats (..) - , ForgeThreadStats (..) - , mapForgingCurrentThreadStats - , mapForgingCurrentThreadStats_ - , mapForgingStatsTxsProcessed - , mapForgingStatsTxsSyncDuration - , mkForgingStats - , threadStatsProjection - ) where - -import Control.Concurrent (ThreadId, myThreadId) -import Control.Concurrent.STM -import Control.Monad (join) -import Data.Functor (void) -import Data.Int (Int64) -import Data.IORef (IORef, atomicModifyIORef', newIORef) -import Data.Map (Map) -import qualified Data.Map.Strict as Map - - --- | This structure stores counters of blockchain-related events, --- per individual forge thread. --- These counters are driven by traces. -data ForgingStats - = ForgingStats - { fsTxsProcessedNum :: !(IORef Int) - -- ^ Transactions removed from mempool. - , fsTxsSyncDuration :: !(IORef Int) - -- ^ Cumulative mempool sync duration in milliseconds. - , fsState :: !(TVar (Map ThreadId (TVar ForgeThreadStats))) - , fsBlocksUncoupled :: !(TVar Int64) - -- ^ Blocks forged since last restart not on the current chain - } - --- | 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 occurrences 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 - -- occurring since node start, for it is a sum total for all threads. - , ftsLastSlot :: !Int - } - -mkForgingStats :: IO ForgingStats -mkForgingStats = - ForgingStats - <$> newIORef 0 - <*> newIORef 0 - <*> newTVarIO mempty - <*> newTVarIO 0 - -mapForgingStatsTxsProcessed :: - ForgingStats - -> (Int -> Int) - -> IO Int -mapForgingStatsTxsProcessed fs f = - atomicModifyIORef' (fsTxsProcessedNum fs) $ - \txCount -> join (,) $ f txCount - -mapForgingStatsTxsSyncDuration :: - ForgingStats - -> (Int -> Int) - -> IO Int -mapForgingStatsTxsSyncDuration fs f = - atomicModifyIORef' (fsTxsSyncDuration fs) $ - \syncMs -> join (,) $ f syncMs - -mapForgingCurrentThreadStats :: - ForgingStats - -> (ForgeThreadStats -> (ForgeThreadStats, a)) - -> IO a -mapForgingCurrentThreadStats ForgingStats { fsState } f = do - tid <- myThreadId - allStats <- readTVarIO fsState - varStats <- case Map.lookup tid allStats of - Nothing -> do - varStats <- newTVarIO $ ForgeThreadStats 0 0 0 0 0 - atomically $ modifyTVar fsState $ Map.insert tid varStats - return varStats - Just varStats -> - return varStats - atomically $ do - stats <- readTVar varStats - let !(!stats', x) = f stats - writeTVar varStats stats' - return x - -mapForgingCurrentThreadStats_ :: - ForgingStats - -> (ForgeThreadStats -> ForgeThreadStats) - -> IO () -mapForgingCurrentThreadStats_ fs f = - void $ mapForgingCurrentThreadStats fs ((, ()) . f) - -threadStatsProjection :: - ForgingStats - -> (ForgeThreadStats -> a) - -> IO [a] -threadStatsProjection fs f = atomically $ do - allStats <- readTVar (fsState fs) - mapM (fmap f . readTVar) $ Map.elems allStats diff --git a/cardano-node/src/Cardano/Tracing/OrphanInstances/Byron.hs b/cardano-node/src/Cardano/Tracing/OrphanInstances/Byron.hs deleted file mode 100644 index b0c53901553..00000000000 --- a/cardano-node/src/Cardano/Tracing/OrphanInstances/Byron.hs +++ /dev/null @@ -1,229 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - -{-# OPTIONS_GHC -Wno-orphans #-} - -module Cardano.Tracing.OrphanInstances.Byron () where - -import Cardano.Api (textShow) - -import Ouroboros.Consensus.Protocol.PBFT (PBftTiebreakerView(..)) -import Ouroboros.Consensus.Block.EBB (fromIsEBB) -import Cardano.Chain.Block (ABlockOrBoundaryHdr (..), AHeader (..), - ChainValidationError (..), delegationCertificate) -import Cardano.Chain.Byron.API (ApplyMempoolPayloadErr (..)) -import Cardano.Chain.Delegation (delegateVK) -import Cardano.Crypto.Signing (VerificationKey) -import Cardano.Tracing.OrphanInstances.Common -import Cardano.Tracing.OrphanInstances.Consensus () -import Cardano.Tracing.Render (renderTxId) -import Ouroboros.Consensus.Block (Header) -import Ouroboros.Consensus.Byron.Ledger (ByronBlock (..), ByronNodeToClientVersion (..), - ByronNodeToNodeVersion (..), 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 Ouroboros.Network.Block (blockHash, blockNo, blockSlot) - -import Data.Aeson (Value (..)) -import Data.ByteString (ByteString) -import qualified Data.Set as Set -import qualified Data.Text as Text - -{- HLINT ignore "Use :" -} - --- --- | instances of @ToObject@ --- --- NOTE: this list is sorted by the unqualified name of the outermost type. - -instance ToObject ApplyMempoolPayloadErr where - toObject _verb (MempoolTxErr utxoValidationErr) = - mconcat - [ "kind" .= String "MempoolTxErr" - , "error" .= String (textShow utxoValidationErr) - ] - toObject _verb (MempoolDlgErr delegScheduleError) = - mconcat - [ "kind" .= String "MempoolDlgErr" - , "error" .= String (textShow delegScheduleError) - ] - toObject _verb (MempoolUpdateProposalErr iFaceErr) = - mconcat - [ "kind" .= String "MempoolUpdateProposalErr" - , "error" .= String (textShow iFaceErr) - ] - toObject _verb (MempoolUpdateVoteErr iFaceErrr) = - mconcat - [ "kind" .= String "MempoolUpdateVoteErr" - , "error" .= String (textShow iFaceErrr) - ] - -instance ToObject ByronLedgerUpdate where - toObject verb (ByronUpdatedProtocolUpdates protocolUpdates) = - mconcat - [ "kind" .= String "ByronUpdatedProtocolUpdates" - , "protocolUpdates" .= map (toObject verb) protocolUpdates - ] - -instance ToObject ProtocolUpdate where - toObject verb (ProtocolUpdate updateVersion updateState) = - mconcat - [ "kind" .= String "ProtocolUpdate" - , "protocolUpdateVersion" .= updateVersion - , "protocolUpdateState" .= toObject verb updateState - ] - -instance ToObject UpdateState where - toObject _verb updateState = case updateState of - UpdateRegistered slot -> - mconcat - [ "kind" .= String "UpdateRegistered" - , "slot" .= slot - ] - UpdateActive votes -> - mconcat - [ "kind" .= String "UpdateActive" - , "votes" .= map (Text.pack . show) (Set.toList votes) - ] - UpdateConfirmed slot -> - mconcat - [ "kind" .= String "UpdateConfirmed" - , "slot" .= slot - ] - UpdateStablyConfirmed endorsements -> - mconcat - [ "kind" .= String "UpdateStablyConfirmed" - , "endorsements" .= map (Text.pack . show) (Set.toList endorsements) - ] - UpdateCandidate slot epoch -> - mconcat - [ "kind" .= String "UpdateCandidate" - , "slot" .= slot - , "epoch" .= epoch - ] - UpdateStableCandidate transitionEpoch -> - mconcat - [ "kind" .= String "UpdateStableCandidate" - , "transitionEpoch" .= transitionEpoch - ] - -instance ToObject (GenTx ByronBlock) where - toObject _ tx = mconcat [ "txid" .= Text.take 8 (renderTxId (txId tx)) ] - - -instance ToJSON (TxId (GenTx ByronBlock)) where - toJSON = String . Text.take 8 . renderTxId - - -instance ToObject ChainValidationError where - toObject _verb ChainValidationBoundaryTooLarge = - mconcat - [ "kind" .= String "ChainValidationBoundaryTooLarge" ] - toObject _verb ChainValidationBlockAttributesTooLarge = - mconcat - [ "kind" .= String "ChainValidationBlockAttributesTooLarge" ] - toObject _verb (ChainValidationBlockTooLarge _ _) = - mconcat - [ "kind" .= String "ChainValidationBlockTooLarge" ] - toObject _verb ChainValidationHeaderAttributesTooLarge = - mconcat - [ "kind" .= String "ChainValidationHeaderAttributesTooLarge" ] - toObject _verb (ChainValidationHeaderTooLarge _ _) = - mconcat - [ "kind" .= String "ChainValidationHeaderTooLarge" ] - toObject _verb (ChainValidationDelegationPayloadError err) = - mconcat - [ "kind" .= String err ] - toObject _verb (ChainValidationInvalidDelegation _ _) = - mconcat - [ "kind" .= String "ChainValidationInvalidDelegation" ] - toObject _verb (ChainValidationGenesisHashMismatch _ _) = - mconcat - [ "kind" .= String "ChainValidationGenesisHashMismatch" ] - toObject _verb (ChainValidationExpectedGenesisHash _ _) = - mconcat - [ "kind" .= String "ChainValidationExpectedGenesisHash" ] - toObject _verb (ChainValidationExpectedHeaderHash _ _) = - mconcat - [ "kind" .= String "ChainValidationExpectedHeaderHash" ] - toObject _verb (ChainValidationInvalidHash _ _) = - mconcat - [ "kind" .= String "ChainValidationInvalidHash" ] - toObject _verb (ChainValidationMissingHash _) = - mconcat - [ "kind" .= String "ChainValidationMissingHash" ] - toObject _verb (ChainValidationUnexpectedGenesisHash _) = - mconcat - [ "kind" .= String "ChainValidationUnexpectedGenesisHash" ] - toObject _verb (ChainValidationInvalidSignature _) = - mconcat - [ "kind" .= String "ChainValidationInvalidSignature" ] - toObject _verb (ChainValidationDelegationSchedulingError _) = - mconcat - [ "kind" .= String "ChainValidationDelegationSchedulingError" ] - toObject _verb (ChainValidationProtocolMagicMismatch _ _) = - mconcat - [ "kind" .= String "ChainValidationProtocolMagicMismatch" ] - toObject _verb ChainValidationSignatureLight = - mconcat - [ "kind" .= String "ChainValidationSignatureLight" ] - toObject _verb (ChainValidationTooManyDelegations _) = - mconcat - [ "kind" .= String "ChainValidationTooManyDelegations" ] - toObject _verb (ChainValidationUpdateError _ _) = - mconcat - [ "kind" .= String "ChainValidationUpdateError" ] - toObject _verb (ChainValidationUTxOValidationError _) = - mconcat - [ "kind" .= String "ChainValidationUTxOValidationError" ] - toObject _verb (ChainValidationProofValidationError _) = - mconcat - [ "kind" .= String "ChainValidationProofValidationError" ] - - -instance ToObject (Header ByronBlock) where - toObject _verb b = - mconcat $ - [ "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 ToObject ByronOtherHeaderEnvelopeError where - toObject _verb (UnexpectedEBBInSlot slot) = - mconcat - [ "kind" .= String "UnexpectedEBBInSlot" - , "slot" .= slot - ] - -instance ToJSON ByronNodeToClientVersion where - toJSON ByronNodeToClientVersion1 = String "ByronNodeToClientVersion1" - -instance ToJSON ByronNodeToNodeVersion where - toJSON ByronNodeToNodeVersion1 = String "ByronNodeToNodeVersion1" - toJSON ByronNodeToNodeVersion2 = String "ByronNodeToNodeVersion2" - -instance ToObject PBftTiebreakerView where - toObject _verb (PBftTiebreakerView isEBB) = - mconcat - [ "kind" .= String "PBftTiebreakerView" - , "isEBB" .= fromIsEBB isEBB - ] diff --git a/cardano-node/src/Cardano/Tracing/OrphanInstances/Common.hs b/cardano-node/src/Cardano/Tracing/OrphanInstances/Common.hs deleted file mode 100644 index 23ee74df1fb..00000000000 --- a/cardano-node/src/Cardano/Tracing/OrphanInstances/Common.hs +++ /dev/null @@ -1,80 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE EmptyCase #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE UndecidableInstances #-} - -{-# OPTIONS_GHC -Wno-orphans #-} - -module Cardano.Tracing.OrphanInstances.Common - ( - -- * ToObject and helpers - ToObject(..) - , TracingVerbosity(..) - , mkObject - , emptyObject - , ToJSON - , toJSON - , (.=) - - -- * Transformable and helpers - , Transformable(..) - , trStructured - , trStructuredText - , HasTextFormatter(..) - - -- * Severity and Privacy - , HasSeverityAnnotation(..) - , Severity(..) - , HasPrivacyAnnotation(..) - , PrivacyAnnotation(..) - - -- * Tracer and related - , Tracer - , LogObject(..) - , LOContent(..) - , mkLOMeta - ) where - -import Cardano.BM.Data.LogItem (LOContent (..), LogObject (..), PrivacyAnnotation (..), - mkLOMeta) -import Cardano.BM.Data.Tracer (HasTextFormatter (..), emptyObject, mkObject, trStructured, - trStructuredText) -import Cardano.BM.Stats -import Cardano.BM.Tracing (HasPrivacyAnnotation (..), HasSeverityAnnotation (..), - Severity (..), ToObject (..), Tracer (..), TracingVerbosity (..), - Transformable (..)) -import Cardano.Node.Handlers.Shutdown () - -import Data.Aeson hiding (Value) -import Data.Scientific (coefficient) -import Data.Text (Text) -import Data.Void (Void) -import Network.Socket (PortNumber) -import Text.Read (readMaybe) --- | 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 ToObject Void where - toObject _verb x = case x of {} - -instance FromJSON PortNumber where - parseJSON (Number portNum) = case readMaybe . show $ coefficient portNum of - Just port -> pure port - Nothing -> fail $ show portNum <> " is not a valid port number." - parseJSON invalid = fail $ "Parsing of port number failed due to type mismatch. " - <> "Encountered: " <> show invalid - -instance HasPrivacyAnnotation ResourceStats -instance HasSeverityAnnotation ResourceStats where - getSeverityAnnotation _ = Info -instance Transformable Text IO ResourceStats where - trTransformer = trStructured - -instance ToObject ResourceStats where - toObject _verb stats = - case toJSON stats of - Object x -> x - _ -> mempty diff --git a/cardano-node/src/Cardano/Tracing/OrphanInstances/Consensus.hs b/cardano-node/src/Cardano/Tracing/OrphanInstances/Consensus.hs deleted file mode 100644 index a0342fffcb3..00000000000 --- a/cardano-node/src/Cardano/Tracing/OrphanInstances/Consensus.hs +++ /dev/null @@ -1,1967 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - -{-# OPTIONS_GHC -Wno-deprecations #-} -{-# OPTIONS_GHC -Wno-orphans #-} - -module Cardano.Tracing.OrphanInstances.Consensus () where - -import qualified Cardano.KESAgent.Processes.ServiceClient as Agent -import Cardano.Network.OrphanInstances () -import Cardano.Node.Tracing.Tracers.ConsensusStartupException - (ConsensusStartupException (..)) -import Cardano.Prelude (Typeable, maximumDef) -import Cardano.Slotting.Slot (fromWithOrigin) -import Cardano.Tracing.OrphanInstances.Common -import Cardano.Tracing.OrphanInstances.Network () -import Cardano.Tracing.Render (renderChainHash, renderChunkNo, renderHeaderHash, - renderHeaderHashForVerbosity, renderPointAsPhrase, renderPointForVerbosity, - renderRealPoint, renderRealPointAsPhrase, renderTipBlockNo, renderTipHash, - renderWithOrigin) -import Ouroboros.Consensus.Block (BlockProtocol, BlockSupportsProtocol, CannotForge, - ConvertRawHash (..), ForgeStateUpdateError, GenesisWindow (..), GetHeader (..), - Header, HeaderHash, RealPoint (..), blockNo, blockPoint, blockPrevHash, - getHeader, pointHash, realPointHash, realPointSlot, withOriginToMaybe) -import Ouroboros.Consensus.Block.SupportsSanityCheck -import Ouroboros.Consensus.Genesis.Governor (DensityBounds (..), GDDDebugInfo (..), - TraceGDDEvent (..)) -import Ouroboros.Consensus.HeaderValidation -import Ouroboros.Consensus.Ledger.Abstract -import Ouroboros.Consensus.Ledger.Extended -import Ouroboros.Consensus.Ledger.Inspect (InspectLedger, LedgerEvent (..), LedgerUpdate, - LedgerWarning) -import Ouroboros.Consensus.Ledger.SupportsMempool (ApplyTxErr, ByteSize32 (..), GenTx, - GenTxId, HasTxId, LedgerSupportsMempool, TxId, txForgetValidated, txId) -import Ouroboros.Consensus.Ledger.SupportsProtocol (LedgerSupportsProtocol) -import Ouroboros.Consensus.Mempool (MempoolSize (..), TraceEventMempool (..), - jsonMempoolRejectionDetails) -import Ouroboros.Consensus.MiniProtocol.BlockFetch.Server - (TraceBlockFetchServerEvent (..)) -import Ouroboros.Consensus.MiniProtocol.ChainSync.Client (TraceChainSyncClientEvent (..)) -import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client.Jumping as ChainSync.Client -import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client.State as ChainSync.Client -import Ouroboros.Consensus.MiniProtocol.ChainSync.Server (BlockingType (..), - TraceChainSyncServerEvent (..)) -import Ouroboros.Consensus.MiniProtocol.LocalTxSubmission.Server - (TraceLocalTxSubmissionServerEvent (..)) -import Ouroboros.Consensus.Node.GSM -import Ouroboros.Consensus.Node.Run (RunNode, estimateBlockSize) -import Ouroboros.Consensus.Node.Tracers (TraceForgeEvent (..)) -import qualified Ouroboros.Consensus.Node.Tracers as Consensus -import Ouroboros.Consensus.Peras.SelectView -import Ouroboros.Consensus.Protocol.Abstract -import qualified Ouroboros.Consensus.Protocol.BFT as BFT -import qualified Ouroboros.Consensus.Protocol.PBFT as PBFT -import Ouroboros.Consensus.Protocol.Praos.AgentClient -import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB -import qualified Ouroboros.Consensus.Storage.ImmutableDB.API as ImmDB -import Ouroboros.Consensus.Storage.ImmutableDB.Chunks.Internal (ChunkNo (..), - chunkNoToInt) -import qualified Ouroboros.Consensus.Storage.ImmutableDB.Impl.Types as ImmDB -import Ouroboros.Consensus.Storage.LedgerDB (PushGoal (..), PushStart (..), Pushing (..)) -import qualified Ouroboros.Consensus.Storage.LedgerDB as LedgerDB -import qualified Ouroboros.Consensus.Storage.LedgerDB.Snapshots as LedgerDB -import qualified Ouroboros.Consensus.Storage.VolatileDB.Impl as VolDb -import Ouroboros.Consensus.Util.Condense -import Ouroboros.Consensus.Util.Enclose -import Ouroboros.Consensus.Util.Orphans () -import qualified Ouroboros.Network.AnchoredFragment as AF -import Ouroboros.Network.Block (BlockNo (..), ChainUpdate (..), MaxSlotNo (..), - SlotNo (..), StandardHash, Tip (..), blockHash, pointSlot, tipFromHeader) -import Ouroboros.Network.BlockFetch.ClientState (TraceLabelPeer (..)) -import Ouroboros.Network.Point (withOrigin) -import Ouroboros.Network.SizeInBytes (SizeInBytes (..)) - -import Control.Exception -import Control.Monad (guard) -import Data.Aeson (Value (..)) -import qualified Data.Aeson as Aeson -import Data.Foldable (Foldable (..)) -import Data.Function (on) -import Data.Proxy -import Data.Text (Text, pack) -import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text -import Data.Word (Word32) -import GHC.Generics (Generic) -import Network.TypedProtocol.Core -import Numeric (showFFloat) - - -{- HLINT ignore "Use const" -} -{- HLINT ignore "Use record patterns" -} - -instance ToObject ConsensusStartupException where - toObject _ (ConsensusStartupException err) = - mconcat - [ "kind" .= String "ConsensusStartupException" - , "error" .= String (pack . show $ err) - ] - -instance HasPrivacyAnnotation ConsensusStartupException where -instance HasSeverityAnnotation ConsensusStartupException where - getSeverityAnnotation _ = Critical -instance Transformable Text IO ConsensusStartupException where - trTransformer = trStructured -instance HasTextFormatter ConsensusStartupException where - -instance HasPrivacyAnnotation SanityCheckIssue -instance HasSeverityAnnotation SanityCheckIssue where - getSeverityAnnotation _ = Error -instance Transformable Text IO SanityCheckIssue where - trTransformer = trStructured - -instance ToObject SanityCheckIssue where - toObject _verb issue = - mconcat - [ "kind" .= String "SanityCheckIssue" - , "issue" .= toJSON issue - ] -instance ToJSON SanityCheckIssue where - toJSON = Aeson.String . pack . show - -instance ConvertRawHash blk => ConvertRawHash (Header blk) where - toShortRawHash _ = toShortRawHash (Proxy @blk) - fromShortRawHash _ = fromShortRawHash (Proxy @blk) - hashSize :: proxy (Header blk) -> Word32 - hashSize _ = hashSize (Proxy @blk) - -instance ConvertRawHash blk => ConvertRawHash (HeaderWithTime blk) where - toShortRawHash _ = toShortRawHash (Proxy @blk) - fromShortRawHash _ = fromShortRawHash (Proxy @blk) - hashSize :: proxy (HeaderWithTime blk) -> Word32 - hashSize _ = hashSize (Proxy @blk) - --- --- * instances of @HasPrivacyAnnotation@ and @HasSeverityAnnotation@ --- --- NOTE: this list is sorted by the unqualified name of the outermost type. - -instance HasPrivacyAnnotation (ChainDB.TraceEvent blk) -instance HasSeverityAnnotation (ChainDB.TraceEvent blk) where - getSeverityAnnotation (ChainDB.TraceAddBlockEvent ev) = case ev of - ChainDB.IgnoreBlockOlderThanImmTip {} -> Info - ChainDB.IgnoreBlockAlreadyInVolatileDB {} -> Info - ChainDB.IgnoreInvalidBlock {} -> Info - ChainDB.AddedBlockToQueue {} -> Debug - ChainDB.PoppedBlockFromQueue {} -> Debug - ChainDB.PoppingFromQueue {} -> Debug - ChainDB.AddedBlockToVolatileDB {} -> Debug - ChainDB.TryAddToCurrentChain {} -> Debug - ChainDB.TrySwitchToAFork {} -> Info - ChainDB.StoreButDontChange {} -> Debug - ChainDB.ChangingSelection {} -> Debug - ChainDB.AddedToCurrentChain events _ _ _ _ -> - maximumDef Notice (map getSeverityAnnotation events) - ChainDB.SwitchedToAFork events _ _ _ _ -> - maximumDef Notice (map getSeverityAnnotation events) - ChainDB.AddBlockValidation ev' -> case ev' of - ChainDB.InvalidBlock {} -> Error - ChainDB.ValidCandidate {} -> Info - ChainDB.UpdateLedgerDbTraceEvent {} -> Debug - ChainDB.PipeliningEvent {} -> Debug - ChainDB.AddedReprocessLoEBlocksToQueue {} -> Debug - ChainDB.PoppedReprocessLoEBlocksFromQueue -> Debug - ChainDB.ChainSelectionLoEDebug _ _ -> Debug - - getSeverityAnnotation (ChainDB.TraceLedgerDBEvent ev) = case ev of - LedgerDB.LedgerDBSnapshotEvent ev' -> case ev' of - LedgerDB.TookSnapshot {} -> Info - LedgerDB.DeletedSnapshot {} -> Debug - LedgerDB.InvalidSnapshot _ invalidWhy -> case invalidWhy of - LedgerDB.InitFailureRead (LedgerDB.ReadMetadataError _ LedgerDB.MetadataBackendMismatch) -> Warning - LedgerDB.InitFailureRead (LedgerDB.ReadMetadataError _ LedgerDB.MetadataFileDoesNotExist) -> Warning - _ -> Error - LedgerDB.LedgerReplayEvent {} -> Info - LedgerDB.LedgerDBForkerEvent {} -> Debug - LedgerDB.LedgerDBFlavorImplEvent {} -> Debug - - getSeverityAnnotation (ChainDB.TraceCopyToImmutableDBEvent ev) = case ev of - ChainDB.CopiedBlockToImmutableDB {} -> Debug - ChainDB.NoBlocksToCopyToImmutableDB -> Debug - - getSeverityAnnotation (ChainDB.TraceGCEvent ev) = case ev of - ChainDB.PerformedGC {} -> Debug - ChainDB.ScheduledGC {} -> Debug - - getSeverityAnnotation (ChainDB.TraceOpenEvent ev) = case ev of - ChainDB.OpenedDB {} -> Info - ChainDB.ClosedDB {} -> Info - ChainDB.OpenedImmutableDB {} -> Info - ChainDB.OpenedVolatileDB {} -> Info - ChainDB.OpenedLgrDB -> Info - ChainDB.StartedOpeningDB -> Info - ChainDB.StartedOpeningImmutableDB -> Info - ChainDB.StartedOpeningVolatileDB -> Info - ChainDB.StartedOpeningLgrDB -> Info - - getSeverityAnnotation (ChainDB.TraceFollowerEvent ev) = case ev of - ChainDB.NewFollower {} -> Debug - ChainDB.FollowerNoLongerInMem {} -> Debug - ChainDB.FollowerSwitchToMem {} -> Debug - ChainDB.FollowerNewImmIterator {} -> Debug - getSeverityAnnotation (ChainDB.TraceInitChainSelEvent ev) = case ev of - ChainDB.StartedInitChainSelection{} -> Info - ChainDB.InitialChainSelected{} -> Info - ChainDB.InitChainSelValidation ev' -> case ev' of - ChainDB.InvalidBlock{} -> Debug - ChainDB.ValidCandidate {} -> Info - ChainDB.UpdateLedgerDbTraceEvent {} -> Info - - getSeverityAnnotation (ChainDB.TraceIteratorEvent ev) = case ev of - ChainDB.StreamFromVolatileDB {} -> Debug - _ -> Debug - getSeverityAnnotation (ChainDB.TraceImmutableDBEvent ev) = case ev of - ImmDB.NoValidLastLocation {} -> Info - ImmDB.ValidatedLastLocation {} -> Info - ImmDB.ChunkValidationEvent ev' -> case ev' of - ImmDB.StartedValidatingChunk{} -> Info - ImmDB.ValidatedChunk{} -> Info - ImmDB.MissingChunkFile{} -> Warning - ImmDB.InvalidChunkFile {} -> Warning - ImmDB.MissingPrimaryIndex{} -> Warning - ImmDB.MissingSecondaryIndex{} -> Warning - ImmDB.InvalidPrimaryIndex{} -> Warning - ImmDB.InvalidSecondaryIndex{} -> Warning - ImmDB.RewritePrimaryIndex{} -> Warning - ImmDB.RewriteSecondaryIndex{} -> Warning - ImmDB.ChunkFileDoesntFit{} -> Warning - ImmDB.Migrating{} -> Debug - ImmDB.DeletingAfter{} -> Debug - ImmDB.DBAlreadyClosed{} -> Error - ImmDB.DBClosed{} -> Info - ImmDB.TraceCacheEvent{} -> Debug - getSeverityAnnotation (ChainDB.TraceVolatileDBEvent ev) = case ev of - VolDb.DBAlreadyClosed{} -> Error - VolDb.BlockAlreadyHere{} -> Debug - VolDb.Truncate{} -> Error - VolDb.InvalidFileNames{} -> Warning - VolDb.DBClosed{} -> Info - getSeverityAnnotation ChainDB.TraceLastShutdownUnclean = Warning - - getSeverityAnnotation ChainDB.TraceChainSelStarvationEvent{} = Debug - - getSeverityAnnotation ChainDB.TracePerasCertDbEvent{} = Info - getSeverityAnnotation ChainDB.TraceAddPerasCertEvent{} = Info - -instance HasSeverityAnnotation (LedgerEvent blk) where - getSeverityAnnotation (LedgerUpdate _) = Notice - getSeverityAnnotation (LedgerWarning _) = Critical - -instance HasPrivacyAnnotation (TraceBlockFetchServerEvent blk) -instance HasSeverityAnnotation (TraceBlockFetchServerEvent blk) where - getSeverityAnnotation _ = Info - -instance (ToObject peer, ToObject (TraceChainSyncClientEvent blk)) - => Transformable Text IO (TraceLabelPeer peer (TraceChainSyncClientEvent blk)) where - trTransformer = trStructured -instance (BlockSupportsProtocol blk, Show peer, Show (Header blk)) - => HasTextFormatter (TraceLabelPeer peer (TraceChainSyncClientEvent blk)) where - formatText a _ = pack $ show a - -instance HasPrivacyAnnotation (TraceChainSyncClientEvent blk) -instance HasSeverityAnnotation (TraceChainSyncClientEvent blk) where - getSeverityAnnotation (TraceDownloadedHeader _) = Info - getSeverityAnnotation (TraceFoundIntersection _ _ _) = Info - getSeverityAnnotation (TraceRolledBack _) = Notice - getSeverityAnnotation (TraceException _) = Warning - getSeverityAnnotation (TraceTermination _) = Notice - getSeverityAnnotation (TraceValidatedHeader _) = Debug - getSeverityAnnotation (TraceWaitingBeyondForecastHorizon _) = Debug - getSeverityAnnotation (TraceAccessingForecastHorizon _) = Debug - getSeverityAnnotation (TraceGaveLoPToken _ _ _) = Debug - getSeverityAnnotation (TraceOfferJump _) = Debug - getSeverityAnnotation (TraceJumpResult _) = Debug - getSeverityAnnotation TraceJumpingWaitingForNextInstruction = Debug - getSeverityAnnotation (TraceJumpingInstructionIs _) = Debug - getSeverityAnnotation (TraceDrainingThePipe _) = Debug - - -instance HasPrivacyAnnotation (TraceChainSyncServerEvent blk) -instance HasSeverityAnnotation (TraceChainSyncServerEvent blk) where - getSeverityAnnotation _ = Info - - -instance HasPrivacyAnnotation (TraceEventMempool blk) -instance HasSeverityAnnotation (TraceEventMempool blk) where - getSeverityAnnotation TraceMempoolAddedTx{} = Info - getSeverityAnnotation TraceMempoolTipMovedBetweenSTMBlocks{} = Info - getSeverityAnnotation TraceMempoolRejectedTx{} = Info - getSeverityAnnotation TraceMempoolRemoveTxs{} = Debug - getSeverityAnnotation TraceMempoolManuallyRemovedTxs{} = Warning - getSeverityAnnotation TraceMempoolSyncNotNeeded{} = Debug - getSeverityAnnotation TraceMempoolSynced{} = Debug - getSeverityAnnotation TraceMempoolAttemptingAdd{} = Debug - -instance HasPrivacyAnnotation () -instance HasSeverityAnnotation () where - getSeverityAnnotation () = Info - -instance HasPrivacyAnnotation (TraceForgeEvent blk) -instance HasSeverityAnnotation (TraceForgeEvent blk) where - getSeverityAnnotation TraceStartLeadershipCheck {} = Info - getSeverityAnnotation TraceSlotIsImmutable {} = Error - getSeverityAnnotation TraceBlockFromFuture {} = Error - getSeverityAnnotation TraceBlockContext {} = Debug - getSeverityAnnotation TraceNoLedgerState {} = Error - getSeverityAnnotation TraceLedgerState {} = Debug - getSeverityAnnotation TraceNoLedgerView {} = Error - getSeverityAnnotation TraceLedgerView {} = Debug - getSeverityAnnotation TraceForgeStateUpdateError {} = Error - getSeverityAnnotation TraceNodeCannotForge {} = Error - getSeverityAnnotation TraceNodeNotLeader {} = Info - getSeverityAnnotation TraceNodeIsLeader {} = Info - getSeverityAnnotation TraceForgeTickedLedgerState {} = Debug - getSeverityAnnotation TraceForgingMempoolSnapshot {} = Debug - getSeverityAnnotation TraceForgedBlock {} = Info - getSeverityAnnotation TraceDidntAdoptBlock {} = Error - getSeverityAnnotation TraceForgedInvalidBlock {} = Error - getSeverityAnnotation TraceAdoptedBlock {} = Info - getSeverityAnnotation TraceAdoptionThreadDied {} = Error - - -instance HasPrivacyAnnotation (TraceLocalTxSubmissionServerEvent blk) -instance HasSeverityAnnotation (TraceLocalTxSubmissionServerEvent blk) where - getSeverityAnnotation _ = Info - - --- --- | instances of @Transformable@ --- --- NOTE: this list is sorted by the unqualified name of the outermost type. - -instance ( HasPrivacyAnnotation (ChainDB.TraceAddBlockEvent blk) - , HasSeverityAnnotation (ChainDB.TraceAddBlockEvent blk) - , LedgerSupportsProtocol blk - , ToObject (ChainDB.TraceAddBlockEvent blk)) - => Transformable Text IO (ChainDB.TraceAddBlockEvent blk) where - trTransformer = trStructuredText - - -instance (LedgerSupportsProtocol blk) - => HasTextFormatter (ChainDB.TraceAddBlockEvent blk) where - formatText _ = pack . show . toList - - -instance (ToObject peer, ConvertRawHash blk) - => Transformable Text IO (TraceLabelPeer peer (TraceBlockFetchServerEvent blk)) where - trTransformer = trStructuredText - - -instance HasTextFormatter (TraceLabelPeer peer (TraceBlockFetchServerEvent blk)) where - formatText _ = pack . show . toList - - -instance (ConvertRawHash blk, LedgerSupportsProtocol blk, ToJSON (HeaderHash blk)) - => Transformable Text IO (TraceChainSyncClientEvent blk) where - trTransformer = trStructured - - -instance ConvertRawHash blk - => Transformable Text IO (TraceChainSyncServerEvent blk) where - trTransformer = trStructured - -instance (ToObject peer, ToObject (TraceChainSyncServerEvent blk)) - => Transformable Text IO (TraceLabelPeer peer (TraceChainSyncServerEvent blk)) where - trTransformer = trStructured -instance (StandardHash blk, Show peer) - => HasTextFormatter (TraceLabelPeer peer (TraceChainSyncServerEvent blk)) where - formatText a _ = pack $ show a - - -instance ( ToObject (ApplyTxErr blk), ToObject (GenTx blk) - , ToJSON (GenTxId blk), LedgerSupportsMempool blk - , ConvertRawHash blk - , ToJSON (HeaderHash blk) - ) - => Transformable Text IO (TraceEventMempool blk) where - trTransformer = trStructured - -instance Condense t => Condense (Enclosing' t) where - condense RisingEdge = "RisingEdge" - condense (FallingEdgeWith a) = "FallingEdge: " <> condense a - -deriving instance Generic (Enclosing' t) -instance ToJSON t => ToJSON (Enclosing' t) - -condenseT :: Condense a => a -> Text -condenseT = pack . condense - -showT :: Show a => a -> Text -showT = pack . show - - -instance ( tx ~ GenTx blk - , HasTxId tx - , RunNode blk - , ToObject (LedgerError blk) - , ToObject (OtherHeaderEnvelopeError blk) - , ToObject (ValidationErr (BlockProtocol blk)) - , ToObject (CannotForge blk) - , ToObject (ForgeStateUpdateError blk) - , LedgerSupportsMempool blk) - => Transformable Text IO (TraceForgeEvent blk) where - trTransformer = trStructuredText - -instance ( tx ~ GenTx blk - , ConvertRawHash blk - , HasTxId tx - , LedgerSupportsMempool blk - , LedgerSupportsProtocol blk - , LedgerSupportsMempool blk - , Show (TxId tx) - , Show (ForgeStateUpdateError blk) - , Show (CannotForge blk) - , LedgerSupportsMempool blk) - => HasTextFormatter (TraceForgeEvent blk) where - formatText = \case - TraceStartLeadershipCheck slotNo -> const $ - "Checking for leadership in slot " <> showT (unSlotNo slotNo) - TraceSlotIsImmutable slotNo immutableTipPoint immutableTipBlkNo -> const $ - "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) - TraceBlockFromFuture currentSlot tipSlot -> const $ - "Couldn't forge block because current tip is in the future: " - <> "current tip slot: " <> showT (unSlotNo tipSlot) - <> ", current slot: " <> showT (unSlotNo currentSlot) - TraceBlockContext currentSlot tipBlockNo tipPoint -> const $ - "New block will fit onto: " - <> "tip: " <> renderPointAsPhrase tipPoint - <> ", tip block no: " <> showT (unBlockNo tipBlockNo) - <> ", current slot: " <> showT (unSlotNo currentSlot) - TraceNoLedgerState slotNo pt -> const $ - "Could not obtain ledger state for point " - <> renderPointAsPhrase pt - <> ", current slot: " - <> showT (unSlotNo slotNo) - TraceLedgerState slotNo pt -> const $ - "Obtained a ledger state for point " - <> renderPointAsPhrase pt - <> ", current slot: " - <> showT (unSlotNo slotNo) - TraceNoLedgerView slotNo _ -> const $ - "Could not obtain ledger view for slot " <> showT (unSlotNo slotNo) - TraceLedgerView slotNo -> const $ - "Obtained a ledger view for slot " <> showT (unSlotNo slotNo) - TraceForgeStateUpdateError slotNo reason -> const $ - "Updating the forge state in slot " - <> showT (unSlotNo slotNo) - <> " failed because: " - <> showT reason - TraceNodeCannotForge slotNo reason -> const $ - "We are the leader in slot " - <> showT (unSlotNo slotNo) - <> ", but we cannot forge because: " - <> showT reason - TraceNodeNotLeader slotNo -> const $ - "Not leading slot " <> showT (unSlotNo slotNo) - TraceNodeIsLeader slotNo -> const $ - "Leading slot " <> showT (unSlotNo slotNo) - TraceForgeTickedLedgerState slotNo prevPt -> const $ - "While forging in slot " - <> showT (unSlotNo slotNo) - <> " we ticked the ledger state ahead from " - <> renderPointAsPhrase prevPt - TraceForgingMempoolSnapshot slotNo prevPt mpHash mpSlot -> const $ - "While forging in slot " - <> showT (unSlotNo slotNo) - <> " we acquired a mempool snapshot valid against " - <> renderPointAsPhrase prevPt - <> " from a mempool that was prepared for " - <> renderChainHash (Text.decodeLatin1 . toRawHash (Proxy @blk)) mpHash - <> " ticked to slot " - <> showT (unSlotNo mpSlot) - TraceForgedBlock slotNo _ _ _ _ -> const $ - "Forged block in slot " <> showT (unSlotNo slotNo) - TraceDidntAdoptBlock slotNo _ -> const $ - "Didn't adopt forged block in slot " <> showT (unSlotNo slotNo) - TraceForgedInvalidBlock slotNo _ reason -> const $ - "Forged invalid block in slot " - <> showT (unSlotNo slotNo) - <> ", reason: " <> showT reason - TraceAdoptedBlock slotNo blk txs -> const $ - "Adopted block forged in slot " - <> showT (unSlotNo slotNo) - <> ": " <> renderHeaderHash (Proxy @blk) (blockHash blk) - <> ", TxIds: " <> showT (map (txId . txForgetValidated) txs) - TraceAdoptionThreadDied slotNo blk -> const $ - "Adoption Thread died in slot " - <> showT (unSlotNo slotNo) - <> ": " <> renderHeaderHash (Proxy @blk) (blockHash blk) - - -instance Transformable Text IO (TraceLocalTxSubmissionServerEvent blk) where - trTransformer = trStructured - -instance HasPrivacyAnnotation a => HasPrivacyAnnotation (Consensus.TraceLabelCreds a) -instance HasSeverityAnnotation a => HasSeverityAnnotation (Consensus.TraceLabelCreds a) where - getSeverityAnnotation (Consensus.TraceLabelCreds _ a) = getSeverityAnnotation a - -instance ToObject a => ToObject (Consensus.TraceLabelCreds a) where - toObject verb (Consensus.TraceLabelCreds creds val) = - mconcat [ "credentials" .= toJSON creds - , "val" .= toObject verb val - ] - -instance (HasPrivacyAnnotation a, HasSeverityAnnotation a, ToObject a) - => Transformable Text IO (Consensus.TraceLabelCreds a) where - trTransformer = trStructured - -instance ( ConvertRawHash blk - , LedgerSupportsProtocol blk - , InspectLedger blk - , ToObject (Header blk) - , ToObject (LedgerEvent blk) - , ToObject (WeightedSelectView (BlockProtocol blk)) - , ToJSON (HeaderHash blk) - ) - => Transformable Text IO (ChainDB.TraceEvent blk) where - trTransformer = trStructuredText - -instance ( ConvertRawHash blk - , LedgerSupportsProtocol blk - , InspectLedger blk) - => HasTextFormatter (ChainDB.TraceEvent blk) where - formatText tev _obj = case tev of - ChainDB.TraceLastShutdownUnclean -> "ChainDB is not clean. Validating all immutable chunks" - ChainDB.TraceAddBlockEvent ev -> case ev of - ChainDB.IgnoreBlockOlderThanImmTip pt -> - "Ignoring block older than ImmTip: " <> renderRealPointAsPhrase pt - ChainDB.IgnoreBlockAlreadyInVolatileDB pt -> - "Ignoring block already in DB: " <> renderRealPointAsPhrase pt - ChainDB.IgnoreInvalidBlock pt _reason -> - "Ignoring previously seen invalid block: " <> renderRealPointAsPhrase pt - ChainDB.AddedBlockToQueue pt edgeSz -> - case edgeSz of - RisingEdge -> - "About to add block to queue: " <> renderRealPointAsPhrase pt - FallingEdgeWith sz -> - "Block added to queue: " <> renderRealPointAsPhrase pt <> " queue size " <> condenseT sz - ChainDB.AddedReprocessLoEBlocksToQueue {} -> - "Added request to queue to reprocess blocks postponed by LoE." - ChainDB.PoppedReprocessLoEBlocksFromQueue -> - "Poppped request from queue to reprocess blocks postponed by LoE." - ChainDB.ChainSelectionLoEDebug {} -> - "ChainDB LoE debug event" - ChainDB.PoppingFromQueue -> - "Popping block from queue" - ChainDB.PoppedBlockFromQueue pt -> - "Popped block from queue: " <> renderRealPointAsPhrase pt - ChainDB.StoreButDontChange pt -> - "Ignoring block: " <> renderRealPointAsPhrase pt - ChainDB.TryAddToCurrentChain pt -> - "Block fits onto the current chain: " <> renderRealPointAsPhrase pt - ChainDB.TrySwitchToAFork pt _ -> - "Block fits onto some fork: " <> renderRealPointAsPhrase pt - ChainDB.ChangingSelection pt -> - "Changing selection to: " <> renderPointAsPhrase pt - ChainDB.AddedToCurrentChain es _ _ c _ -> - "Chain extended, new tip: " <> renderPointAsPhrase (AF.headPoint c) <> - Text.concat [ "\nEvent: " <> showT e | e <- es ] - ChainDB.SwitchedToAFork es _ _ c _ -> - "Switched to a fork, new tip: " <> renderPointAsPhrase (AF.headPoint c) <> - Text.concat [ "\nEvent: " <> showT e | e <- es ] - ChainDB.AddBlockValidation ev' -> case ev' of - ChainDB.InvalidBlock err pt -> - "Invalid block " <> renderRealPointAsPhrase pt <> ": " <> showT err - ChainDB.ValidCandidate c -> - "Valid candidate spanning from " <> renderPointAsPhrase (AF.lastPoint c) <> " to " <> renderPointAsPhrase (AF.headPoint c) - ChainDB.UpdateLedgerDbTraceEvent (LedgerDB.StartedPushingBlockToTheLedgerDb (PushStart start) (PushGoal goal) (Pushing curr)) -> - let fromSlot = unSlotNo $ realPointSlot start - atSlot = unSlotNo $ realPointSlot curr - atDiff = atSlot - fromSlot - toSlot = unSlotNo $ realPointSlot goal - toDiff = toSlot - fromSlot - in - "Pushing ledger state for block " <> renderRealPointAsPhrase curr <> ". Progress: " <> - showProgressT (fromIntegral atDiff) (fromIntegral toDiff) <> "%" - ChainDB.AddedBlockToVolatileDB pt _ _ enclosing -> case enclosing of - RisingEdge -> "Chain about to add block " <> renderRealPointAsPhrase pt - FallingEdge -> "Chain added block " <> renderRealPointAsPhrase pt - ChainDB.PipeliningEvent ev' -> case ev' of - ChainDB.SetTentativeHeader hdr enclosing -> case enclosing of - RisingEdge -> "About to set tentative header to " <> renderPointAsPhrase (blockPoint hdr) - FallingEdge -> "Set tentative header to " <> renderPointAsPhrase (blockPoint hdr) - ChainDB.TrapTentativeHeader hdr -> "Discovered trap tentative header " <> renderPointAsPhrase (blockPoint hdr) - ChainDB.OutdatedTentativeHeader hdr -> "Tentative header is now outdated" <> renderPointAsPhrase (blockPoint hdr) - - ChainDB.TraceLedgerDBEvent ev -> case ev of - LedgerDB.LedgerDBSnapshotEvent ev' -> case ev' of - LedgerDB.InvalidSnapshot snap failure -> - "Invalid snapshot " <> showT snap <> showT failure <> context - where - context = case failure of - LedgerDB.InitFailureRead LedgerDB.ReadSnapshotFailed{} -> - " This is most likely an expected change in the serialization format," - <> " which currently requires a chain replay" - LedgerDB.InitFailureRead LedgerDB.ReadSnapshotDataCorruption -> - " The snapshot fails the CRC check. It seems there has been disk corruption" - LedgerDB.InitFailureRead (LedgerDB.ReadMetadataError _ err) -> case err of - LedgerDB.MetadataFileDoesNotExist -> - " The snapshot doesn't have the required metadata file." - LedgerDB.MetadataInvalid errMsg -> - " Snapshot metadata file failed to deserialize: " <> showT errMsg - LedgerDB.MetadataBackendMismatch -> - " Snapshot was created for a different backend. Convert it with `snapshot-converter`." - _ -> "" - LedgerDB.TookSnapshot snap pt RisingEdge -> - "Taking ledger snapshot " <> showT snap <> - " at " <> renderRealPointAsPhrase pt - LedgerDB.TookSnapshot snap pt (FallingEdgeWith t) -> - "Took ledger snapshot " <> showT snap <> - " at " <> renderRealPointAsPhrase pt <> - ", duration: " <> showT t - LedgerDB.DeletedSnapshot snap -> - "Deleted old snapshot " <> showT snap - LedgerDB.LedgerReplayEvent ev' -> case ev' of - LedgerDB.TraceReplayStartEvent ev'' -> case ev'' of - LedgerDB.ReplayFromGenesis -> - "Replaying ledger from genesis" - LedgerDB.ReplayFromSnapshot _ (LedgerDB.ReplayStart tip') -> - "Replaying ledger from snapshot at " <> - renderPointAsPhrase tip' - LedgerDB.TraceReplayProgressEvent - (LedgerDB.ReplayedBlock pt _ledgerEvents (LedgerDB.ReplayStart replayFrom) (LedgerDB.ReplayGoal replayTo)) -> - let fromSlot = withOrigin 0 Prelude.id $ unSlotNo <$> pointSlot replayFrom - atSlot = unSlotNo $ realPointSlot pt - atDiff = atSlot - fromSlot - toSlot = withOrigin 0 Prelude.id $ unSlotNo <$> pointSlot replayTo - toDiff = toSlot - fromSlot - in - "Replayed block: slot " - <> showT atSlot - <> " out of " - <> showT toSlot - <> ". Progress: " - <> showProgressT (fromIntegral atDiff) (fromIntegral toDiff) - <> "%" - LedgerDB.LedgerDBForkerEvent ev' -> showT ev' - LedgerDB.LedgerDBFlavorImplEvent ev' -> showT ev' - - ChainDB.TraceCopyToImmutableDBEvent ev -> case ev of - ChainDB.CopiedBlockToImmutableDB pt -> - "Copied block " <> renderPointAsPhrase pt <> " to the ImmutableDB" - ChainDB.NoBlocksToCopyToImmutableDB -> - "There are no blocks to copy to the ImmutableDB" - ChainDB.TraceGCEvent ev -> case ev of - ChainDB.PerformedGC slot -> - "Performed a garbage collection for " <> condenseT slot - ChainDB.ScheduledGC slot _difft -> - "Scheduled a garbage collection for " <> condenseT slot - ChainDB.TraceOpenEvent ev -> case ev of - ChainDB.StartedOpeningDB -> "Started opening Chain DB" - ChainDB.StartedOpeningImmutableDB -> "Started opening Immutable DB" - ChainDB.StartedOpeningVolatileDB -> "Started opening Volatile DB" - ChainDB.StartedOpeningLgrDB -> "Started opening Ledger DB" - ChainDB.OpenedDB immTip tip' -> - "Opened db with immutable tip at " <> renderPointAsPhrase immTip <> - " and tip " <> renderPointAsPhrase tip' - ChainDB.ClosedDB immTip tip' -> - "Closed db with immutable tip at " <> renderPointAsPhrase immTip <> - " and tip " <> renderPointAsPhrase tip' - ChainDB.OpenedImmutableDB immTip chunk -> - "Opened imm db with immutable tip at " <> renderPointAsPhrase immTip <> - " and chunk " <> showT chunk - ChainDB.OpenedVolatileDB mx -> "Opened " <> case mx of - NoMaxSlotNo -> "empty Volatile DB" - MaxSlotNo mxx -> "Volatile DB with max slot seen " <> showT mxx - ChainDB.OpenedLgrDB -> "Opened lgr db" - ChainDB.TraceFollowerEvent ev -> case ev of - ChainDB.NewFollower -> "New follower was created" - ChainDB.FollowerNoLongerInMem _ -> "FollowerNoLongerInMem" - ChainDB.FollowerSwitchToMem _ _ -> "FollowerSwitchToMem" - ChainDB.FollowerNewImmIterator _ _ -> "FollowerNewImmIterator" - ChainDB.TraceInitChainSelEvent ev -> case ev of - ChainDB.StartedInitChainSelection -> "Started initial chain selection" - ChainDB.InitialChainSelected -> "Initial chain selected" - ChainDB.InitChainSelValidation e -> case e of - ChainDB.InvalidBlock _err _pt -> "Invalid block found during Initial chain selection, truncating the candidate and retrying to select a best candidate." - ChainDB.ValidCandidate af -> "Valid candidate spanning from " <> renderPointAsPhrase (AF.lastPoint af) <> " to " <> renderPointAsPhrase (AF.headPoint af) - ChainDB.UpdateLedgerDbTraceEvent (LedgerDB.StartedPushingBlockToTheLedgerDb (PushStart start) (PushGoal goal) (Pushing curr)) -> - let fromSlot = unSlotNo $ realPointSlot start - atSlot = unSlotNo $ realPointSlot curr - atDiff = atSlot - fromSlot - toSlot = unSlotNo $ realPointSlot goal - toDiff = toSlot - fromSlot - in - "Pushing ledger state for block " <> renderRealPointAsPhrase curr <> ". Progress: " <> - showProgressT (fromIntegral atDiff) (fromIntegral toDiff) <> "%" - ChainDB.TraceIteratorEvent ev -> case ev of - ChainDB.UnknownRangeRequested ev' -> - case ev' of - ChainDB.MissingBlock realPt -> - "The block at the given point was not found in the ChainDB." - <> renderRealPoint realPt - ChainDB.ForkTooOld streamFrom -> - "The requested range forks off too far in the past" - <> showT streamFrom - ChainDB.BlockMissingFromVolatileDB realPt -> mconcat - [ "This block is no longer in the VolatileDB because it has been garbage" - , " collected. It might now be in the ImmutableDB if it was part of the" - , " current chain. Block: " - , renderRealPoint realPt - ] - ChainDB.StreamFromImmutableDB sFrom sTo -> mconcat - [ "Stream only from the ImmutableDB. StreamFrom:" - , showT sFrom - , " StreamTo: " - , showT sTo - ] - ChainDB.StreamFromBoth sFrom sTo pts -> mconcat - [ "Stream from both the VolatileDB and the ImmutableDB." - , " StreamFrom: " <> showT sFrom <> " StreamTo: " <> showT sTo - , " Points: " <> showT (map renderRealPoint pts) - ] - ChainDB.StreamFromVolatileDB sFrom sTo pts -> mconcat - [ "Stream only from the VolatileDB." - , " StreamFrom: " <> showT sFrom <> " StreamTo: " <> showT sTo - , " Points: " <> showT (map renderRealPoint pts) - ] - ChainDB.BlockWasCopiedToImmutableDB pt -> mconcat - [ "This block has been garbage collected from the VolatileDB is now" - , " found and streamed from the ImmutableDB. Block: " <> renderRealPoint pt - ] - ChainDB.BlockGCedFromVolatileDB pt -> mconcat - [ "This block no longer in the VolatileDB and isn't in the ImmutableDB" - , " either; it wasn't part of the current chain. Block: " <> renderRealPoint pt - ] - ChainDB.SwitchBackToVolatileDB -> "SwitchBackToVolatileDB" - ChainDB.TraceImmutableDBEvent ev -> case ev of - ImmDB.NoValidLastLocation -> - "No valid last location was found. Starting from Genesis." - ImmDB.ValidatedLastLocation cn t -> - "Found a valid last location at chunk " - <> showT cn - <> " with tip " - <> renderRealPoint (ImmDB.tipToRealPoint t) - <> "." - ImmDB.ChunkValidationEvent e -> case e of - ImmDB.StartedValidatingChunk chunkNo outOf -> - "Validating chunk no. " <> showT chunkNo <> " out of " <> showT outOf - <> ". Progress: " <> showProgressT (chunkNoToInt chunkNo) (chunkNoToInt outOf + 1) <> "%" - ImmDB.ValidatedChunk chunkNo outOf -> - "Validated chunk no. " <> showT chunkNo <> " out of " <> showT outOf - <> ". Progress: " <> showProgressT (chunkNoToInt chunkNo + 1) (chunkNoToInt outOf + 1) <> "%" - ImmDB.MissingChunkFile cn -> - "The chunk file with number " <> showT cn <> " is missing." - ImmDB.InvalidChunkFile cn er -> - "The chunk file with number " <> showT cn <> " is invalid: " <> showT er - ImmDB.MissingPrimaryIndex cn -> - "The primary index of the chunk file with number " <> showT cn <> " is missing." - ImmDB.MissingSecondaryIndex cn -> - "The secondary index of the chunk file with number " <> showT cn <> " is missing." - ImmDB.InvalidPrimaryIndex cn -> - "The primary index of the chunk file with number " <> showT cn <> " is invalid." - ImmDB.InvalidSecondaryIndex cn -> - "The secondary index of the chunk file with number " <> showT cn <> " is invalid." - ImmDB.RewritePrimaryIndex cn -> - "Rewriting the primary index for the chunk file with number " <> showT cn <> "." - ImmDB.RewriteSecondaryIndex cn -> - "Rewriting the secondary index for the chunk file with number " <> showT cn <> "." - ImmDB.ChunkFileDoesntFit ch1 ch2 -> - "Chunk file doesn't fit. The hash of the block " <> showT ch2 <> " doesn't match the previous hash of the first block in the current epoch: " <> showT ch1 <> "." - ImmDB.Migrating t -> "Migrating: " <> t - ImmDB.DeletingAfter wot -> "Deleting chunk files after " <> showT wot - ImmDB.DBAlreadyClosed {} -> "Immutable DB was already closed. Double closing." - ImmDB.DBClosed {} -> "Closed Immutable DB." - ImmDB.TraceCacheEvent ev' -> "Cache event: " <> case ev' of - ImmDB.TraceCurrentChunkHit cn curr -> "Current chunk hit: " <> showT cn <> ", cache size: " <> showT curr - ImmDB.TracePastChunkHit cn curr -> "Past chunk hit: " <> showT cn <> ", cache size: " <> showT curr - ImmDB.TracePastChunkMiss cn curr -> "Past chunk miss: " <> showT cn <> ", cache size: " <> showT curr - ImmDB.TracePastChunkEvict cn curr -> "Past chunk evict: " <> showT cn <> ", cache size: " <> showT curr - ImmDB.TracePastChunksExpired cns curr -> "Past chunks expired: " <> showT cns <> ", cache size: " <> showT curr - ChainDB.TraceVolatileDBEvent ev -> case ev of - VolDb.DBAlreadyClosed -> "Volatile DB was already closed. Double closing." - VolDb.BlockAlreadyHere bh -> "Block " <> showT bh <> " was already in the Volatile DB." - VolDb.Truncate e pth offs -> "Truncating the file at " <> showT pth <> " at offset " <> showT offs <> ": " <> showT e - VolDb.InvalidFileNames fs -> "Invalid Volatile DB files: " <> showT fs - VolDb.DBClosed -> "Closed Volatile DB." - ChainDB.TraceChainSelStarvationEvent ev -> case ev of - ChainDB.ChainSelStarvation RisingEdge -> "Chain Selection was starved." - ChainDB.ChainSelStarvation (FallingEdgeWith pt) -> "Chain Selection was unstarved by " <> renderRealPoint pt - ChainDB.TracePerasCertDbEvent ev -> showT ev - ChainDB.TraceAddPerasCertEvent ev -> showT ev - where showProgressT :: Int -> Int -> Text - showProgressT chunkNo outOf = - pack (showFFloat (Just 2) (100 * fromIntegral chunkNo / fromIntegral outOf :: Float) mempty) - - - --- --- | instances of @ToObject@ --- --- NOTE: this list is sorted by the unqualified name of the outermost type. - -instance ToObject BFT.BftValidationErr where - toObject _verb (BFT.BftInvalidSignature err) = - mconcat - [ "kind" .= String "BftInvalidSignature" - , "error" .= String (pack err) - ] - - -instance ToObject LedgerDB.DiskSnapshot where - toObject MinimalVerbosity snap = toObject NormalVerbosity snap - toObject NormalVerbosity _ = mconcat [ "kind" .= String "snapshot" ] - toObject MaximalVerbosity snap = - mconcat [ "kind" .= String "snapshot" - , "snapshot" .= String (pack $ show snap) ] - - -instance ( StandardHash blk - , ToObject (LedgerError blk) - , ToObject (OtherHeaderEnvelopeError blk) - , ToObject (ValidationErr (BlockProtocol blk))) - => ToObject (ExtValidationError blk) where - toObject verb (ExtValidationErrorLedger err) = toObject verb err - toObject verb (ExtValidationErrorHeader err) = toObject verb err - - -instance ( StandardHash blk - , ToObject (OtherHeaderEnvelopeError blk) - ) - => ToObject (HeaderEnvelopeError blk) where - toObject _verb (UnexpectedBlockNo expect act) = - mconcat - [ "kind" .= String "UnexpectedBlockNo" - , "expected" .= condense expect - , "actual" .= condense act - ] - toObject _verb (UnexpectedSlotNo expect act) = - mconcat - [ "kind" .= String "UnexpectedSlotNo" - , "expected" .= condense expect - , "actual" .= condense act - ] - toObject _verb (UnexpectedPrevHash expect act) = - mconcat - [ "kind" .= String "UnexpectedPrevHash" - , "expected" .= String (pack $ show expect) - , "actual" .= String (pack $ show act) - ] - toObject _verb (CheckpointMismatch blockNumber hdrHashExpected hdrHashActual) = - mconcat - [ "kind" .= String "CheckpointMismatch" - , "blockNo" .= String (pack $ show blockNumber) - , "expected" .= String (pack $ show hdrHashExpected) - , "actual" .= String (pack $ show hdrHashActual) - ] - toObject verb (OtherHeaderEnvelopeError err) = - toObject verb err - - -instance ( StandardHash blk - , ToObject (ValidationErr (BlockProtocol blk)) - , ToObject (OtherHeaderEnvelopeError blk) - ) - => ToObject (HeaderError blk) where - toObject verb (HeaderProtocolError err) = - mconcat - [ "kind" .= String "HeaderProtocolError" - , "error" .= toObject verb err - ] - toObject verb (HeaderEnvelopeError err) = - mconcat - [ "kind" .= String "HeaderEnvelopeError" - , "error" .= toObject verb err - ] - - -instance (Show (PBFT.PBftVerKeyHash c)) - => ToObject (PBFT.PBftValidationErr c) where - toObject _verb (PBFT.PBftInvalidSignature text) = - mconcat - [ "kind" .= String "PBftInvalidSignature" - , "error" .= String text - ] - toObject _verb (PBFT.PBftNotGenesisDelegate vkhash _ledgerView) = - mconcat - [ "kind" .= String "PBftNotGenesisDelegate" - , "vk" .= String (pack $ show vkhash) - ] - toObject _verb (PBFT.PBftExceededSignThreshold vkhash numForged) = - mconcat - [ "kind" .= String "PBftExceededSignThreshold" - , "vk" .= String (pack $ show vkhash) - , "numForged" .= String (pack (show numForged)) - ] - toObject _verb PBFT.PBftInvalidSlot = - mconcat - [ "kind" .= String "PBftInvalidSlot" - ] - - -instance (Show (PBFT.PBftVerKeyHash c)) - => ToObject (PBFT.PBftCannotForge c) where - toObject _verb (PBFT.PBftCannotForgeInvalidDelegation vkhash) = - mconcat - [ "kind" .= String "PBftCannotForgeInvalidDelegation" - , "vk" .= String (pack $ show vkhash) - ] - toObject _verb (PBFT.PBftCannotForgeThresholdExceeded numForged) = - mconcat - [ "kind" .= String "PBftCannotForgeThresholdExceeded" - , "numForged" .= numForged - ] - - -instance ConvertRawHash blk - => ToObject (RealPoint blk) where - toObject verb p = mconcat - [ "kind" .= String "Point" - , "slot" .= unSlotNo (realPointSlot p) - , "hash" .= renderHeaderHashForVerbosity (Proxy @blk) verb (realPointHash p) ] - - -instance (ToObject (LedgerUpdate blk), ToObject (LedgerWarning blk)) - => ToObject (LedgerEvent blk) where - toObject verb = \case - LedgerUpdate update -> toObject verb update - LedgerWarning warning -> toObject verb warning - - -instance ( ConvertRawHash blk - , LedgerSupportsProtocol blk - , ToJSON (HeaderHash blk) - , ToObject (Header blk) - , ToObject (LedgerEvent blk) - , ToObject (WeightedSelectView (BlockProtocol blk))) - => ToObject (ChainDB.TraceEvent blk) where - toObject _verb ChainDB.TraceLastShutdownUnclean = - mconcat [ "kind" .= String "TraceLastShutdownUnclean" ] - toObject verb (ChainDB.TraceAddBlockEvent ev) = case ev of - ChainDB.IgnoreBlockOlderThanImmTip pt -> - mconcat [ "kind" .= String "TraceAddBlockEvent.IgnoreBlockOlderThanImmTip" - , "block" .= toObject verb pt ] - ChainDB.IgnoreBlockAlreadyInVolatileDB pt -> - mconcat [ "kind" .= String "TraceAddBlockEvent.IgnoreBlockAlreadyInVolatileDB" - , "block" .= toObject verb pt ] - ChainDB.IgnoreInvalidBlock pt reason -> - mconcat [ "kind" .= String "TraceAddBlockEvent.IgnoreInvalidBlock" - , "block" .= toObject verb pt - , "reason" .= show reason ] - ChainDB.AddedBlockToQueue pt edgeSz -> - mconcat [ "kind" .= String "TraceAddBlockEvent.AddedBlockToQueue" - , "block" .= toObject verb pt - , case edgeSz of - RisingEdge -> "risingEdge" .= True - FallingEdgeWith sz -> "queueSize" .= toJSON sz ] - ChainDB.PoppingFromQueue -> - mconcat [ "kind" .= String "TraceAddBlockEvent.PoppingFromQueue" - ] - ChainDB.PoppedBlockFromQueue pt -> - mconcat [ "kind" .= String "TraceAddBlockEvent.PoppedBlockFromQueue" - , "block" .= toObject verb pt - ] - ChainDB.StoreButDontChange pt -> - mconcat [ "kind" .= String "TraceAddBlockEvent.StoreButDontChange" - , "block" .= toObject verb pt ] - ChainDB.TryAddToCurrentChain pt -> - mconcat [ "kind" .= String "TraceAddBlockEvent.TryAddToCurrentChain" - , "block" .= toObject verb pt ] - ChainDB.TrySwitchToAFork pt _ -> - mconcat [ "kind" .= String "TraceAddBlockEvent.TrySwitchToAFork" - , "block" .= toObject verb pt ] - ChainDB.ChangingSelection pt -> - mconcat [ "kind" .= String "TraceAddBlockEvent.ChangingSelection" - , "block" .= toObject verb pt ] - ChainDB.AddedToCurrentChain events selChangedInfo base extended _ -> - mconcat $ - [ "kind" .= String "TraceAddBlockEvent.AddedToCurrentChain" - , "newtip" .= renderPointForVerbosity verb (AF.headPoint extended) - , "chainLengthDelta" .= extended `chainLengthΔ` base - , "newSuffixSelectView" .= toObject verb (ChainDB.newSuffixSelectView selChangedInfo) - ] - ++ [ "oldSuffixSelectView" .= toObject verb oldSuffixSelectView - | Just oldSuffixSelectView <- [ChainDB.oldSuffixSelectView selChangedInfo] - ] - ++ [ "headers" .= toJSON (toObject verb `map` addedHdrsNewChain base extended) - | verb == MaximalVerbosity ] - ++ [ "events" .= toJSON (map (toObject verb) events) - | not (null events) ] - ChainDB.SwitchedToAFork events selChangedInfo old new _ -> - mconcat $ - [ "kind" .= String "TraceAddBlockEvent.SwitchedToAFork" - , "newtip" .= renderPointForVerbosity verb (AF.headPoint new) - , "chainLengthDelta" .= new `chainLengthΔ` old - -- Check that the SwitchedToAFork event was triggered by a proper fork. - , "realFork" .= not (AF.withinFragmentBounds (AF.headPoint old) new) - , "newSuffixSelectView" .= toObject verb (ChainDB.newSuffixSelectView selChangedInfo) - ] - ++ [ "oldSuffixSelectView" .= toObject verb oldSuffixSelectView - | Just oldSuffixSelectView <- [ChainDB.oldSuffixSelectView selChangedInfo] - ] - ++ [ "headers" .= toJSON (toObject verb `map` addedHdrsNewChain old new) - | verb == MaximalVerbosity ] - ++ [ "events" .= toJSON (map (toObject verb) events) - | not (null events) ] - ChainDB.AddBlockValidation ev' -> case ev' of - ChainDB.InvalidBlock err pt -> - mconcat [ "kind" .= String "TraceAddBlockEvent.AddBlockValidation.InvalidBlock" - , "block" .= toObject verb pt - , "error" .= show err ] - ChainDB.ValidCandidate c -> - mconcat [ "kind" .= String "TraceAddBlockEvent.AddBlockValidation.ValidCandidate" - , "block" .= renderPointForVerbosity verb (AF.headPoint c) ] - ChainDB.UpdateLedgerDbTraceEvent (LedgerDB.StartedPushingBlockToTheLedgerDb (PushStart start) (PushGoal goal) (Pushing curr)) -> - mconcat [ "kind" .= String "TraceAddBlockEvent.AddBlockValidation.UpdateLedgerDb" - , "startingBlock" .= renderRealPoint start - , "currentBlock" .= renderRealPoint curr - , "targetBlock" .= renderRealPoint goal - ] - ChainDB.AddedBlockToVolatileDB pt (BlockNo bn) _isEBB enclosing -> - mconcat $ [ "kind" .= String "TraceAddBlockEvent.AddedBlockToVolatileDB" - , "block" .= toObject verb pt - , "blockNo" .= show bn ] - <> [ "risingEdge" .= True | RisingEdge <- [enclosing] ] - ChainDB.PipeliningEvent ev' -> case ev' of - ChainDB.SetTentativeHeader hdr enclosing -> - mconcat $ [ "kind" .= String "TraceAddBlockEvent.PipeliningEvent.SetTentativeHeader" - , "block" .= renderPointForVerbosity verb (blockPoint hdr) - ] - <> [ "risingEdge" .= True | RisingEdge <- [enclosing] ] - ChainDB.TrapTentativeHeader hdr -> - mconcat [ "kind" .= String "TraceAddBlockEvent.PipeliningEvent.TrapTentativeHeader" - , "block" .= renderPointForVerbosity verb (blockPoint hdr) - ] - ChainDB.OutdatedTentativeHeader hdr -> - mconcat [ "kind" .= String "TraceAddBlockEvent.PipeliningEvent.OutdatedTentativeHeader" - , "block" .= renderPointForVerbosity verb (blockPoint hdr) - ] - ChainDB.AddedReprocessLoEBlocksToQueue RisingEdge -> - mconcat [ "kind" .= String "AddedReprocessLoEBlocksToQueue" ] - ChainDB.AddedReprocessLoEBlocksToQueue (FallingEdgeWith _) -> - mconcat [ "kind" .= String "AddedReprocessLoEBlocksToQueue TODO" ] - ChainDB.PoppedReprocessLoEBlocksFromQueue -> - mconcat [ "kind" .= String "PoppedReprocessLoEBlocksFromQueue" ] - ChainDB.ChainSelectionLoEDebug curChain loeFrag -> - case loeFrag of - ChainDB.LoEEnabled loeF -> - mconcat [ "kind" .= String "ChainSelectionLoEDebug" - , "curChain" .= headAndAnchor curChain - , "loeFrag" .= headAndAnchor loeF - ] - ChainDB.LoEDisabled -> - mconcat [ "kind" .= String "ChainSelectionLoEDebug" - , "curChain" .= headAndAnchor curChain - , "loeFrag" .= String "LoE is disabled" - ] - where - headAndAnchor frag = Aeson.object - [ "anchor" .= renderPointForVerbosity verb (AF.anchorPoint frag) - , "head" .= renderPointForVerbosity verb (AF.headPoint frag) - ] - where - addedHdrsNewChain - :: 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. - chainLengthΔ :: AF.AnchoredFragment (Header blk) -> AF.AnchoredFragment (Header blk) -> Int - chainLengthΔ = on (-) (fromWithOrigin (-1) . fmap (fromIntegral . unBlockNo) . AF.headBlockNo) - - toObject _verb (ChainDB.TracePerasCertDbEvent ev) = - mconcat [ "kind" .= String "TracePerasCertDbEvent" - , "event" .= show ev - ] - toObject _verb (ChainDB.TraceAddPerasCertEvent ev) = - mconcat [ "kind" .= String "TraceAddPerasCertEvent" - , "event" .= show ev - ] - - toObject MinimalVerbosity (ChainDB.TraceLedgerDBEvent _ev) = mempty -- no output - toObject verb (ChainDB.TraceLedgerDBEvent ev) = case ev of - LedgerDB.LedgerDBSnapshotEvent ev' -> case ev' of - LedgerDB.TookSnapshot snap pt enclosedTiming -> - mconcat [ "kind" .= String "TraceSnapshotEvent.TookSnapshot" - , "snapshot" .= toObject verb snap - , "tip" .= show pt - , "enclosedTime" .= enclosedTiming - ] - LedgerDB.DeletedSnapshot snap -> - mconcat [ "kind" .= String "TraceLedgerDBEvent.LedgerDBSnapshotEvent.DeletedSnapshot" - , "snapshot" .= toObject verb snap ] - LedgerDB.InvalidSnapshot snap failure -> - mconcat [ "kind" .= String "TraceLedgerDBEvent.LedgerDBSnapshotEvent.InvalidSnapshot" - , "snapshot" .= toObject verb snap - , "failure" .= show failure ] - LedgerDB.LedgerReplayEvent ev' -> case ev' of - LedgerDB.TraceReplayStartEvent ev'' -> case ev'' of - LedgerDB.ReplayFromGenesis -> - mconcat [ "kind" .= String "TraceLedgerReplayEvent.ReplayFromGenesis" ] - LedgerDB.ReplayFromSnapshot snap tip' -> - mconcat [ "kind" .= String "TraceLedgerReplayEvent.ReplayFromSnapshot" - , "snapshot" .= toObject verb snap - , "tip" .= show tip' ] - LedgerDB.TraceReplayProgressEvent (LedgerDB.ReplayedBlock pt _ledgerEvents _ (LedgerDB.ReplayGoal replayTo)) -> - mconcat [ "kind" .= String "TraceLedgerReplayEvent.ReplayedBlock" - , "slot" .= unSlotNo (realPointSlot pt) - , "tip" .= withOrigin 0 unSlotNo (pointSlot replayTo) ] - LedgerDB.LedgerDBForkerEvent (LedgerDB.TraceForkerEventWithKey k ev') -> - mconcat [ "kind" .= String "LedgerDBForkerEvent" - , "key" .= show k - , "event" .= show ev' ] - LedgerDB.LedgerDBFlavorImplEvent ev' -> - mconcat [ "kind" .= String "LedgerDBFlavorImplEvent" - , "event" .= show ev' ] - - toObject verb (ChainDB.TraceCopyToImmutableDBEvent ev) = case ev of - ChainDB.CopiedBlockToImmutableDB pt -> - mconcat [ "kind" .= String "TraceCopyToImmutableDBEvent.CopiedBlockToImmutableDB" - , "slot" .= toObject verb pt ] - ChainDB.NoBlocksToCopyToImmutableDB -> - mconcat [ "kind" .= String "TraceCopyToImmutableDBEvent.NoBlocksToCopyToImmutableDB" ] - - toObject verb (ChainDB.TraceGCEvent ev) = case ev of - ChainDB.PerformedGC slot -> - mconcat [ "kind" .= String "TraceGCEvent.PerformedGC" - , "slot" .= toObject verb slot ] - ChainDB.ScheduledGC slot difft -> - mconcat $ [ "kind" .= String "TraceGCEvent.ScheduledGC" - , "slot" .= toObject verb slot ] <> - [ "difft" .= String ((pack . show) difft) | verb >= MaximalVerbosity] - - toObject verb (ChainDB.TraceOpenEvent ev) = case ev of - ChainDB.StartedOpeningDB -> - mconcat ["kind" .= String "TraceOpenEvent.StartedOpeningDB"] - ChainDB.StartedOpeningImmutableDB -> - mconcat ["kind" .= String "TraceOpenEvent.StartedOpeningImmutableDB"] - ChainDB.StartedOpeningVolatileDB -> - mconcat ["kind" .= String "TraceOpenEvent.StartedOpeningVolatileDB"] - ChainDB.StartedOpeningLgrDB -> - mconcat ["kind" .= String "TraceOpenEvent.StartedOpeningLgrDB"] - ChainDB.OpenedDB immTip tip' -> - mconcat [ "kind" .= String "TraceOpenEvent.OpenedDB" - , "immtip" .= toObject verb immTip - , "tip" .= toObject verb tip' ] - ChainDB.ClosedDB immTip tip' -> - mconcat [ "kind" .= String "TraceOpenEvent.ClosedDB" - , "immtip" .= toObject verb immTip - , "tip" .= toObject verb tip' ] - ChainDB.OpenedImmutableDB immTip epoch -> - mconcat [ "kind" .= String "TraceOpenEvent.OpenedImmutableDB" - , "immtip" .= toObject verb immTip - , "epoch" .= String ((pack . show) epoch) ] - ChainDB.OpenedVolatileDB maxSlotN -> - mconcat [ "kind" .= String "TraceOpenEvent.OpenedVolatileDB" - , "maxSlotNo" .= String (showT maxSlotN) ] - ChainDB.OpenedLgrDB -> - mconcat [ "kind" .= String "TraceOpenEvent.OpenedLgrDB" ] - - toObject _verb (ChainDB.TraceFollowerEvent ev) = case ev of - ChainDB.NewFollower -> - mconcat [ "kind" .= String "TraceFollowerEvent.NewFollower" ] - ChainDB.FollowerNoLongerInMem _ -> - mconcat [ "kind" .= String "TraceFollowerEvent.FollowerNoLongerInMem" ] - ChainDB.FollowerSwitchToMem _ _ -> - mconcat [ "kind" .= String "TraceFollowerEvent.FollowerSwitchToMem" ] - ChainDB.FollowerNewImmIterator _ _ -> - mconcat [ "kind" .= String "TraceFollowerEvent.FollowerNewImmIterator" ] - toObject verb (ChainDB.TraceInitChainSelEvent ev) = case ev of - ChainDB.InitialChainSelected -> - mconcat ["kind" .= String "TraceFollowerEvent.InitialChainSelected"] - ChainDB.StartedInitChainSelection -> - mconcat ["kind" .= String "TraceFollowerEvent.StartedInitChainSelection"] - ChainDB.InitChainSelValidation ev' -> case ev' of - ChainDB.InvalidBlock err pt -> - mconcat [ "kind" .= String "TraceInitChainSelEvent.InvalidBlock" - , "block" .= toObject verb pt - , "error" .= show err ] - ChainDB.ValidCandidate c -> - mconcat [ "kind" .= String "TraceInitChainSelEvent.ValidCandidate" - , "block" .= renderPointForVerbosity verb (AF.headPoint c) ] - ChainDB.UpdateLedgerDbTraceEvent - (LedgerDB.StartedPushingBlockToTheLedgerDb (PushStart start) (PushGoal goal) (Pushing curr) ) -> - mconcat [ "kind" .= String "TraceAddBlockEvent.AddBlockValidation.UpdateLedgerDbTraceEvent.StartedPushingBlockToTheLedgerDb" - , "startingBlock" .= renderRealPoint start - , "currentBlock" .= renderRealPoint curr - , "targetBlock" .= renderRealPoint goal - ] - - toObject _verb (ChainDB.TraceIteratorEvent ev) = case ev of - ChainDB.UnknownRangeRequested unkRange -> - mconcat [ "kind" .= String "TraceIteratorEvent.UnknownRangeRequested" - , "range" .= String (showT unkRange) - ] - ChainDB.StreamFromVolatileDB streamFrom streamTo realPt -> - mconcat [ "kind" .= String "TraceIteratorEvent.StreamFromVolatileDB" - , "from" .= String (showT streamFrom) - , "to" .= String (showT streamTo) - , "point" .= String (Text.pack . show $ map renderRealPoint realPt) - ] - ChainDB.StreamFromImmutableDB streamFrom streamTo -> - mconcat [ "kind" .= String "TraceIteratorEvent.StreamFromImmutableDB" - , "from" .= String (showT streamFrom) - , "to" .= String (showT streamTo) - ] - ChainDB.StreamFromBoth streamFrom streamTo realPt -> - mconcat [ "kind" .= String "TraceIteratorEvent.StreamFromBoth" - , "from" .= String (showT streamFrom) - , "to" .= String (showT streamTo) - , "point" .= String (Text.pack . show $ map renderRealPoint realPt) - ] - ChainDB.BlockMissingFromVolatileDB realPt -> - mconcat [ "kind" .= String "TraceIteratorEvent.BlockMissingFromVolatileDB" - , "point" .= String (renderRealPoint realPt) - ] - ChainDB.BlockWasCopiedToImmutableDB realPt -> - mconcat [ "kind" .= String "TraceIteratorEvent.BlockWasCopiedToImmutableDB" - , "point" .= String (renderRealPoint realPt) - ] - ChainDB.BlockGCedFromVolatileDB realPt -> - mconcat [ "kind" .= String "TraceIteratorEvent.BlockGCedFromVolatileDB" - , "point" .= String (renderRealPoint realPt) - ] - ChainDB.SwitchBackToVolatileDB -> - mconcat ["kind" .= String "TraceIteratorEvent.SwitchBackToVolatileDB" - ] - toObject verb (ChainDB.TraceImmutableDBEvent ev) = case ev of - ImmDB.ChunkValidationEvent traceChunkValidation -> toObject verb traceChunkValidation - ImmDB.NoValidLastLocation -> - mconcat [ "kind" .= String "TraceImmutableDBEvent.NoValidLastLocation" ] - ImmDB.ValidatedLastLocation chunkNo immTip -> - mconcat [ "kind" .= String "TraceImmutableDBEvent.ValidatedLastLocation" - , "chunkNo" .= String (renderChunkNo chunkNo) - , "immTip" .= String (renderTipHash immTip) - , "blockNo" .= String (renderTipBlockNo immTip) - ] - ImmDB.ChunkFileDoesntFit expectPrevHash actualPrevHash -> - mconcat [ "kind" .= String "TraceImmutableDBEvent.ChunkFileDoesntFit" - , "expectedPrevHash" .= String (renderChainHash (Text.decodeLatin1 . toRawHash (Proxy @blk)) expectPrevHash) - , "actualPrevHash" .= String (renderChainHash (Text.decodeLatin1 . toRawHash (Proxy @blk)) actualPrevHash) - ] - ImmDB.Migrating txt -> - mconcat [ "kind" .= String "TraceImmutableDBEvent.Migrating" - , "info" .= String txt - ] - ImmDB.DeletingAfter immTipWithInfo -> - mconcat [ "kind" .= String "TraceImmutableDBEvent.DeletingAfter" - , "immTipHash" .= String (renderWithOrigin renderTipHash immTipWithInfo) - , "immTipBlockNo" .= String (renderWithOrigin renderTipBlockNo immTipWithInfo) - ] - ImmDB.DBAlreadyClosed -> mconcat [ "kind" .= String "TraceImmutableDBEvent.DBAlreadyClosed" ] - ImmDB.DBClosed -> mconcat [ "kind" .= String "TraceImmutableDBEvent.DBClosed" ] - ImmDB.TraceCacheEvent cacheEv -> - case cacheEv of - ImmDB.TraceCurrentChunkHit chunkNo nbPastChunksInCache -> - mconcat [ "kind" .= String "TraceImmDbEvent.TraceCacheEvent.TraceCurrentChunkHit" - , "chunkNo" .= String (renderChunkNo chunkNo) - , "noPastChunks" .= String (showT nbPastChunksInCache) - ] - ImmDB.TracePastChunkHit chunkNo nbPastChunksInCache -> - mconcat [ "kind" .= String "TraceImmDbEvent.TraceCacheEvent.TracePastChunkHit" - , "chunkNo" .= String (renderChunkNo chunkNo) - , "noPastChunks" .= String (showT nbPastChunksInCache) - ] - ImmDB.TracePastChunkMiss chunkNo nbPastChunksInCache -> - mconcat [ "kind" .= String "TraceImmDbEvent.TraceCacheEvent.TracePastChunkMiss" - , "chunkNo" .= String (renderChunkNo chunkNo) - , "noPastChunks" .= String (showT nbPastChunksInCache) - ] - ImmDB.TracePastChunkEvict chunkNo nbPastChunksInCache -> - mconcat [ "kind" .= String "TraceImmDbEvent.TraceCacheEvent.TracePastChunkEvict" - , "chunkNo" .= String (renderChunkNo chunkNo) - , "noPastChunks" .= String (showT nbPastChunksInCache) - ] - ImmDB.TracePastChunksExpired chunkNos nbPastChunksInCache -> - mconcat [ "kind" .= String "TraceImmDbEvent.TraceCacheEvent.TracePastChunksExpired" - , "chunkNos" .= String (Text.pack . show $ map renderChunkNo chunkNos) - , "noPastChunks" .= String (showT nbPastChunksInCache) - ] - toObject _verb (ChainDB.TraceVolatileDBEvent ev) = case ev of - VolDb.DBAlreadyClosed -> mconcat [ "kind" .= String "TraceVolatileDbEvent.DBAlreadyClosed"] - VolDb.BlockAlreadyHere blockId -> - mconcat [ "kind" .= String "TraceVolatileDbEvent.BlockAlreadyHere" - , "blockId" .= String (showT blockId) - ] - VolDb.Truncate pErr fsPath blockOffset -> - mconcat [ "kind" .= String "TraceVolatileDbEvent.Truncate" - , "parserError" .= String (showT pErr) - , "file" .= String (showT fsPath) - , "blockOffset" .= String (showT blockOffset) - ] - VolDb.InvalidFileNames fsPaths -> - mconcat [ "kind" .= String "TraceVolatileDBEvent.InvalidFileNames" - , "files" .= String (Text.pack . show $ map show fsPaths) - ] - VolDb.DBClosed -> mconcat [ "kind" .= String "TraceVolatileDbEvent.DBClosed"] - toObject verb (ChainDB.TraceChainSelStarvationEvent (ChainDB.ChainSelStarvation edge)) = - mconcat [ "kind" .= String "ChainDB.ChainSelStarvation" - , case edge of - RisingEdge -> "risingEdge" .= True - FallingEdgeWith pt -> "fallingEdge" .= toObject verb pt - ] - -instance ConvertRawHash blk => ToObject (ImmDB.TraceChunkValidation blk ChunkNo) where - toObject verb ev = case ev of - ImmDB.RewriteSecondaryIndex chunkNo -> - mconcat [ "kind" .= String "TraceImmutableDBEvent.RewriteSecondaryIndex" - , "chunkNo" .= String (renderChunkNo chunkNo) - ] - ImmDB.RewritePrimaryIndex chunkNo -> - mconcat [ "kind" .= String "TraceImmutableDBEvent.RewritePrimaryIndex" - , "chunkNo" .= String (renderChunkNo chunkNo) - ] - ImmDB.MissingPrimaryIndex chunkNo -> - mconcat [ "kind" .= String "TraceImmutableDBEvent.MissingPrimaryIndex" - , "chunkNo" .= String (renderChunkNo chunkNo) - ] - ImmDB.MissingSecondaryIndex chunkNo -> - mconcat [ "kind" .= String "TraceImmutableDBEvent.MissingSecondaryIndex" - , "chunkNo" .= String (renderChunkNo chunkNo) - ] - ImmDB.InvalidPrimaryIndex chunkNo -> - mconcat [ "kind" .= String "TraceImmutableDBEvent.InvalidPrimaryIndex" - , "chunkNo" .= String (renderChunkNo chunkNo) - ] - ImmDB.InvalidSecondaryIndex chunkNo -> - mconcat [ "kind" .= String "TraceImmutableDBEvent.InvalidSecondaryIndex" - , "chunkNo" .= String (renderChunkNo chunkNo) - ] - ImmDB.InvalidChunkFile chunkNo (ImmDB.ChunkErrHashMismatch hashPrevBlock prevHashOfBlock) -> - mconcat [ "kind" .= String "TraceImmutableDBEvent.InvalidChunkFile.ChunkErrHashMismatch" - , "chunkNo" .= String (renderChunkNo chunkNo) - , "hashPrevBlock" .= String (Text.decodeLatin1 . toRawHash (Proxy @blk) $ hashPrevBlock) - , "prevHashOfBlock" .= String (renderChainHash (Text.decodeLatin1 . toRawHash (Proxy @blk)) prevHashOfBlock) - ] - ImmDB.InvalidChunkFile chunkNo (ImmDB.ChunkErrCorrupt pt) -> - mconcat [ "kind" .= String "TraceImmutableDBEvent.InvalidChunkFile.ChunkErrCorrupt" - , "chunkNo" .= String (renderChunkNo chunkNo) - , "block" .= String (renderPointForVerbosity verb pt) - ] - ImmDB.ValidatedChunk chunkNo _ -> - mconcat [ "kind" .= String "TraceImmutableDBEvent.ValidatedChunk" - , "chunkNo" .= String (renderChunkNo chunkNo) - ] - ImmDB.MissingChunkFile chunkNo -> - mconcat [ "kind" .= String "TraceImmutableDBEvent.MissingChunkFile" - , "chunkNo" .= String (renderChunkNo chunkNo) - ] - ImmDB.InvalidChunkFile chunkNo (ImmDB.ChunkErrRead readIncErr) -> - mconcat [ "kind" .= String "TraceImmutableDBEvent.InvalidChunkFile.ChunkErrRead" - , "chunkNo" .= String (renderChunkNo chunkNo) - , "error" .= String (showT readIncErr) - ] - ImmDB.StartedValidatingChunk initialChunk finalChunk -> - mconcat [ "kind" .= String "TraceImmutableDBEvent.StartedValidatingChunk" - , "initialChunk" .= renderChunkNo initialChunk - , "finalChunk" .= renderChunkNo finalChunk - ] - - -instance ConvertRawHash blk => ToObject (TraceBlockFetchServerEvent blk) where - toObject _verb (TraceBlockFetchServerSendBlock blk) = - mconcat [ "kind" .= String "TraceBlockFetchServerSendBlock" - , "block" .= String (renderChainHash @blk (renderHeaderHash (Proxy @blk)) $ pointHash blk) - ] - -tipToObject :: forall blk. ConvertRawHash blk => Tip blk -> Aeson.Object -tipToObject = \case - TipGenesis -> mconcat - [ "slot" .= toJSON (0 :: Int) - , "block" .= String "genesis" - , "blockNo" .= toJSON ((-1) :: Int) - ] - Tip slot hash blockno -> mconcat - [ "slot" .= slot - , "block" .= String (renderHeaderHash (Proxy @blk) hash) - , "blockNo" .= blockno - ] - -instance (ConvertRawHash blk, LedgerSupportsProtocol blk, ToJSON (HeaderHash blk)) - => ToObject (TraceChainSyncClientEvent blk) where - toObject verb ev = case ev of - TraceDownloadedHeader h -> - mconcat - [ "kind" .= String "ChainSyncClientEvent.TraceDownloadedHeader" - , tipToObject (tipFromHeader h) - ] - TraceRolledBack tip -> - mconcat [ "kind" .= String "ChainSyncClientEvent.TraceRolledBack" - , "tip" .= toObject verb tip ] - TraceException exc -> - mconcat [ "kind" .= String "ChainSyncClientEvent.TraceException" - , "exception" .= String (pack $ show exc) ] - TraceFoundIntersection _ _ _ -> - mconcat [ "kind" .= String "ChainSyncClientEvent.TraceFoundIntersection" ] - TraceTermination reason -> - mconcat [ "kind" .= String "ChainSyncClientEvent.TraceTermination" - , "reason" .= String (pack $ show reason) ] - TraceValidatedHeader h -> - mconcat [ "kind" .= String "ChainSyncClientEvent.TraceValidatedHeader" - , tipToObject (tipFromHeader h) ] - TraceWaitingBeyondForecastHorizon slotNo -> - mconcat [ "kind" .= String "ChainSyncClientEvent.TraceWaitingBeyondForecastHorizon" - , "slot" .= condense slotNo ] - TraceAccessingForecastHorizon slotNo -> - mconcat [ "kind" .= String "ChainSyncClientEvent.TraceAccessingForecastHorizon" - , "slot" .= condense slotNo ] - TraceGaveLoPToken tokenGiven h bestBlockNumberPriorToH -> - mconcat [ "kind" .= String "ChainSyncClientEvent.TraceGaveLoPToken" - , "given" .= tokenGiven - , tipToObject (tipFromHeader h) - , "blockNo" .= bestBlockNumberPriorToH ] - TraceOfferJump jumpTo -> - mconcat [ "kind" .= String "ChainSyncClientEvent.TraceOfferJump" - , "jumpTo" .= toObject verb jumpTo - ] - TraceJumpResult res -> - mconcat [ "kind" .= String "ChainSyncClientEvent.TraceJumpResult" - , "res" .= case res of - ChainSync.Client.AcceptedJump info -> Aeson.object - [ "kind" .= String "AcceptedJump" - , "payload" .= toObject verb info ] - ChainSync.Client.RejectedJump info -> Aeson.object - [ "kind" .= String "RejectedJump" - , "payload" .= toObject verb info ] - ] - TraceJumpingWaitingForNextInstruction -> - mconcat [ "kind" .= String "ChainSyncClientEvent.TraceJumpingWaitingForNextInstruction" - ] - TraceJumpingInstructionIs instr -> - mconcat [ "kind" .= String "ChainSyncClientEvent.TraceJumpingInstructionIs" - , "instr" .= toObject verb instr - ] - TraceDrainingThePipe n -> - mconcat [ "kind" .= String "ChainSyncClientEvent.TraceDrainingThePipe" - , "n" .= natToInt n - ] - -instance ( LedgerSupportsProtocol blk - , ConvertRawHash blk - , ToJSON (HeaderHash blk) - ) => ToObject (ChainSync.Client.Instruction blk) where - toObject verb = \case - ChainSync.Client.RunNormally -> - mconcat ["kind" .= String "RunNormally"] - ChainSync.Client.Restart -> - mconcat ["kind" .= String "Restart"] - ChainSync.Client.JumpInstruction info -> - mconcat [ "kind" .= String "JumpInstruction" - , "payload" .= toObject verb info - ] - -instance ( LedgerSupportsProtocol blk - , ConvertRawHash blk - , ToJSON (HeaderHash blk) - ) => ToObject (ChainSync.Client.JumpInstruction blk) where - toObject verb = \case - ChainSync.Client.JumpTo info -> - mconcat [ "kind" .= String "JumpTo" - , "info" .= toObject verb info ] - ChainSync.Client.JumpToGoodPoint info -> - mconcat [ "kind" .= String "JumpToGoodPoint" - , "info" .= toObject verb info ] - -instance ( LedgerSupportsProtocol blk - , ConvertRawHash blk - , ToJSON (HeaderHash blk) - ) => ToObject (ChainSync.Client.JumpInfo blk) where - toObject verb info = - mconcat [ "kind" .= String "JumpInfo" - , "mostRecentIntersection" .= toObject verb (ChainSync.Client.jMostRecentIntersection info) - , "ourFragment" .= toJSON ((tipToObject . tipFromHeader) `map` AF.toOldestFirst (ChainSync.Client.jOurFragment info)) - , "theirFragment" .= toJSON ((tipToObject . tipFromHeader) `map` AF.toOldestFirst (ChainSync.Client.jTheirFragment info)) - ] - -instance HasPrivacyAnnotation (ChainSync.Client.TraceEventCsj peer blk) where -instance HasSeverityAnnotation (ChainSync.Client.TraceEventCsj peer blk) where - getSeverityAnnotation _ = Debug -instance (ToObject peer, ConvertRawHash blk, ToJSON (HeaderHash blk)) - => Transformable Text IO (TraceLabelPeer peer (ChainSync.Client.TraceEventCsj peer blk)) where - trTransformer = trStructured -instance (ToObject peer, ConvertRawHash blk, ToJSON (HeaderHash blk)) - => ToObject (ChainSync.Client.TraceEventCsj peer blk) where - toObject verb = \case - ChainSync.Client.BecomingObjector prevObjector -> - mconcat - [ "kind" .= String "BecomingObjector" - , "previousObjector" .= (toObject verb <$> prevObjector) - ] - ChainSync.Client.BlockedOnJump -> - mconcat - [ "kind" .= String "BlockedOnJump" - ] - ChainSync.Client.InitializedAsDynamo -> - mconcat - [ "kind" .= String "InitializedAsDynamo" - ] - ChainSync.Client.NoLongerDynamo newDynamo reason -> - mconcat - [ "kind" .= String "NoLongerDynamo" - , "newDynamo" .= (toObject verb <$> newDynamo) - , "reason" .= csjReasonToJSON reason - ] - ChainSync.Client.NoLongerObjector newObjector reason -> - mconcat - [ "kind" .= String "NoLongerObjector" - , "newObjector" .= (toObject verb <$> newObjector) - , "reason" .= csjReasonToJSON reason - ] - ChainSync.Client.SentJumpInstruction jumpTarget -> - mconcat - [ "kind" .= String "SentJumpInstruction" - , "jumpTarget" .= toObject verb jumpTarget - ] - where - csjReasonToJSON = \case - ChainSync.Client.BecauseCsjDisengage -> String "BecauseCsjDisengage" - ChainSync.Client.BecauseCsjDisconnect -> String "BecauseCsjDisconnect" - - -instance HasPrivacyAnnotation (ChainSync.Client.TraceEventDbf peer) where -instance HasSeverityAnnotation (ChainSync.Client.TraceEventDbf peer) where - getSeverityAnnotation _ = Info -instance ToObject peer - => Transformable Text IO (ChainSync.Client.TraceEventDbf peer) where - trTransformer = trStructured -instance HasTextFormatter (ChainSync.Client.TraceEventDbf peer) where -instance ToObject peer - => ToObject (ChainSync.Client.TraceEventDbf peer) where - toObject verb = \case - ChainSync.Client.RotatedDynamo oldPeer newPeer -> - mconcat - [ "kind" .= String "RotatedDynamo" - , "oldPeer" .= toObject verb oldPeer - , "newPeer" .= toObject verb newPeer - ] - -instance ConvertRawHash blk - => ToObject (TraceChainSyncServerEvent blk) where - toObject verb ev = case ev of - TraceChainSyncServerUpdate tip update blocking enclosing -> - mconcat $ - [ "kind" .= String "ChainSyncServerEvent.TraceChainSyncServerUpdate" - , "tip" .= tipToObject tip - , case update of - AddBlock pt -> "addBlock" .= renderPointForVerbosity verb pt - RollBack pt -> "rollBackTo" .= renderPointForVerbosity verb pt - , "blockingRead" .= case blocking of Blocking -> True; NonBlocking -> False - ] - <> [ "risingEdge" .= True | RisingEdge <- [enclosing] ] - -instance ( ToObject (ApplyTxErr blk), ToObject (GenTx blk) - , ToJSON (GenTxId blk), LedgerSupportsMempool blk - , ConvertRawHash blk - , ToJSON (HeaderHash blk) - ) => ToObject (TraceEventMempool blk) where - toObject verb (TraceMempoolAddedTx tx _mpSzBefore mpSzAfter) = - mconcat - [ "kind" .= String "TraceMempoolAddedTx" - , "tx" .= toObject verb (txForgetValidated tx) - , "mempoolSize" .= toObject verb mpSzAfter - ] - toObject verb (TraceMempoolRejectedTx tx txApplyErr details mpSz) = - mconcat $ - [ "kind" .= String "TraceMempoolRejectedTx" - , "tx" .= toObject verb tx - , "mempoolSize" .= toObject verb mpSz - ] <> - if verb /= MaximalVerbosity then [] else - [ "err" .= toObject verb txApplyErr - , "errdetails" .= jsonMempoolRejectionDetails details - ] - toObject verb (TraceMempoolRemoveTxs txs mpSz) = - mconcat - [ "kind" .= String "TraceMempoolRemoveTxs" - , "txs" - .= map - ( \(tx, err) -> - Aeson.object $ - [ "tx" .= toObject verb (txForgetValidated tx) - ] <> - [ "err" .= toObject verb err - | verb == MaximalVerbosity - ] - ) - txs - , "mempoolSize" .= toObject verb mpSz - ] - toObject verb (TraceMempoolManuallyRemovedTxs txs0 txs1 mpSz) = - mconcat - [ "kind" .= String "TraceMempoolManuallyRemovedTxs" - , "txsRemoved" .= txs0 - , "txsInvalidated" .= map (toObject verb . txForgetValidated) txs1 - , "mempoolSize" .= toObject verb mpSz - ] - toObject _verb (TraceMempoolSynced et) = - mconcat - [ "kind" .= String "TraceMempoolSynced" - , "enclosingTime" .= et - ] - toObject verb (TraceMempoolSyncNotNeeded t) = - mconcat - [ "kind" .= String "TraceMempoolSyncNotNeeded" - , "tip" .= toObject verb t - ] - toObject verb (TraceMempoolAttemptingAdd tx) = - mconcat - [ "kind" .= String "TraceMempoolAttemptingAdd" - , "tx" .= toObject verb tx - ] - - toObject _verb TraceMempoolTipMovedBetweenSTMBlocks = - mconcat - [ "kind" .= String "TraceMempoolTipMovedBetweenSTMBlocks" - ] - -instance ToObject MempoolSize where - toObject _verb MempoolSize{msNumTxs, msNumBytes} = - mconcat - [ "numTxs" .= msNumTxs - , "bytes" .= unByteSize32 msNumBytes - ] - -instance HasTextFormatter () where - formatText _ = pack . show . toList - --- ForgeStateInfo default value = () -instance Transformable Text IO () where - trTransformer = trStructuredText - -instance ( RunNode blk - , ToObject (LedgerError blk) - , ToObject (OtherHeaderEnvelopeError blk) - , ToObject (ValidationErr (BlockProtocol blk)) - , ToObject (CannotForge blk) - , ToObject (ForgeStateUpdateError blk)) - => ToObject (TraceForgeEvent blk) where - toObject _verb (TraceStartLeadershipCheck slotNo) = - mconcat - [ "kind" .= String "TraceStartLeadershipCheck" - , "slot" .= toJSON (unSlotNo slotNo) - ] - toObject verb (TraceSlotIsImmutable slotNo tipPoint tipBlkNo) = - mconcat - [ "kind" .= String "TraceSlotIsImmutable" - , "slot" .= toJSON (unSlotNo slotNo) - , "tip" .= renderPointForVerbosity verb tipPoint - , "tipBlockNo" .= toJSON (unBlockNo tipBlkNo) - ] - toObject _verb (TraceBlockFromFuture currentSlot tip) = - mconcat - [ "kind" .= String "TraceBlockFromFuture" - , "current slot" .= toJSON (unSlotNo currentSlot) - , "tip" .= toJSON (unSlotNo tip) - ] - toObject verb (TraceBlockContext currentSlot tipBlkNo tipPoint) = - mconcat - [ "kind" .= String "TraceBlockContext" - , "current slot" .= toJSON (unSlotNo currentSlot) - , "tip" .= renderPointForVerbosity verb tipPoint - , "tipBlockNo" .= toJSON (unBlockNo tipBlkNo) - ] - toObject _verb (TraceNoLedgerState slotNo _pt) = - mconcat - [ "kind" .= String "TraceNoLedgerState" - , "slot" .= toJSON (unSlotNo slotNo) - ] - toObject _verb (TraceLedgerState slotNo _pt) = - mconcat - [ "kind" .= String "TraceLedgerState" - , "slot" .= toJSON (unSlotNo slotNo) - ] - toObject _verb (TraceNoLedgerView slotNo _) = - mconcat - [ "kind" .= String "TraceNoLedgerView" - , "slot" .= toJSON (unSlotNo slotNo) - ] - toObject _verb (TraceLedgerView slotNo) = - mconcat - [ "kind" .= String "TraceLedgerView" - , "slot" .= toJSON (unSlotNo slotNo) - ] - toObject verb (TraceForgeStateUpdateError slotNo reason) = - mconcat - [ "kind" .= String "TraceForgeStateUpdateError" - , "slot" .= toJSON (unSlotNo slotNo) - , "reason" .= toObject verb reason - ] - toObject verb (TraceNodeCannotForge slotNo reason) = - mconcat - [ "kind" .= String "TraceNodeCannotForge" - , "slot" .= toJSON (unSlotNo slotNo) - , "reason" .= toObject verb reason - ] - toObject _verb (TraceNodeNotLeader slotNo) = - mconcat - [ "kind" .= String "TraceNodeNotLeader" - , "slot" .= toJSON (unSlotNo slotNo) - ] - toObject _verb (TraceNodeIsLeader slotNo) = - mconcat - [ "kind" .= String "TraceNodeIsLeader" - , "slot" .= toJSON (unSlotNo slotNo) - ] - toObject verb (TraceForgeTickedLedgerState slotNo prevPt) = - mconcat - [ "kind" .= String "TraceForgeTickedLedgerState" - , "slot" .= toJSON (unSlotNo slotNo) - , "prev" .= renderPointForVerbosity verb prevPt - ] - toObject verb (TraceForgingMempoolSnapshot slotNo prevPt mpHash mpSlot) = - mconcat - [ "kind" .= String "TraceForgingMempoolSnapshot" - , "slot" .= toJSON (unSlotNo slotNo) - , "prev" .= renderPointForVerbosity verb prevPt - , "mempoolHash" .= String (renderChainHash @blk (renderHeaderHash (Proxy @blk)) mpHash) - , "mempoolSlot" .= toJSON (unSlotNo mpSlot) - ] - toObject _verb (TraceForgedBlock slotNo _ blk _ _) = - mconcat - [ "kind" .= String "TraceForgedBlock" - , "slot" .= toJSON (unSlotNo slotNo) - , "block" .= String (renderHeaderHash (Proxy @blk) $ blockHash blk) - , "blockNo" .= toJSON (unBlockNo $ blockNo blk) - , "blockPrev" .= String (renderChainHash @blk (renderHeaderHash (Proxy @blk)) $ blockPrevHash blk) - ] - toObject _verb (TraceDidntAdoptBlock slotNo _) = - mconcat - [ "kind" .= String "TraceDidntAdoptBlock" - , "slot" .= toJSON (unSlotNo slotNo) - ] - toObject verb (TraceForgedInvalidBlock slotNo _ reason) = - mconcat - [ "kind" .= String "TraceForgedInvalidBlock" - , "slot" .= toJSON (unSlotNo slotNo) - , "reason" .= toObject verb reason - ] - toObject MaximalVerbosity (TraceAdoptedBlock slotNo blk txs) = - mconcat - [ "kind" .= String "TraceAdoptedBlock" - , "slot" .= toJSON (unSlotNo slotNo) - , "blockHash" .= renderHeaderHashForVerbosity - (Proxy @blk) - MaximalVerbosity - (blockHash blk) - , "blockSize" .= toJSON (getSizeInBytes $ estimateBlockSize (getHeader blk)) - , "txIds" .= toJSON (map (show . txId . txForgetValidated) txs) - ] - toObject verb (TraceAdoptedBlock slotNo blk _txs) = - mconcat - [ "kind" .= String "TraceAdoptedBlock" - , "slot" .= toJSON (unSlotNo slotNo) - , "blockHash" .= renderHeaderHashForVerbosity - (Proxy @blk) - verb - (blockHash blk) - , "blockSize" .= toJSON (getSizeInBytes $ estimateBlockSize (getHeader blk)) - ] - toObject verb (TraceAdoptionThreadDied slotNo blk) = - mconcat - [ "kind" .= String "TraceAdoptionThreadDied" - , "slot" .= toJSON (unSlotNo slotNo) - , "blockHash" .= renderHeaderHashForVerbosity - (Proxy @blk) - verb - (blockHash blk) - , "blockSize" .= toJSON (getSizeInBytes $ estimateBlockSize (getHeader blk)) - ] - - -instance ToObject (TraceLocalTxSubmissionServerEvent blk) where - toObject _verb _ = - mconcat [ "kind" .= String "TraceLocalTxSubmissionServerEvent" ] - -instance HasPrivacyAnnotation (TraceGsmEvent selection) where - -instance HasSeverityAnnotation (TraceGsmEvent selection) where - getSeverityAnnotation = \case - GsmEventEnterCaughtUp{} -> Notice - GsmEventLeaveCaughtUp{} -> Warning - GsmEventPreSyncingToSyncing{} -> Notice - GsmEventSyncingToPreSyncing{} -> Notice - GsmEventInitializedInCaughtUp{} -> Notice - GsmEventInitializedInPreSyncing{} -> Notice - -instance ToObject selection => Transformable Text IO (TraceGsmEvent selection) where - trTransformer = trStructured - -instance ToObject selection => ToObject (TraceGsmEvent selection) where - toObject verb (GsmEventEnterCaughtUp i s) = - mconcat - [ "kind" .= String "GsmEventEnterCaughtUp" - , "peerNumber" .= toJSON i - , "currentSelection" .= toObject verb s - ] - toObject verb (GsmEventLeaveCaughtUp s a) = - mconcat - [ "kind" .= String "GsmEventLeaveCaughtUp" - , "currentSelection" .= toObject verb s - , "age" .= toJSON (show a) - ] - toObject _verb GsmEventPreSyncingToSyncing = - mconcat - [ "kind" .= String "GsmEventPreSyncingToSyncing" - ] - toObject _verb GsmEventSyncingToPreSyncing = - mconcat - [ "kind" .= String "GsmEventSyncingToPreSyncing" - ] - toObject _verb GsmEventInitializedInCaughtUp = - mconcat - [ "kind" .= String "GsmEventInitializedInCaughtUp" - ] - toObject _verb GsmEventInitializedInPreSyncing = - mconcat - [ "kind" .= String "GsmEventInitializedInPreSyncing" - ] - -instance HasPrivacyAnnotation (TraceGDDEvent peer blk) where -instance HasSeverityAnnotation (TraceGDDEvent peer blk) where - getSeverityAnnotation _ = Debug -instance (Typeable blk, ToObject peer, ConvertRawHash blk, GetHeader blk, ToJSON (HeaderHash blk)) => Transformable Text IO (TraceGDDEvent peer blk) where - trTransformer = trStructured - -instance (Typeable blk, ToObject peer, ConvertRawHash blk, GetHeader blk, ToJSON (HeaderHash blk)) => ToObject (TraceGDDEvent peer blk) where - toObject verb (TraceGDDDebug (GDDDebugInfo {..})) = mconcat $ - [ "kind" .= String "TraceGDDEvent" - , "losingPeers".= toJSON (map (toObject verb) losingPeers) - , "loeHead" .= toObject verb loeHead - , "sgen" .= toJSON (unGenesisWindow sgen) - ] <> do - guard $ verb >= MaximalVerbosity - [ "bounds" .= toJSON ( - map - ( \(peer, density) -> Object $ mconcat - [ "kind" .= String "PeerDensityBound" - , "peer" .= toObject verb peer - , "densityBounds" .= toObject verb density - ] - ) - bounds - ) - , "curChain" .= toObject verb curChain - , "candidates" .= toJSON ( - map - ( \(peer, frag) -> Object $ mconcat - [ "kind" .= String "PeerCandidateFragment" - , "peer" .= toObject verb peer - , "candidateFragment" .= toObject verb frag - ] - ) - candidates - ) - , "candidateSuffixes" .= toJSON ( - map - ( \(peer, frag) -> Object $ mconcat - [ "kind" .= String "PeerCandidateSuffix" - , "peer" .= toObject verb peer - , "candidateSuffix" .= toObject verb frag - ] - ) - candidateSuffixes - ) - ] - - toObject verb (TraceGDDDisconnected peer) = mconcat - [ "kind" .= String "TraceGDDDisconnected" - , "peer" .= toJSON (map (toObject verb) $ toList peer) - ] - -instance - (Typeable blk, ConvertRawHash blk, GetHeader blk, ToJSON (HeaderHash blk)) => - ToObject (DensityBounds blk) where - toObject verb DensityBounds {..} = mconcat - [ "kind" .= String "DensityBounds" - , "clippedFragment" .= toObject verb clippedFragment - , "offersMoreThanK" .= toJSON offersMoreThanK - , "lowerBound" .= toJSON lowerBound - , "upperBound" .= toJSON upperBound - , "hasBlockAfter" .= toJSON hasBlockAfter - , "latestSlot" .= toJSON (unSlotNo <$> withOriginToMaybe latestSlot) - , "idling" .= toJSON idling - ] - -instance ConvertRawHash blk => ToObject (Tip blk) where - toObject _verb TipGenesis = - mconcat [ "kind" .= String "TipGenesis" ] - toObject _verb (Tip slotNo hash bNo) = - mconcat [ "kind" .= String "Tip" - , "tipSlotNo" .= toJSON (unSlotNo slotNo) - , "tipHash" .= renderHeaderHash (Proxy @blk) hash - , "tipBlockNo" .= toJSON bNo - ] - -instance ToObject KESAgentClientTrace where - toObject _verb (KESAgentClientException exc) = - mconcat [ "kind" .= String "KESAgentClientException" - , "exception" .= String (pack $ displayException exc) - ] - toObject verb (KESAgentClientTrace trc) = - mconcat [ "kind" .= String "KESAgentClientTrace" - , "trace" .= toObject verb trc - ] - -instance HasPrivacyAnnotation KESAgentClientTrace where - -instance HasSeverityAnnotation KESAgentClientTrace where - getSeverityAnnotation = \case - KESAgentClientException{} -> Error - KESAgentClientTrace{} -> Info - -instance Transformable Text IO KESAgentClientTrace where - trTransformer = trStructured - -instance ToObject Agent.ServiceClientTrace where - toObject _dtal = \case - Agent.ServiceClientVersionHandshakeTrace _vhdt -> - mconcat [ "kind" .= String "ServiceClientVersionHandshakeTrace" ] - Agent.ServiceClientVersionHandshakeFailed -> - mconcat [ "kind" .= String "ServiceClientVersionHandshakeFailed" ] - Agent.ServiceClientDriverTrace _sdt -> - mconcat [ "kind" .= String "ServiceClientDriverTrace" ] - Agent.ServiceClientSocketClosed -> - mconcat [ "kind" .= String "ServiceClientSocketClosed" ] - Agent.ServiceClientConnected _s -> - mconcat [ "kind" .= String "ServiceClientConnected" ] - Agent.ServiceClientAttemptReconnect _ _ _ _ -> - mconcat [ "kind" .= String "ServiceClientAttemptReconnect" ] - Agent.ServiceClientReceivedKey _tbt -> - mconcat [ "kind" .= String "ServiceClientReceivedKey" ] - Agent.ServiceClientDeclinedKey _tbt -> - mconcat [ "kind" .= String "ServiceClientDeclinedKey" ] - Agent.ServiceClientDroppedKey -> - mconcat [ "kind" .= String "ServiceClientDroppedKey" ] - Agent.ServiceClientOpCertNumberCheck _ _ -> - mconcat [ "kind" .= String "ServiceClientOpCertNumberCheck" ] - Agent.ServiceClientAbnormalTermination _s -> - mconcat [ "kind" .= String "ServiceClientAbnormalTermination" ] - Agent.ServiceClientStopped -> - mconcat [ "kind" .= String "ServiceClientStopped" ] - -instance HasPrivacyAnnotation Agent.ServiceClientTrace where - -instance HasSeverityAnnotation Agent.ServiceClientTrace where - getSeverityAnnotation = \case - Agent.ServiceClientVersionHandshakeTrace{} -> Debug - Agent.ServiceClientVersionHandshakeFailed{} -> Error - Agent.ServiceClientDriverTrace{} -> Debug - Agent.ServiceClientSocketClosed{} -> Info - Agent.ServiceClientConnected{} -> Info - Agent.ServiceClientAttemptReconnect{} -> Info - Agent.ServiceClientReceivedKey{} -> Info - Agent.ServiceClientDeclinedKey{} -> Info - Agent.ServiceClientDroppedKey{} -> Info - Agent.ServiceClientOpCertNumberCheck{} -> Debug - Agent.ServiceClientAbnormalTermination{} -> Error - Agent.ServiceClientStopped{} -> Info diff --git a/cardano-node/src/Cardano/Tracing/OrphanInstances/HardFork.hs b/cardano-node/src/Cardano/Tracing/OrphanInstances/HardFork.hs deleted file mode 100644 index c928ecdce58..00000000000 --- a/cardano-node/src/Cardano/Tracing/OrphanInstances/HardFork.hs +++ /dev/null @@ -1,453 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# 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.Tracing.OrphanInstances.HardFork () where - -import Cardano.Slotting.Slot (EpochSize (..)) -import Cardano.Tracing.OrphanInstances.Common -import Cardano.Tracing.OrphanInstances.Consensus () -import Ouroboros.Consensus.Block (BlockProtocol, CannotForge, ForgeStateInfo, - ForgeStateUpdateError, PerasWeight (..)) -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 (..), OneEraTiebreakerView (..), - OneEraValidationErr (..), mkEraMismatch) -import Ouroboros.Consensus.HardFork.Combinator.Condense () -import Ouroboros.Consensus.HardFork.Combinator.Serialisation.Common - (EraNodeToClientVersion (..), HardForkNodeToNodeVersion (..), - HardForkSpecificNodeToClientVersion (..), HardForkSpecificNodeToNodeVersion (..)) -import Ouroboros.Consensus.HardFork.History.EraParams (EraParams (..), SafeZone) -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.Node.NetworkProtocolVersion (BlockNodeToClientVersion, - BlockNodeToNodeVersion) -import Ouroboros.Consensus.Peras.SelectView -import Ouroboros.Consensus.Protocol.Abstract (ConsensusProtocol (TiebreakerView), - ValidationErr) -import Ouroboros.Consensus.TypeFamilyWrappers -import Ouroboros.Consensus.Util.Condense (Condense (..)) - -import Data.Aeson -import qualified Data.ByteString.Base16 as Base16 -import qualified Data.ByteString.Short as SBS -import Data.Proxy (Proxy (..)) -import Data.SOP (All, Compose, K (..)) -import Data.SOP.Strict - - --- --- instances for hashes --- - -instance Condense (OneEraHash xs) where - condense = condense . Base16.encode . SBS.fromShort . getOneEraHash - --- --- instances for Header HardForkBlock --- - -instance All (ToObject `Compose` Header) xs => ToObject (Header (HardForkBlock xs)) where - toObject verb = - hcollapse - . hcmap (Proxy @(ToObject `Compose` Header)) (K . toObject verb) - . getOneEraHeader - . getHardForkHeader - - --- --- instances for GenTx HardForkBlock --- - -instance All (Compose ToObject GenTx) xs => ToObject (GenTx (HardForkBlock xs)) where - toObject verb = - hcollapse - . hcmap (Proxy @(ToObject `Compose` GenTx)) (K . toObject verb) - . 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 (ToObject `Compose` WrapApplyTxErr) xs => ToObject (HardForkApplyTxErr xs) where - toObject verb (HardForkApplyTxErrFromEra err) = toObject verb err - toObject _verb (HardForkApplyTxErrWrongEra mismatch) = - mconcat - [ "kind" .= String "HardForkApplyTxErrWrongEra" - , "currentEra" .= ledgerEraName - , "txEra" .= otherEraName - ] - where - EraMismatch {ledgerEraName, otherEraName} = mkEraMismatch mismatch - -instance All (ToObject `Compose` WrapApplyTxErr) xs => ToObject (OneEraApplyTxErr xs) where - toObject verb = - hcollapse - . hcmap (Proxy @(ToObject `Compose` WrapApplyTxErr)) (K . toObject verb) - . getOneEraApplyTxErr - -instance ToObject (ApplyTxErr blk) => ToObject (WrapApplyTxErr blk) where - toObject verb = toObject verb . unwrapApplyTxErr - - --- --- instances for HardForkLedgerError --- - -instance All (ToObject `Compose` WrapLedgerErr) xs => ToObject (HardForkLedgerError xs) where - toObject verb (HardForkLedgerErrorFromEra err) = toObject verb err - - toObject _verb (HardForkLedgerErrorWrongEra mismatch) = - mconcat - [ "kind" .= String "HardForkLedgerErrorWrongEra" - , "currentEra" .= ledgerEraName - , "blockEra" .= otherEraName - ] - where - EraMismatch {ledgerEraName, otherEraName} = mkEraMismatch mismatch - -instance All (ToObject `Compose` WrapLedgerErr) xs => ToObject (OneEraLedgerError xs) where - toObject verb = - hcollapse - . hcmap (Proxy @(ToObject `Compose` WrapLedgerErr)) (K . toObject verb) - . getOneEraLedgerError - -instance ToObject (LedgerError blk) => ToObject (WrapLedgerErr blk) where - toObject verb = toObject verb . unwrapLedgerErr - - --- --- instances for HardForkLedgerWarning --- - -instance ( All (ToObject `Compose` WrapLedgerWarning) xs - , All SingleEraBlock xs - ) => ToObject (HardForkLedgerWarning xs) where - toObject verb warning = case warning of - HardForkWarningInEra err -> toObject verb err - - HardForkWarningTransitionMismatch toEra eraParams epoch -> - mconcat - [ "kind" .= String "HardForkWarningTransitionMismatch" - , "toEra" .= condense toEra - , "eraParams" .= toObject verb eraParams - , "transitionEpoch" .= epoch - ] - - HardForkWarningTransitionInFinalEra fromEra epoch -> - mconcat - [ "kind" .= String "HardForkWarningTransitionInFinalEra" - , "fromEra" .= condense fromEra - , "transitionEpoch" .= epoch - ] - - HardForkWarningTransitionUnconfirmed toEra -> - mconcat - [ "kind" .= String "HardForkWarningTransitionUnconfirmed" - , "toEra" .= condense toEra - ] - - HardForkWarningTransitionReconfirmed fromEra toEra prevEpoch newEpoch -> - mconcat - [ "kind" .= String "HardForkWarningTransitionReconfirmed" - , "fromEra" .= condense fromEra - , "toEra" .= condense toEra - , "prevTransitionEpoch" .= prevEpoch - , "newTransitionEpoch" .= newEpoch - ] - -instance All (ToObject `Compose` WrapLedgerWarning) xs => ToObject (OneEraLedgerWarning xs) where - toObject verb = - hcollapse - . hcmap (Proxy @(ToObject `Compose` WrapLedgerWarning)) (K . toObject verb) - . getOneEraLedgerWarning - -instance ToObject (LedgerWarning blk) => ToObject (WrapLedgerWarning blk) where - toObject verb = toObject verb . unwrapLedgerWarning - -instance ToObject EraParams where - toObject _verb EraParams{ eraEpochSize, eraSlotLength, eraSafeZone} = - mconcat - [ "epochSize" .= unEpochSize eraEpochSize - , "slotLength" .= getSlotLength eraSlotLength - , "safeZone" .= eraSafeZone - ] - -deriving instance ToJSON SafeZone - - --- --- instances for HardForkLedgerUpdate --- - -instance ( All (ToObject `Compose` WrapLedgerUpdate) xs - , All SingleEraBlock xs - ) => ToObject (HardForkLedgerUpdate xs) where - toObject verb update = case update of - HardForkUpdateInEra err -> toObject verb err - - HardForkUpdateTransitionConfirmed fromEra toEra epoch -> - mconcat - [ "kind" .= String "HardForkUpdateTransitionConfirmed" - , "fromEra" .= condense fromEra - , "toEra" .= condense toEra - , "transitionEpoch" .= epoch - ] - - HardForkUpdateTransitionDone fromEra toEra epoch -> - mconcat - [ "kind" .= String "HardForkUpdateTransitionDone" - , "fromEra" .= condense fromEra - , "toEra" .= condense toEra - , "transitionEpoch" .= epoch - ] - - HardForkUpdateTransitionRolledBack fromEra toEra -> - mconcat - [ "kind" .= String "HardForkUpdateTransitionRolledBack" - , "fromEra" .= condense fromEra - , "toEra" .= condense toEra - ] - -instance All (ToObject `Compose` WrapLedgerUpdate) xs => ToObject (OneEraLedgerUpdate xs) where - toObject verb = - hcollapse - . hcmap (Proxy @(ToObject `Compose` WrapLedgerUpdate)) (K . toObject verb) - . getOneEraLedgerUpdate - -instance ToObject (LedgerUpdate blk) => ToObject (WrapLedgerUpdate blk) where - toObject verb = toObject verb . unwrapLedgerUpdate - - --- --- instances for HardForkEnvelopeErr --- - -instance All (ToObject `Compose` WrapEnvelopeErr) xs => ToObject (HardForkEnvelopeErr xs) where - toObject verb (HardForkEnvelopeErrFromEra err) = toObject verb err - - toObject _verb (HardForkEnvelopeErrWrongEra mismatch) = - mconcat - [ "kind" .= String "HardForkEnvelopeErrWrongEra" - , "currentEra" .= ledgerEraName - , "blockEra" .= otherEraName - ] - where - EraMismatch {ledgerEraName, otherEraName} = mkEraMismatch mismatch - -instance All (ToObject `Compose` WrapEnvelopeErr) xs => ToObject (OneEraEnvelopeErr xs) where - toObject verb = - hcollapse - . hcmap (Proxy @(ToObject `Compose` WrapEnvelopeErr)) (K . toObject verb) - . getOneEraEnvelopeErr - -instance ToObject (OtherHeaderEnvelopeError blk) => ToObject (WrapEnvelopeErr blk) where - toObject verb = toObject verb . unwrapEnvelopeErr - - --- --- instances for HardForkValidationErr --- - -instance All (ToObject `Compose` WrapValidationErr) xs => ToObject (HardForkValidationErr xs) where - toObject verb (HardForkValidationErrFromEra err) = toObject verb err - - toObject _verb (HardForkValidationErrWrongEra mismatch) = - mconcat - [ "kind" .= String "HardForkValidationErrWrongEra" - , "currentEra" .= ledgerEraName - , "blockEra" .= otherEraName - ] - where - EraMismatch {ledgerEraName, otherEraName} = mkEraMismatch mismatch - -instance All (ToObject `Compose` WrapValidationErr) xs => ToObject (OneEraValidationErr xs) where - toObject verb = - hcollapse - . hcmap (Proxy @(ToObject `Compose` WrapValidationErr)) (K . toObject verb) - . getOneEraValidationErr - -instance ToObject (ValidationErr (BlockProtocol blk)) => ToObject (WrapValidationErr blk) where - toObject verb = toObject verb . unwrapValidationErr - - --- --- instances for HardForkCannotForge --- - --- It's a type alias: --- type HardForkCannotForge xs = OneEraCannotForge xs - -instance All (ToObject `Compose` WrapCannotForge) xs => ToObject (OneEraCannotForge xs) where - toObject verb = - hcollapse - . hcmap (Proxy @(ToObject `Compose` WrapCannotForge)) - (K . toObject verb) - . getOneEraCannotForge - -instance ToObject (CannotForge blk) => ToObject (WrapCannotForge blk) where - toObject verb = toObject verb . unwrapCannotForge - - --- --- instances for HardForkForgeStateInfo --- - --- It's a type alias: --- type HardForkForgeStateInfo xs = OneEraForgeStateInfo xs - -instance All (ToObject `Compose` WrapForgeStateInfo) xs => ToObject (OneEraForgeStateInfo xs) where - toObject verb forgeStateInfo = - mconcat - [ "kind" .= String "HardForkForgeStateInfo" - , "forgeStateInfo" .= toJSON forgeStateInfo' - ] - where - forgeStateInfo' :: Object - forgeStateInfo' = - hcollapse - . hcmap (Proxy @(ToObject `Compose` WrapForgeStateInfo)) - (K . toObject verb) - . getOneEraForgeStateInfo - $ forgeStateInfo - -instance ToObject (ForgeStateInfo blk) => ToObject (WrapForgeStateInfo blk) where - toObject verb = toObject verb . unwrapForgeStateInfo - - --- --- instances for HardForkForgeStateUpdateError --- - --- It's a type alias: --- type HardForkForgeStateUpdateError xs = OneEraForgeStateUpdateError xs - -instance All (ToObject `Compose` WrapForgeStateUpdateError) xs => ToObject (OneEraForgeStateUpdateError xs) where - toObject verb forgeStateUpdateError = - mconcat - [ "kind" .= String "HardForkForgeStateUpdateError" - , "forgeStateUpdateError" .= toJSON forgeStateUpdateError' - ] - where - forgeStateUpdateError' :: Object - forgeStateUpdateError' = - hcollapse - . hcmap (Proxy @(ToObject `Compose` WrapForgeStateUpdateError)) - (K . toObject verb) - . getOneEraForgeStateUpdateError - $ forgeStateUpdateError - -instance ToObject (ForgeStateUpdateError blk) => ToObject (WrapForgeStateUpdateError blk) where - toObject verb = toObject verb . unwrapForgeStateUpdateError - --- --- Instances for HardForkNodeToClientVersion --- - -instance ( ToJSON (BlockNodeToClientVersion x) - , All (ToJSON `Compose` EraNodeToClientVersion) (x ': xs) - ) => ToJSON (HardForkNodeToClientVersion (x ': xs)) where - toJSON (HardForkNodeToClientDisabled blockNodeToClientVersion) = - object [ "tag" .= String "HardForkNodeToClientDisabled" - , "contents" .= toJSON blockNodeToClientVersion - ] - toJSON (HardForkNodeToClientEnabled hfNodeToClientVersion eraNodeToClientVersions) = - object [ "tag" .= String "HardForkNodeToClientEnabled" - , "hardForkSpecificNodeToClientVersion" .= toJSON hfNodeToClientVersion - , "eraNodeToClientVersions" .= hcollapse eraNodeToClientVersionsAsJSON - ] - where - eraNodeToClientVersionsAsJSON :: NP (K Value) (x ': xs) - eraNodeToClientVersionsAsJSON = hcmap (Proxy @(ToJSON `Compose` EraNodeToClientVersion)) - (K . toJSON) - eraNodeToClientVersions - -instance ToJSON HardForkSpecificNodeToClientVersion where - toJSON HardForkSpecificNodeToClientVersion3 = String "HardForkSpecificNodeToClientVersion3" - -instance (ToJSON (BlockNodeToClientVersion blk)) => ToJSON (EraNodeToClientVersion blk) where - toJSON EraNodeToClientDisabled = String "EraNodeToClientDisabled" - toJSON (EraNodeToClientEnabled blockNodeToClientVersion) = toJSON blockNodeToClientVersion - --- --- Instances for HardForkNodeToNodeVersion --- -instance ( ToJSON (BlockNodeToNodeVersion x) - , All (ToJSON `Compose` WrapNodeToNodeVersion) (x ': xs) - ) => ToJSON (HardForkNodeToNodeVersion (x ': xs)) where - toJSON (HardForkNodeToNodeDisabled blockNodeToNodeVersion) = - object [ "tag" .= String "HardForkNodeToNodeDisabled" - , "contents" .= toJSON blockNodeToNodeVersion - ] - toJSON (HardForkNodeToNodeEnabled hfNodeToNodeVersion eraNodeToNodeVersions) = - object [ "tag" .= String "HardForkNodeToNodeEnabled" - , "hardForkSpecificNodeToNodeVersion" .= toJSON hfNodeToNodeVersion - , "eraNodeToNodeVersions" .= hcollapse eraNodeToNodeVersionsAsJSON - ] - where - eraNodeToNodeVersionsAsJSON :: NP (K Value) (x ': xs) - eraNodeToNodeVersionsAsJSON = hcmap (Proxy @(ToJSON `Compose` WrapNodeToNodeVersion)) - (K . toJSON) - eraNodeToNodeVersions - -instance ToJSON HardForkSpecificNodeToNodeVersion where - toJSON HardForkSpecificNodeToNodeVersion1 = "HardForkSpecificNodeToNodeVersion1" - -instance (ToJSON (BlockNodeToNodeVersion blk)) => ToJSON (WrapNodeToNodeVersion blk) where - toJSON (WrapNodeToNodeVersion blockNodeToNodeVersion) = toJSON blockNodeToNodeVersion - --- --- instances for HardForkSelectView --- - -instance All (ToObject `Compose` WrapTiebreakerView) xs => ToObject (HardForkTiebreakerView xs) where - toObject verb = toObject verb . getHardForkTiebreakerView - -instance ToObject (TiebreakerView protocol) => ToObject (WeightedSelectView protocol) where - toObject verb sv = mconcat - [ "blockNo" .= wsvBlockNo sv - , "weightBoost" .= unPerasWeight (wsvWeightBoost sv) - , toObject verb (wsvTiebreaker sv) - ] - -instance All (ToObject `Compose` WrapTiebreakerView) xs => ToObject (OneEraTiebreakerView xs) where - toObject verb = - hcollapse - . hcmap (Proxy @(ToObject `Compose` WrapTiebreakerView)) - (K . toObject verb) - . getOneEraTiebreakerView - -instance ToObject (TiebreakerView (BlockProtocol blk)) => ToObject (WrapTiebreakerView blk) where - toObject verb = toObject verb . unwrapTiebreakerView diff --git a/cardano-node/src/Cardano/Tracing/OrphanInstances/Network.hs b/cardano-node/src/Cardano/Tracing/OrphanInstances/Network.hs deleted file mode 100644 index 718d09931c3..00000000000 --- a/cardano-node/src/Cardano/Tracing/OrphanInstances/Network.hs +++ /dev/null @@ -1,2369 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE QuantifiedConstraints #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - -{-# OPTIONS_GHC -Wno-orphans #-} - -module Cardano.Tracing.OrphanInstances.Network - ( Verbose (..) - , FetchDecisionToJSON (..) - ) where - - -import Cardano.Network.Diffusion (CardanoDebugPeerSelection, CardanoPeerSelectionCounters, - CardanoTraceLocalRootPeers, TraceChurnMode (..)) -import qualified Cardano.Network.NodeToClient as NtC -import Cardano.Network.NodeToNode (RemoteAddress, TraceSendRecv (..)) -import qualified Cardano.Network.NodeToNode as NtN -import Cardano.Network.OrphanInstances () -import qualified Cardano.Network.PeerSelection as Cardano -import qualified Cardano.Network.PeerSelection.ExtraRootPeers as Cardano -import qualified Cardano.Network.PeerSelection.ExtraRootPeers as Cardano.PublicRootPeers -import Cardano.Network.PeerSelection.PublicRootPeers (PublicRootPeers (..)) -import Cardano.Node.Queries (ConvertTxId) -import Cardano.Tracing.OrphanInstances.Common -import Cardano.Tracing.Render -import Ouroboros.Consensus.Block (ConvertRawHash (..), Header, getHeader) -import Ouroboros.Consensus.Ledger.Query (BlockQuery, Query) -import Ouroboros.Consensus.Ledger.SupportsMempool (ApplyTxErr, GenTx, GenTxId, - HasTxs (..), TxId, txId) -import Ouroboros.Consensus.Node.Run (RunNode, estimateBlockSize) -import qualified Ouroboros.Network.AnchoredFragment as AF -import qualified Ouroboros.Network.AnchoredSeq as AS -import Ouroboros.Network.Block -import Ouroboros.Network.BlockFetch.ClientState (TraceFetchClientState, - TraceLabelPeer (..)) -import qualified Ouroboros.Network.BlockFetch.ClientState as BlockFetch -import Ouroboros.Network.BlockFetch.Decision (FetchDecision, FetchDecline (..)) -import qualified Ouroboros.Network.BlockFetch.Decision.Trace as BlockFetch -import Ouroboros.Network.ConnectionHandler (ConnectionHandlerTrace (..)) -import Ouroboros.Network.ConnectionId (ConnectionId (..)) -import Ouroboros.Network.ConnectionManager.ConnMap (ConnMap (..)) -import Ouroboros.Network.ConnectionManager.Core as ConnMgr (Trace (..)) -import Ouroboros.Network.ConnectionManager.State (ConnStateId (..)) -import qualified Ouroboros.Network.ConnectionManager.Types as ConnMgr -import Ouroboros.Network.DeltaQ (GSV (..), PeerGSV (..)) -import qualified Ouroboros.Network.Diffusion.Types as Diffusion -import qualified Ouroboros.Network.Driver.Stateful as Stateful -import qualified Ouroboros.Network.InboundGovernor as InboundGovernor -import qualified Ouroboros.Network.InboundGovernor.State as InboundGovernor -import Ouroboros.Network.KeepAlive (TraceKeepAliveClient (..)) -import Ouroboros.Network.OrphanInstances () -import Ouroboros.Network.PeerSelection.Governor (DebugPeerSelection (..), - DebugPeerSelectionState (..), PeerSelectionCounters, PeerSelectionState (..), - PeerSelectionTargets (..), PeerSelectionView (..), TracePeerSelection (..), - peerSelectionStateToCounters) -import Ouroboros.Network.PeerSelection.LedgerPeers -import Ouroboros.Network.PeerSelection.PeerStateActions (PeerSelectionActionsTrace (..)) -import Ouroboros.Network.PeerSelection.RootPeersDNS.DNSActions (DNSTrace (..)) -import Ouroboros.Network.PeerSelection.RootPeersDNS.LocalRootPeers - (TraceLocalRootPeers (..)) -import Ouroboros.Network.PeerSelection.RootPeersDNS.PublicRootPeers - (TracePublicRootPeers (..)) -import qualified Ouroboros.Network.PeerSelection.State.KnownPeers as KnownPeers -import Ouroboros.Network.Protocol.BlockFetch.Type (BlockFetch, Message (..)) -import Ouroboros.Network.Protocol.ChainSync.Type (ChainSync) -import qualified Ouroboros.Network.Protocol.ChainSync.Type as ChainSync -import qualified Ouroboros.Network.Protocol.KeepAlive.Type as KA -import Ouroboros.Network.Protocol.LocalStateQuery.Type (LocalStateQuery) -import qualified Ouroboros.Network.Protocol.LocalStateQuery.Type as LocalStateQuery -import Ouroboros.Network.Protocol.LocalTxMonitor.Type (LocalTxMonitor) -import qualified Ouroboros.Network.Protocol.LocalTxMonitor.Type as LocalTxMonitor -import Ouroboros.Network.Protocol.LocalTxSubmission.Type (LocalTxSubmission) -import qualified Ouroboros.Network.Protocol.LocalTxSubmission.Type as LocalTxSub -import Ouroboros.Network.Protocol.PeerSharing.Type (PeerSharingAmount (..)) -import qualified Ouroboros.Network.Protocol.PeerSharing.Type as PeerSharing -import Ouroboros.Network.Protocol.TxSubmission2.Type as TxSubmission2 -import Ouroboros.Network.RethrowPolicy (ErrorCommand (..)) -import Ouroboros.Network.Server as Server -import Ouroboros.Network.Snocket (LocalAddress (..)) -import Ouroboros.Network.TxSubmission.Inbound.V2 (ProcessedTxCount (..), - TraceTxLogic (..), TraceTxSubmissionInbound (..), TxDecision (..), - TxSubmissionCounters (..), TxsToMempool (..)) -import Ouroboros.Network.TxSubmission.Outbound (TraceTxSubmissionOutbound (..)) - -import Control.Exception (Exception (..)) -import Control.Monad.Class.MonadTime.SI (DiffTime, Time (..)) -import Data.Aeson (ToJSONKey (..), Value (..)) -import qualified Data.Aeson as Aeson -import Data.Aeson.Types (listValue) -import Data.Bifunctor (Bifunctor (first)) -import Data.Foldable (Foldable (..)) -import qualified Data.IP as IP -import qualified Data.Map.Strict as Map -import qualified Data.Set as Set -import Data.Text (Text, pack) -import Data.Typeable -import qualified Network.Mux as Mux -import Network.Socket (SockAddr (..)) -import Network.TypedProtocol.Codec (AnyMessage (AnyMessageAndAgency)) -import qualified Network.TypedProtocol.Stateful.Codec as Stateful - -{- HLINT ignore "Use record patterns" -} - --- --- * instances of @HasPrivacyAnnotation@ and @HasSeverityAnnotation@ --- --- NOTE: this list is sorted by the unqualified name of the outermost type. - -instance HasPrivacyAnnotation (Diffusion.DiffusionTracer ntnAddr ntcAddr) -instance HasSeverityAnnotation (Diffusion.DiffusionTracer ntnAddr ntcAddr) where - getSeverityAnnotation Diffusion.SystemdSocketConfiguration {} = Warning - getSeverityAnnotation Diffusion.UnsupportedLocalSystemdSocket {} = Warning - getSeverityAnnotation Diffusion.DiffusionErrored {} = Critical - getSeverityAnnotation _ = Info - -instance HasPrivacyAnnotation NtN.AcceptConnectionsPolicyTrace -instance HasSeverityAnnotation NtN.AcceptConnectionsPolicyTrace where - getSeverityAnnotation NtN.ServerTraceAcceptConnectionRateLimiting {} = Info - getSeverityAnnotation NtN.ServerTraceAcceptConnectionHardLimit {} = Warning - getSeverityAnnotation NtN.ServerTraceAcceptConnectionResume {} = Info - - -instance HasPrivacyAnnotation (TraceFetchClientState header) -instance HasSeverityAnnotation (TraceFetchClientState header) where - getSeverityAnnotation BlockFetch.AddedFetchRequest {} = Info - getSeverityAnnotation BlockFetch.SendFetchRequest {} = Info - getSeverityAnnotation BlockFetch.AcknowledgedFetchRequest {} = Info - getSeverityAnnotation BlockFetch.StartedFetchBatch {} = Info - getSeverityAnnotation BlockFetch.CompletedBlockFetch {} = Info - getSeverityAnnotation BlockFetch.CompletedFetchBatch {} = Info - getSeverityAnnotation BlockFetch.RejectedFetchBatch {} = Info - getSeverityAnnotation BlockFetch.ClientTerminating {} = Notice - - -instance HasPrivacyAnnotation (TraceSendRecv a) -instance HasSeverityAnnotation (TraceSendRecv a) where - getSeverityAnnotation _ = Debug - - -instance HasPrivacyAnnotation (Stateful.TraceSendRecv (LocalStateQuery blk (Point blk) (Query blk)) f) -instance HasSeverityAnnotation (Stateful.TraceSendRecv (LocalStateQuery blk (Point blk) (Query blk)) f) where - getSeverityAnnotation _ = Debug - - -instance HasPrivacyAnnotation a => HasPrivacyAnnotation (TraceLabelPeer peer a) -instance HasSeverityAnnotation a => HasSeverityAnnotation (TraceLabelPeer peer a) where - getSeverityAnnotation (TraceLabelPeer _p a) = getSeverityAnnotation a - - -instance HasPrivacyAnnotation [TraceLabelPeer peer (FetchDecision [Point header])] -instance HasSeverityAnnotation [TraceLabelPeer peer (FetchDecision [Point header])] where - getSeverityAnnotation [] = Debug - getSeverityAnnotation xs = - maximum $ map (\(TraceLabelPeer _ a) -> fetchDecisionSeverity a) xs - where - fetchDecisionSeverity :: FetchDecision a -> Severity - fetchDecisionSeverity fd = - case fd of - Left FetchDeclineChainNotPlausible -> Debug - Left FetchDeclineChainIntersectionTooDeep -> Notice - Left FetchDeclineAlreadyFetched -> Debug - Left FetchDeclineInFlightThisPeer -> Debug - Left FetchDeclineInFlightOtherPeer -> Debug - Left FetchDeclinePeerShutdown -> Info - Left FetchDeclinePeerStarting -> Info - Left FetchDeclinePeerSlow -> Info - Left FetchDeclineReqsInFlightLimit {} -> Info - Left FetchDeclineBytesInFlightLimit {} -> Info - Left FetchDeclinePeerBusy {} -> Info - Left FetchDeclineConcurrencyLimit {} -> Info - Right _ -> Info - - -instance HasPrivacyAnnotation (BlockFetch.TraceDecisionEvent peer header) -instance HasSeverityAnnotation (BlockFetch.TraceDecisionEvent peer header) where - getSeverityAnnotation (BlockFetch.PeersFetch xs) = getSeverityAnnotation xs - getSeverityAnnotation BlockFetch.PeerStarvedUs {} = Info - - -instance HasPrivacyAnnotation (TraceTxSubmissionInbound txid tx) -instance HasSeverityAnnotation (TraceTxSubmissionInbound txid tx) where - getSeverityAnnotation TraceTxSubmissionCollected {} = Debug - getSeverityAnnotation TraceTxSubmissionProcessed {} = Debug - getSeverityAnnotation TraceTxInboundTerminated = Notice - getSeverityAnnotation TraceTxInboundCannotRequestMoreTxs {} = Debug - getSeverityAnnotation TraceTxInboundCanRequestMoreTxs {} = Debug - getSeverityAnnotation TraceTxInboundAddedToMempool {} = Debug - getSeverityAnnotation TraceTxInboundRejectedFromMempool {} = Debug - getSeverityAnnotation TraceTxInboundError {} = Debug - getSeverityAnnotation TraceTxInboundDecision {} = Debug - - -instance HasPrivacyAnnotation (TraceTxSubmissionOutbound txid tx) -instance HasSeverityAnnotation (TraceTxSubmissionOutbound txid tx) where - getSeverityAnnotation _ = Info - - -instance HasPrivacyAnnotation (TraceKeepAliveClient remotePeer) -instance HasSeverityAnnotation (TraceKeepAliveClient remotePeer) where - getSeverityAnnotation _ = Info - - -instance HasPrivacyAnnotation TraceLedgerPeers -instance HasSeverityAnnotation TraceLedgerPeers where - getSeverityAnnotation ev = - case ev of - PickedLedgerPeer {} -> Debug - PickedLedgerPeers {} -> Info - PickedBigLedgerPeer {} -> Info - PickedBigLedgerPeers {} -> Info - FetchingNewLedgerState {} -> Info - DisabledLedgerPeers {} -> Info - TraceUseLedgerPeers {} -> Info - WaitingOnRequest {} -> Debug - RequestForPeers {} -> Debug - ReusingLedgerState {} -> Debug - FallingBackToPublicRootPeers {} -> Info - NotEnoughLedgerPeers {} -> Warning - NotEnoughBigLedgerPeers {} -> Warning - TraceLedgerPeersDomains {} -> Debug - - UsingBigLedgerPeerSnapshot {} -> Debug - - -instance HasPrivacyAnnotation (Mux.WithBearer peer Mux.Trace) -instance HasSeverityAnnotation (Mux.WithBearer peer Mux.Trace) where - getSeverityAnnotation (Mux.WithBearer _ ev) = case ev of - Mux.TraceState {} -> Info - Mux.TraceCleanExit {} -> Notice - Mux.TraceExceptionExit {} -> Notice - Mux.TraceStartEagerly _ _ -> Info - Mux.TraceStartOnDemand _ _ -> Info - Mux.TraceStartedOnDemand _ _ -> Info - Mux.TraceStartOnDemandAny {} -> Info - Mux.TraceTerminating {} -> Debug - Mux.TraceStopping -> Debug - Mux.TraceStopped -> Debug - Mux.TraceNewMux{} -> Info - Mux.TraceStarting{} -> Info - -instance HasPrivacyAnnotation (Mux.WithBearer peer Mux.ChannelTrace) -instance HasSeverityAnnotation (Mux.WithBearer peer Mux.ChannelTrace) where - getSeverityAnnotation (Mux.WithBearer _ ev) = case ev of - Mux.TraceChannelRecvStart {} -> Debug - Mux.TraceChannelRecvEnd {} -> Debug - Mux.TraceChannelSendStart {} -> Debug - Mux.TraceChannelSendEnd {} -> Debug - -instance HasPrivacyAnnotation (Mux.WithBearer peer Mux.BearerTrace) -instance HasSeverityAnnotation (Mux.WithBearer peer Mux.BearerTrace) where - getSeverityAnnotation (Mux.WithBearer _ ev) = case ev of - Mux.TraceRecvHeaderStart -> Debug - Mux.TraceRecvHeaderEnd {} -> Debug - Mux.TraceRecvStart {} -> Debug - Mux.TraceRecvRaw {} -> Debug - Mux.TraceRecvEnd {} -> Debug - Mux.TraceSendStart {} -> Debug - Mux.TraceSendEnd -> Debug - Mux.TraceEmitDeltaQ -> Debug - Mux.TraceRecvDeltaQObservation {} -> Debug - Mux.TraceRecvDeltaQSample {} -> Debug - Mux.TraceSDUReadTimeoutException -> Notice - Mux.TraceSDUWriteTimeoutException -> Notice - Mux.TraceTCPInfo {} -> Debug - -instance HasPrivacyAnnotation (Mux.WithBearer peer (TraceSendRecv a)) -instance HasSeverityAnnotation (Mux.WithBearer peer (TraceSendRecv a)) - -instance HasPrivacyAnnotation CardanoTraceLocalRootPeers -instance HasSeverityAnnotation CardanoTraceLocalRootPeers where - getSeverityAnnotation _ = Info - -instance HasPrivacyAnnotation TracePublicRootPeers -instance HasSeverityAnnotation TracePublicRootPeers where - getSeverityAnnotation _ = Info - -instance HasPrivacyAnnotation (TracePeerSelection extraDebugState extraFlags extraPeers ntnAddr) where -instance HasSeverityAnnotation (TracePeerSelection extraDebugState extraFlags extraPeers ntnAddr) where - getSeverityAnnotation ev = - case ev of - TraceLocalRootPeersChanged {} -> Notice - TraceTargetsChanged {} -> Notice - TracePublicRootsRequest {} -> Info - TracePublicRootsResults {} -> Info - TracePublicRootsFailure {} -> Error - TracePeerShareRequests {} -> Info - TracePeerShareResults {} -> Info - TracePeerShareResultsFiltered {} -> Debug - TracePickInboundPeers {} -> Info - TraceForgetColdPeers {} -> Info - TracePromoteColdPeers {} -> Info - TracePromoteColdLocalPeers {} -> Info - TracePromoteColdFailed {} -> Info - TracePromoteColdDone {} -> Info - TracePromoteWarmPeers {} -> Info - TracePromoteWarmLocalPeers {} -> Info - TracePromoteWarmFailed {} -> Info - TracePromoteWarmDone {} -> Info - TracePromoteWarmAborted {} -> Info - TraceDemoteWarmPeers {} -> Info - TraceDemoteWarmFailed {} -> Info - TraceDemoteWarmDone {} -> Info - TraceDemoteHotPeers {} -> Info - TraceDemoteLocalHotPeers {} -> Info - TraceDemoteHotFailed {} -> Info - TraceDemoteHotDone {} -> Info - TraceDemoteAsynchronous {} -> Info - TraceDemoteLocalAsynchronous {} -> Warning - TraceGovernorWakeup {} -> Info - TraceChurnWait {} -> Info - - TraceForgetBigLedgerPeers {} -> Info - - TraceBigLedgerPeersRequest {} -> Info - TraceBigLedgerPeersResults {} -> Info - TraceBigLedgerPeersFailure {} -> Error - - TracePromoteColdBigLedgerPeers {} -> Info - TracePromoteColdBigLedgerPeerFailed {} -> Info - TracePromoteColdBigLedgerPeerDone {} -> Info - - TracePromoteWarmBigLedgerPeers {} -> Info - TracePromoteWarmBigLedgerPeerFailed {} -> Error - TracePromoteWarmBigLedgerPeerDone {} -> Info - TracePromoteWarmBigLedgerPeerAborted {} -> Info - - TraceDemoteWarmBigLedgerPeers {} -> Info - TraceDemoteWarmBigLedgerPeerFailed {} -> Info - TraceDemoteWarmBigLedgerPeerDone {} -> Info - - TraceDemoteHotBigLedgerPeers {} -> Info - TraceDemoteHotBigLedgerPeerFailed {} -> Info - TraceDemoteHotBigLedgerPeerDone {} -> Info - - TraceDemoteBigLedgerPeersAsynchronous {} -> Warning - - TraceBootstrapPeersFlagChangedWhilstInSensitiveState -> Info - - TraceOnlyBootstrapPeers {} -> Notice - - TraceOutboundGovernorCriticalFailure {} -> Error - - TraceChurnAction {} -> Info - TraceChurnTimeout {} -> Notice - - TraceDebugState {} -> Info - - TraceVerifyPeerSnapshot True -> Info - TraceVerifyPeerSnapshot False -> Error - - ExtraTrace {} -> Info - -instance HasPrivacyAnnotation CardanoDebugPeerSelection -instance HasSeverityAnnotation CardanoDebugPeerSelection where - getSeverityAnnotation _ = Debug - -instance HasPrivacyAnnotation (PeerSelectionActionsTrace SockAddr lAddr) -instance HasSeverityAnnotation (PeerSelectionActionsTrace SockAddr lAddr) where - getSeverityAnnotation ev = - case ev of - PeerStatusChanged {} -> Info - PeerHotDuration {} -> Info - PeerStatusChangeFailure {} -> Error - PeerMonitoringError {} -> Error - PeerMonitoringResult {} -> Debug - AcquireConnectionError {} -> Error - -instance HasPrivacyAnnotation (PeerSelectionCounters extraCounters) -instance HasSeverityAnnotation (PeerSelectionCounters extraCounters) where - getSeverityAnnotation _ = Info - -instance HasPrivacyAnnotation (ConnMgr.Trace addr connTrace) -instance HasSeverityAnnotation (ConnMgr.Trace addr (ConnectionHandlerTrace versionNumber agreedOptions)) where - getSeverityAnnotation ev = - case ev of - TrIncludeConnection {} -> Debug - TrReleaseConnection {} -> Debug - TrConnect {} -> Debug - TrConnectError {} -> Info - TrTerminatingConnection {} -> Debug - TrTerminatedConnection {} -> Debug - TrConnectionHandler _ ev' -> - case ev' of - TrHandshakeSuccess {} -> Info - TrHandshakeQuery {} -> Info - TrHandshakeClientError {} -> Notice - TrHandshakeServerError {} -> Info - TrConnectionHandlerError _ _ ShutdownNode -> Critical - TrConnectionHandlerError _ _ ShutdownPeer -> Info - - TrShutdown -> Info - TrConnectionExists {} -> Info - TrForbiddenConnection {} -> Info - TrConnectionFailure {} -> Info - TrConnectionNotFound {} -> Debug - TrForbiddenOperation {} -> Info - - TrPruneConnections {} -> Notice - TrConnectionCleanup {} -> Debug - TrConnectionTimeWait {} -> Debug - TrConnectionTimeWaitDone {} -> Debug - TrConnectionManagerCounters {} -> Info - TrState {} -> Info - ConnMgr.TrUnexpectedlyFalseAssertion {} -> Error - TrInboundConnectionNotFound {} -> Info - -instance HasPrivacyAnnotation (ConnMgr.AbstractTransitionTrace addr) -instance HasSeverityAnnotation (ConnMgr.AbstractTransitionTrace addr) where - getSeverityAnnotation _ = Debug - -instance HasPrivacyAnnotation (Server.Trace addr) -instance HasSeverityAnnotation (Server.Trace addr) where - getSeverityAnnotation ev = - case ev of - Server.TrAcceptConnection {} -> Debug - Server.TrAcceptError {} -> Error - Server.TrAcceptPolicyTrace {} -> Notice - Server.TrServerStarted {} -> Notice - Server.TrServerStopped {} -> Notice - Server.TrServerError {} -> Critical - -instance HasPrivacyAnnotation (InboundGovernor.Trace addr) -instance HasSeverityAnnotation (InboundGovernor.Trace addr) where - getSeverityAnnotation ev = - case ev of - InboundGovernor.TrNewConnection {} -> Debug - InboundGovernor.TrResponderRestarted {} -> Debug - InboundGovernor.TrResponderStartFailure {} -> Info - InboundGovernor.TrResponderErrored {} -> Info - InboundGovernor.TrResponderStarted {} -> Debug - InboundGovernor.TrResponderTerminated {} -> Debug - InboundGovernor.TrPromotedToWarmRemote {} -> Info - InboundGovernor.TrPromotedToHotRemote {} -> Info - InboundGovernor.TrDemotedToColdRemote {} -> Info - InboundGovernor.TrDemotedToWarmRemote {} -> Info - InboundGovernor.TrWaitIdleRemote {} -> Debug - InboundGovernor.TrMuxCleanExit {} -> Debug - InboundGovernor.TrMuxErrored {} -> Info - InboundGovernor.TrInboundGovernorCounters {} -> Info - InboundGovernor.TrRemoteState {} -> Debug - InboundGovernor.TrUnexpectedlyFalseAssertion {} - -> Error - InboundGovernor.TrInboundGovernorError {} -> Error - InboundGovernor.TrMaturedConnections {} -> Info - InboundGovernor.TrInactive {} -> Debug - -instance HasPrivacyAnnotation (Server.RemoteTransitionTrace addr) -instance HasSeverityAnnotation (Server.RemoteTransitionTrace addr) where - getSeverityAnnotation _ = Debug - --- --- | instances of @Transformable@ --- --- NOTE: this list is sorted by the unqualified name of the outermost type. - -instance Transformable Text IO (Diffusion.DiffusionTracer RemoteAddress LocalAddress) where - trTransformer = trStructuredText -instance HasTextFormatter (Diffusion.DiffusionTracer RemoteAddress LocalAddress) where - formatText a _ = pack (show a) - - -instance Transformable Text IO NtN.AcceptConnectionsPolicyTrace where - trTransformer = trStructuredText -instance HasTextFormatter NtN.AcceptConnectionsPolicyTrace where - formatText a _ = pack (show a) - -instance (StandardHash header, Show peer, ToJSON peer, ConvertRawHash header, ToJSON (HeaderHash header)) - => Transformable Text IO [TraceLabelPeer peer (FetchDecision [Point header])] where - trTransformer = trStructuredText -instance (StandardHash header, Show peer) - => HasTextFormatter [TraceLabelPeer peer (FetchDecision [Point header])] where - formatText a _ = pack (show a) - -instance (HasHeader header, ConvertRawHash header, ToObject peer) - => Transformable Text IO (TraceLabelPeer peer (TraceFetchClientState header)) where - trTransformer = trStructured -instance (Show header, StandardHash header, Show peer) - => HasTextFormatter (TraceLabelPeer peer (TraceFetchClientState header)) where - formatText a _ = pack (show a) - -instance (StandardHash header, Show peer, ToJSON peer, ConvertRawHash header, ToJSON (HeaderHash header)) - => Transformable Text IO (BlockFetch.TraceDecisionEvent peer header) where - trTransformer = trStructuredText -instance (StandardHash header, Show peer) - => HasTextFormatter (BlockFetch.TraceDecisionEvent peer header) where - formatText a _ = pack (show a) - -instance ToObject peer - => Transformable Text IO (TraceLabelPeer peer (NtN.TraceSendRecv (ChainSync (Header blk) (Point blk) (Tip blk)))) where - trTransformer = trStructured -instance (Show peer, StandardHash blk, Show (Header blk)) - => HasTextFormatter (TraceLabelPeer peer (NtN.TraceSendRecv (ChainSync (Header blk) (Point blk) (Tip blk)))) where - formatText a _ = pack (show a) - -instance (ToObject peer, ToObject (AnyMessage (TraceTxSubmissionInbound (GenTxId blk) (GenTx blk)))) - => Transformable Text IO (TraceLabelPeer peer (NtN.TraceSendRecv (TraceTxSubmissionInbound (GenTxId blk) (GenTx blk)))) where - trTransformer = trStructured - -instance (ToObject peer, ToJSON txid, ToObject (TxDecision txid tx)) - => Transformable Text IO (TraceLabelPeer peer (TraceTxSubmissionInbound txid tx)) where - trTransformer = trStructured - -instance (ToObject peer, ConvertTxId blk, RunNode blk, HasTxs blk) - => Transformable Text IO (TraceLabelPeer peer (NtN.TraceSendRecv (BlockFetch blk (Point blk)))) where - trTransformer = trStructured - -instance ToObject localPeer - => Transformable Text IO (TraceLabelPeer localPeer (NtN.TraceSendRecv (ChainSync (Serialised blk) (Point blk) (Tip blk)))) where - trTransformer = trStructured - -instance (applyTxErr ~ ApplyTxErr blk, ToObject localPeer) - => Transformable Text IO (TraceLabelPeer localPeer (NtN.TraceSendRecv (LocalTxMonitor (GenTxId blk) (GenTx blk) SlotNo))) where - trTransformer = trStructured - -instance (applyTxErr ~ ApplyTxErr blk, ToObject localPeer) - => Transformable Text IO (TraceLabelPeer localPeer (NtN.TraceSendRecv (LocalTxSubmission (GenTx blk) applyTxErr))) where - trTransformer = trStructured - -instance (forall fp. LocalStateQuery.ShowQuery (BlockQuery blk fp), ToObject localPeer) - => Transformable Text IO (TraceLabelPeer localPeer (NtN.TraceSendRecv (LocalStateQuery blk (Point blk) (Query blk)))) where - trTransformer = trStructured - -instance (ToObject localPeer) - => Transformable Text IO (TraceLabelPeer localPeer (NtN.TraceSendRecv KA.KeepAlive)) where - trTransformer = trStructured - -instance (ToObject localPeer, ToJSON addr) - => Transformable Text IO (TraceLabelPeer localPeer (NtN.TraceSendRecv (PeerSharing.PeerSharing addr))) where - trTransformer = trStructured - -instance - ( HasPrivacyAnnotation (Stateful.TraceSendRecv (LocalStateQuery blk (Point blk) (Query blk)) f) - , HasSeverityAnnotation (Stateful.TraceSendRecv (LocalStateQuery blk (Point blk) (Query blk)) f) - , forall fp. LocalStateQuery.ShowQuery (BlockQuery blk fp), ToObject localPeer) - => Transformable Text IO (TraceLabelPeer localPeer (Stateful.TraceSendRecv (LocalStateQuery blk (Point blk) (Query blk)) f)) where - trTransformer = trStructured - -instance (ToObject peer, Show (TxId (GenTx blk)), Show (GenTx blk)) - => Transformable Text IO (TraceLabelPeer peer (NtN.TraceSendRecv (TxSubmission2 (GenTxId blk) (GenTx blk)))) where - trTransformer = trStructured - -instance (ToObject peer, Show (TxId (GenTx blk)), Show (GenTx blk)) - => Transformable Text IO (TraceLabelPeer peer (TraceTxSubmissionOutbound (GenTxId blk) (GenTx blk))) where - trTransformer = trStructured - -instance (Show tx, Show txid, ToJSON txid, ToObject (TxDecision txid tx)) => Transformable Text IO (TraceTxSubmissionInbound txid tx) where - trTransformer = trStructuredText -instance (Show tx, Show txid) => HasTextFormatter (TraceTxSubmissionInbound txid tx) where - formatText a _ = pack (show a) - - -instance (Show tx, Show txid) - => Transformable Text IO (TraceTxSubmissionOutbound txid tx) where - trTransformer = trStructuredText -instance (Show tx, Show txid) - => HasTextFormatter (TraceTxSubmissionOutbound txid tx) where - formatText a _ = pack (show a) - - -instance Show addr - => Transformable Text IO (TraceKeepAliveClient addr) where - trTransformer = trStructuredText -instance Show addr - => HasTextFormatter (TraceKeepAliveClient addr) where - formatText a _ = pack (show a) - - -instance Transformable Text IO TraceLedgerPeers where - trTransformer = trStructuredText -instance HasTextFormatter TraceLedgerPeers where - formatText _ = pack . show . toList - - -instance ( Show peer - , Show tr - , HasPrivacyAnnotation (Mux.WithBearer peer tr) - , HasSeverityAnnotation (Mux.WithBearer peer tr) - , ToObject (Mux.WithBearer peer tr)) - => Transformable Text IO (Mux.WithBearer peer tr) where - trTransformer = trStructuredText -instance (Show peer, Show tr) - => HasTextFormatter (Mux.WithBearer peer tr) where - formatText (Mux.WithBearer peer ev) _o = - "Bearer on " <> pack (show peer) - <> " event: " <> pack (show ev) - - -instance Transformable Text IO CardanoTraceLocalRootPeers where - trTransformer = trStructuredText -instance HasTextFormatter CardanoTraceLocalRootPeers where - formatText a _ = pack (show a) - -instance Transformable Text IO TracePublicRootPeers where - trTransformer = trStructuredText -instance HasTextFormatter TracePublicRootPeers where - formatText a _ = pack (show a) - -instance - ( ( ToJSON - ( PublicRootPeers - (Cardano.PublicRootPeers.ExtraPeers SockAddr) - addr - ) - ) - , ToJSON addr - , ToJSONKey addr - , Ord addr - , Show addr - ) => - Transformable Text IO (TracePeerSelection Cardano.DebugPeerSelectionState Cardano.PeerTrustable (Cardano.ExtraPeers addr) addr) where - trTransformer = trStructuredText -instance (Ord addr, Show addr) => HasTextFormatter (TracePeerSelection Cardano.DebugPeerSelectionState Cardano.PeerTrustable (Cardano.ExtraPeers addr) addr) where - formatText a _ = pack (show a) - -instance Transformable Text IO CardanoDebugPeerSelection where - trTransformer = trStructuredText -instance HasTextFormatter CardanoDebugPeerSelection where - -- One can only change what is logged with respect to verbosity using json - -- format. - formatText _ obj = pack (show obj) - -instance Show lAddr => Transformable Text IO (PeerSelectionActionsTrace SockAddr lAddr) where - trTransformer = trStructuredText -instance Show lAddr => HasTextFormatter (PeerSelectionActionsTrace SockAddr lAddr) where - formatText a _ = pack (show a) - -instance Transformable Text IO CardanoPeerSelectionCounters where - trTransformer = trStructuredText -instance Show extraCounters => HasTextFormatter (PeerSelectionCounters extraCounters) where - formatText a _ = pack (show a) - -instance (Show addr, Show versionNumber, Show agreedOptions, ToObject addr, - ToJSON addr, ToJSON versionNumber, ToJSON agreedOptions - ) - => Transformable Text IO (ConnMgr.Trace - addr - (ConnectionHandlerTrace versionNumber agreedOptions)) where - trTransformer = trStructuredText -instance (Show addr, Show versionNumber, Show agreedOptions) - => HasTextFormatter (ConnMgr.Trace - addr - (ConnectionHandlerTrace versionNumber agreedOptions)) where - formatText a _ = pack (show a) - -instance (Show addr, ToJSON addr, ToObject addr) - => Transformable Text IO (ConnMgr.AbstractTransitionTrace addr) where - trTransformer = trStructuredText -instance Show addr - => HasTextFormatter (ConnMgr.AbstractTransitionTrace addr) where - formatText a _ = pack (show a) - -instance (Show addr, ToObject addr, ToJSON addr) - => Transformable Text IO (Server.Trace addr) where - trTransformer = trStructuredText -instance Show addr - => HasTextFormatter (Server.Trace addr) where - formatText a _ = pack (show a) - -instance (ToJSON addr, Show addr, Aeson.ToJSONKey addr) - => Transformable Text IO (InboundGovernor.Trace addr) where - trTransformer = trStructuredText -instance Show addr - => HasTextFormatter (InboundGovernor.Trace addr) where - formatText a _ = pack (show a) - -instance (Show addr, ToJSON addr) - => Transformable Text IO (Server.RemoteTransitionTrace addr) where - trTransformer = trStructuredText -instance Show addr - => HasTextFormatter (Server.RemoteTransitionTrace addr) where - formatText a _ = pack (show a) - -instance (Show txid, Show tx, Show addr) - => Transformable Text IO (TraceTxLogic txid tx addr) where - trTransformer = trStructuredText -instance (Show txid, Show tx, Show addr) - => HasTextFormatter (TraceTxLogic txid tx addr) where - formatText a _ = pack (show a) - -instance Transformable Text IO TxSubmissionCounters where - trTransformer = trStructuredText -instance HasTextFormatter TxSubmissionCounters where - formatText a _ = pack (show a) - -instance (Show txid, Show tx, Show addr, Show peer, ToObject peer) - => Transformable Text IO (TraceLabelPeer peer (TraceTxLogic txid tx addr)) where - trTransformer = trStructuredText -instance (Show txid, Show tx, Show addr, Show peer) - => HasTextFormatter (TraceLabelPeer peer (TraceTxLogic txid tx addr)) where - formatText a _ = pack (show a) - - --- --- | instances of @ToObject@ --- --- NOTE: this list is sorted by the unqualified name of the outermost type. - -instance ( ConvertTxId blk - , RunNode blk - , HasTxs blk - ) - => ToObject (AnyMessage (BlockFetch blk (Point blk))) where - toObject MinimalVerbosity (AnyMessageAndAgency stok (MsgBlock blk)) = - mconcat [ "kind" .= String "MsgBlock" - , "agency" .= String (pack $ show stok) - , "blockHash" .= renderHeaderHash (Proxy @blk) (blockHash blk) - , "blockSize" .= toJSON (getSizeInBytes $ estimateBlockSize (getHeader blk)) - ] - - toObject verb (AnyMessageAndAgency stok (MsgBlock blk)) = - mconcat [ "kind" .= String "MsgBlock" - , "agency" .= String (pack $ show stok) - , "blockHash" .= renderHeaderHash (Proxy @blk) (blockHash blk) - , "blockSize" .= toJSON (getSizeInBytes $ estimateBlockSize (getHeader blk)) - , "txIds" .= toJSON (presentTx <$> extractTxs blk) - ] - where - presentTx :: GenTx blk -> Value - presentTx = String . renderTxIdForVerbosity verb . txId - - toObject _v (AnyMessageAndAgency stok MsgRequestRange{}) = - mconcat [ "kind" .= String "MsgRequestRange" - , "agency" .= String (pack $ show stok) - ] - toObject _v (AnyMessageAndAgency stok MsgStartBatch{}) = - mconcat [ "kind" .= String "MsgStartBatch" - , "agency" .= String (pack $ show stok) - ] - toObject _v (AnyMessageAndAgency stok MsgNoBlocks{}) = - mconcat [ "kind" .= String "MsgNoBlocks" - , "agency" .= String (pack $ show stok) - ] - toObject _v (AnyMessageAndAgency stok MsgBatchDone{}) = - mconcat [ "kind" .= String "MsgBatchDone" - , "agency" .= String (pack $ show stok) - ] - toObject _v (AnyMessageAndAgency stok MsgClientDone{}) = - mconcat [ "kind" .= String "MsgClientDone" - , "agency" .= String (pack $ show stok) - ] - -instance (forall result. Show (query result)) - => ToObject (AnyMessage (LocalStateQuery blk pt query)) where - toObject _verb (AnyMessageAndAgency stok LocalStateQuery.MsgAcquire{}) = - mconcat [ "kind" .= String "MsgAcquire" - , "agency" .= String (pack $ show stok) - ] - toObject _verb (AnyMessageAndAgency stok LocalStateQuery.MsgAcquired{}) = - mconcat [ "kind" .= String "MsgAcquired" - , "agency" .= String (pack $ show stok) - ] - toObject _verb (AnyMessageAndAgency stok LocalStateQuery.MsgFailure{}) = - mconcat [ "kind" .= String "MsgFailure" - , "agency" .= String (pack $ show stok) - ] - toObject _verb (AnyMessageAndAgency stok LocalStateQuery.MsgQuery{}) = - mconcat [ "kind" .= String "MsgQuery" - , "agency" .= String (pack $ show stok) - ] - toObject _verb (AnyMessageAndAgency stok LocalStateQuery.MsgResult{}) = - mconcat [ "kind" .= String "MsgResult" - , "agency" .= String (pack $ show stok) - ] - toObject _verb (AnyMessageAndAgency stok LocalStateQuery.MsgRelease{}) = - mconcat [ "kind" .= String "MsgRelease" - , "agency" .= String (pack $ show stok) - ] - toObject _verb (AnyMessageAndAgency stok LocalStateQuery.MsgReAcquire{}) = - mconcat [ "kind" .= String "MsgReAcquire" - , "agency" .= String (pack $ show stok) - ] - toObject _verb (AnyMessageAndAgency stok LocalStateQuery.MsgDone{}) = - mconcat [ "kind" .= String "MsgDone" - , "agency" .= String (pack $ show stok) - ] - -instance (forall result. Show (query result)) - => ToObject (Stateful.AnyMessage (LocalStateQuery blk pt query) f) where - toObject _verb (Stateful.AnyMessageAndAgency stok _ LocalStateQuery.MsgAcquire{}) = - mconcat [ "kind" .= String "MsgAcquire" - , "agency" .= String (pack $ show stok) - ] - toObject _verb (Stateful.AnyMessageAndAgency stok _ LocalStateQuery.MsgAcquired{}) = - mconcat [ "kind" .= String "MsgAcquired" - , "agency" .= String (pack $ show stok) - ] - toObject _verb (Stateful.AnyMessageAndAgency stok _ LocalStateQuery.MsgFailure{}) = - mconcat [ "kind" .= String "MsgFailure" - , "agency" .= String (pack $ show stok) - ] - toObject _verb (Stateful.AnyMessageAndAgency stok _ LocalStateQuery.MsgQuery{}) = - mconcat [ "kind" .= String "MsgQuery" - , "agency" .= String (pack $ show stok) - ] - toObject _verb (Stateful.AnyMessageAndAgency stok _ LocalStateQuery.MsgResult{}) = - mconcat [ "kind" .= String "MsgResult" - , "agency" .= String (pack $ show stok) - ] - toObject _verb (Stateful.AnyMessageAndAgency stok _ LocalStateQuery.MsgRelease{}) = - mconcat [ "kind" .= String "MsgRelease" - , "agency" .= String (pack $ show stok) - ] - toObject _verb (Stateful.AnyMessageAndAgency stok _ LocalStateQuery.MsgReAcquire{}) = - mconcat [ "kind" .= String "MsgReAcquire" - , "agency" .= String (pack $ show stok) - ] - toObject _verb (Stateful.AnyMessageAndAgency stok _ LocalStateQuery.MsgDone{}) = - mconcat [ "kind" .= String "MsgDone" - , "agency" .= String (pack $ show stok) - ] - -instance ToObject (AnyMessage (LocalTxMonitor txid tx slotno)) where - toObject _verb (AnyMessageAndAgency stok LocalTxMonitor.MsgAcquire {}) = - mconcat [ "kind" .= String "MsgAcuire" - , "agency" .= String (pack $ show stok) - ] - toObject _verb (AnyMessageAndAgency stok LocalTxMonitor.MsgAcquired {}) = - mconcat [ "kind" .= String "MsgAcuired" - , "agency" .= String (pack $ show stok) - ] - toObject _verb (AnyMessageAndAgency stok LocalTxMonitor.MsgAwaitAcquire {}) = - mconcat [ "kind" .= String "MsgAwaitAcuire" - , "agency" .= String (pack $ show stok) - ] - toObject _verb (AnyMessageAndAgency stok LocalTxMonitor.MsgNextTx {}) = - mconcat [ "kind" .= String "MsgNextTx" - , "agency" .= String (pack $ show stok) - ] - toObject _verb (AnyMessageAndAgency stok LocalTxMonitor.MsgReplyNextTx {}) = - mconcat [ "kind" .= String "MsgReplyNextTx" - , "agency" .= String (pack $ show stok) - ] - toObject _verb (AnyMessageAndAgency stok LocalTxMonitor.MsgHasTx {}) = - mconcat [ "kind" .= String "MsgHasTx" - , "agency" .= String (pack $ show stok) - ] - toObject _verb (AnyMessageAndAgency stok LocalTxMonitor.MsgReplyHasTx {}) = - mconcat [ "kind" .= String "MsgReplyHasTx" - , "agency" .= String (pack $ show stok) - ] - toObject _verb (AnyMessageAndAgency stok LocalTxMonitor.MsgGetSizes {}) = - mconcat [ "kind" .= String "MsgGetSizes" - , "agency" .= String (pack $ show stok) - ] - toObject _verb (AnyMessageAndAgency stok LocalTxMonitor.MsgReplyGetSizes {}) = - mconcat [ "kind" .= String "MsgReplyGetSizes" - , "agency" .= String (pack $ show stok) - ] - toObject _verb (AnyMessageAndAgency stok LocalTxMonitor.MsgRelease {}) = - mconcat [ "kind" .= String "MsgRelease" - , "agency" .= String (pack $ show stok) - ] - toObject _verb (AnyMessageAndAgency stok LocalTxMonitor.MsgDone {}) = - mconcat [ "kind" .= String "MsgDone" - , "agency" .= String (pack $ show stok) - ] - toObject _verb (AnyMessageAndAgency stok LocalTxMonitor.MsgGetMeasures {}) = - mconcat [ "kind" .= String "MsgGetMeasures" - , "agency" .= String (pack $ show stok) - ] - toObject _verb (AnyMessageAndAgency stok LocalTxMonitor.MsgReplyGetMeasures {}) = - mconcat [ "kind" .= String "MsgReplyMeasures" - , "agency" .= String (pack $ show stok) - ] - -instance ToObject (AnyMessage (LocalTxSubmission tx err)) where - toObject _verb (AnyMessageAndAgency stok LocalTxSub.MsgSubmitTx{}) = - mconcat [ "kind" .= String "MsgSubmitTx" - , "agency" .= String (pack $ show stok) - ] - toObject _verb (AnyMessageAndAgency stok LocalTxSub.MsgAcceptTx{}) = - mconcat [ "kind" .= String "MsgAcceptTx" - , "agency" .= String (pack $ show stok) - ] - toObject _verb (AnyMessageAndAgency stok LocalTxSub.MsgRejectTx{}) = - mconcat [ "kind" .= String "MsgRejectTx" - , "agency" .= String (pack $ show stok) - ] - toObject _verb (AnyMessageAndAgency stok LocalTxSub.MsgDone{}) = - mconcat [ "kind" .= String "MsgDone" - , "agency" .= String (pack $ show stok) - ] - -instance ToObject (AnyMessage (ChainSync blk pt tip)) where - toObject _verb (AnyMessageAndAgency stok ChainSync.MsgRequestNext{}) = - mconcat [ "kind" .= String "MsgRequestNext" - , "agency" .= String (pack $ show stok) - ] - toObject _verb (AnyMessageAndAgency stok ChainSync.MsgAwaitReply{}) = - mconcat [ "kind" .= String "MsgAwaitReply" - , "agency" .= String (pack $ show stok) - ] - toObject _verb (AnyMessageAndAgency stok ChainSync.MsgRollForward{}) = - mconcat [ "kind" .= String "MsgRollForward" - , "agency" .= String (pack $ show stok) - ] - toObject _verb (AnyMessageAndAgency stok ChainSync.MsgRollBackward{}) = - mconcat [ "kind" .= String "MsgRollBackward" - , "agency" .= String (pack $ show stok) - ] - toObject _verb (AnyMessageAndAgency stok ChainSync.MsgFindIntersect{}) = - mconcat [ "kind" .= String "MsgFindIntersect" - , "agency" .= String (pack $ show stok) - ] - toObject _verb (AnyMessageAndAgency stok ChainSync.MsgIntersectFound{}) = - mconcat [ "kind" .= String "MsgIntersectFound" - , "agency" .= String (pack $ show stok) - ] - toObject _verb (AnyMessageAndAgency stok ChainSync.MsgIntersectNotFound{}) = - mconcat [ "kind" .= String "MsgIntersectNotFound" - , "agency" .= String (pack $ show stok) - ] - toObject _verb (AnyMessageAndAgency stok ChainSync.MsgDone{}) = - mconcat [ "kind" .= String "MsgDone" - , "agency" .= String (pack $ show stok) - ] - -instance (Show txid, Show tx) - => ToObject (AnyMessage (TxSubmission2 txid tx)) where - toObject _verb (AnyMessageAndAgency stok MsgInit) = - mconcat - [ "kind" .= String "MsgInit" - , "agency" .= String (pack $ show stok) - ] - toObject _verb (AnyMessageAndAgency stok (MsgRequestTxs txids)) = - mconcat - [ "kind" .= String "MsgRequestTxs" - , "agency" .= String (pack $ show stok) - , "txIds" .= String (pack $ show txids) - ] - toObject _verb (AnyMessageAndAgency stok (MsgReplyTxs txs)) = - mconcat - [ "kind" .= String "MsgReplyTxs" - , "agency" .= String (pack $ show stok) - , "txs" .= String (pack $ show txs) - ] - toObject _verb (AnyMessageAndAgency stok MsgRequestTxIds{}) = - mconcat - [ "kind" .= String "MsgRequestTxIds" - , "agency" .= String (pack $ show stok) - ] - toObject _verb (AnyMessageAndAgency stok (MsgReplyTxIds _)) = - mconcat - [ "kind" .= String "MsgReplyTxIds" - , "agency" .= String (pack $ show stok) - ] - toObject _verb (AnyMessageAndAgency stok MsgDone) = - mconcat - [ "kind" .= String "MsgDone" - , "agency" .= String (pack $ show stok) - ] - -instance ToObject (AnyMessage KA.KeepAlive) where - toObject _verb (AnyMessageAndAgency stok KA.MsgKeepAlive {}) = - mconcat - [ "kind" .= String "MsgKeepAlive" - , "agency" .= String (pack $ show stok) - ] - toObject _verb (AnyMessageAndAgency stok KA.MsgKeepAliveResponse {}) = - mconcat - [ "kind" .= String "MsgKeepAliveResponse" - , "agency" .= String (pack $ show stok) - ] - toObject _verb (AnyMessageAndAgency stok KA.MsgDone) = - mconcat - [ "kind" .= String "MsgDone" - , "agency" .= String (pack $ show stok) - ] - -instance ToJSON peerAddr => ToObject (AnyMessage (PeerSharing.PeerSharing peerAddr)) where - toObject _verb (AnyMessageAndAgency stok (PeerSharing.MsgShareRequest num)) = - mconcat - [ "kind" .= String "MsgShareRequest" - , "agency" .= String (pack $ show stok) - , "ammount" .= PeerSharing.getAmount num - ] - toObject _verb (AnyMessageAndAgency stok (PeerSharing.MsgSharePeers peers)) = - mconcat - [ "kind" .= String "MsgSharePeers" - , "agency" .= String (pack $ show stok) - , "peers" .= peers - ] - toObject _verb (AnyMessageAndAgency stok PeerSharing.MsgDone) = - mconcat - [ "kind" .= String "MsgDone" - , "agency" .= String (pack $ show stok) - ] - - --- TODO: use 'ToJSON' constraints -instance (Show ntnAddr, Show ntcAddr) => ToObject (Diffusion.DiffusionTracer ntnAddr ntcAddr) where - toObject _verb (Diffusion.RunServer sockAddr) = mconcat - [ "kind" .= String "RunServer" - , "socketAddress" .= String (pack (show sockAddr)) - ] - - toObject _verb (Diffusion.RunLocalServer localAddress) = mconcat - [ "kind" .= String "RunLocalServer" - , "localAddress" .= String (pack (show localAddress)) - ] - toObject _verb (Diffusion.UsingSystemdSocket localAddress) = mconcat - [ "kind" .= String "UsingSystemdSocket" - , "path" .= String (pack . show $ localAddress) - ] - - toObject _verb (Diffusion.CreateSystemdSocketForSnocketPath localAddress) = mconcat - [ "kind" .= String "CreateSystemdSocketForSnocketPath" - , "path" .= String (pack . show $ localAddress) - ] - toObject _verb (Diffusion.CreatedLocalSocket localAddress) = mconcat - [ "kind" .= String "CreatedLocalSocket" - , "path" .= String (pack . show $ localAddress) - ] - toObject _verb (Diffusion.ConfiguringLocalSocket localAddress socket) = mconcat - [ "kind" .= String "ConfiguringLocalSocket" - , "path" .= String (pack . show $ localAddress) - , "socket" .= String (pack (show socket)) - ] - toObject _verb (Diffusion.ListeningLocalSocket localAddress socket) = mconcat - [ "kind" .= String "ListeningLocalSocket" - , "path" .= String (pack . show $ localAddress) - , "socket" .= String (pack (show socket)) - ] - toObject _verb (Diffusion.LocalSocketUp localAddress fd) = mconcat - [ "kind" .= String "LocalSocketUp" - , "path" .= String (pack . show $ localAddress) - , "socket" .= String (pack (show fd)) - ] - toObject _verb (Diffusion.CreatingServerSocket socket) = mconcat - [ "kind" .= String "CreatingServerSocket" - , "socket" .= String (pack (show socket)) - ] - toObject _verb (Diffusion.ListeningServerSocket socket) = mconcat - [ "kind" .= String "ListeningServerSocket" - , "socket" .= String (pack (show socket)) - ] - toObject _verb (Diffusion.ServerSocketUp socket) = mconcat - [ "kind" .= String "ServerSocketUp" - , "socket" .= String (pack (show socket)) - ] - toObject _verb (Diffusion.ConfiguringServerSocket socket) = mconcat - [ "kind" .= String "ConfiguringServerSocket" - , "socket" .= String (pack (show socket)) - ] - toObject _verb (Diffusion.UnsupportedLocalSystemdSocket path) = mconcat - [ "kind" .= String "UnsupportedLocalSystemdSocket" - , "path" .= String (pack (show path)) - ] - toObject _verb Diffusion.UnsupportedReadySocketCase = mconcat - [ "kind" .= String "UnsupportedReadySocketCase" - ] - toObject _verb (Diffusion.DiffusionErrored exception) = mconcat - [ "kind" .= String "DiffusionErrored" - , "error" .= String (pack (show exception)) - ] - toObject _verb (Diffusion.SystemdSocketConfiguration config) = mconcat - [ "kand" .= String "SystemdSocketConfiguration" - , "message" .= String (pack (show config)) - ] - - -instance ToObject NtN.AcceptConnectionsPolicyTrace where - toObject _verb (NtN.ServerTraceAcceptConnectionRateLimiting delay numOfConnections) = - mconcat [ "kind" .= String "ServerTraceAcceptConnectionRateLimiting" - , "delay" .= show delay - , "numberOfConnection" .= show numOfConnections - ] - toObject _verb (NtN.ServerTraceAcceptConnectionHardLimit softLimit) = - mconcat [ "kind" .= String "ServerTraceAcceptConnectionHardLimit" - , "softLimit" .= show softLimit - ] - toObject _verb (NtN.ServerTraceAcceptConnectionResume numOfConnections) = - mconcat [ "kind" .= String "ServerTraceAcceptConnectionResume" - , "numberOfConnection" .= show numOfConnections - ] - -newtype Verbose a = Verbose a - -instance ConvertRawHash header - => ToJSON (Verbose (Point header)) where - toJSON (Verbose GenesisPoint) = String "GenesisPoint" - toJSON (Verbose (BlockPoint (SlotNo slotNo) hash)) = - -- it is unlikely that there will be two short hashes in the same slot - String $ renderHeaderHashForVerbosity - (Proxy @header) - MaximalVerbosity - hash - <> "@" - <> pack (show slotNo) - - -instance (ConvertRawHash blk, ToJSON (HeaderHash blk)) - => ToObject (Point blk) where - toObject _verb GenesisPoint = - mconcat [ "point" .= String "GenesisPoint" ] - toObject verb point@BlockPoint{} = - mconcat [ "point" .= - case verb of - MaximalVerbosity - -> toJSON (Verbose point) - _ -> toJSON point - ] - - -instance ToObject SlotNo where - toObject _verb slot = - mconcat [ "kind" .= String "SlotNo" - , "slot" .= toJSON (unSlotNo slot) ] - -instance (ConvertRawHash blk) => ToObject (AF.Anchor blk) where - toObject verb = \case - AF.AnchorGenesis -> mconcat - [ "kind" .= String "AnchorGenesis" ] - AF.Anchor slot hash bno -> mconcat - [ "kind" .= String "Anchor" - , "slot" .= toJSON (unSlotNo slot) - , "headerHash" .= renderHeaderHashForVerbosity (Proxy @blk) verb hash - , "blockNo" .= toJSON (unBlockNo bno) - ] - -instance (ConvertRawHash blk, HasHeader blk, ToJSON (HeaderHash blk)) => ToObject (AF.AnchoredFragment blk) where - toObject verb frag = mconcat - [ "kind" .= String "AnchoredFragment" - , "anchor" .= toObject verb (AF.anchor frag) - , "headPoint" .= toObject verb (AF.headPoint frag) - , "length" .= toJSON (AF.length frag) - ] - -instance (HasHeader header, ConvertRawHash header) - => ToObject (TraceFetchClientState header) where - toObject _verb BlockFetch.AddedFetchRequest {} = - mconcat [ "kind" .= String "AddedFetchRequest" ] - toObject _verb BlockFetch.AcknowledgedFetchRequest {} = - mconcat [ "kind" .= String "AcknowledgedFetchRequest" ] - toObject _verb (BlockFetch.SendFetchRequest af gsv) = - mconcat [ "kind" .= String "SendFetchRequest" - , "head" .= String (renderChainHash - (renderHeaderHash (Proxy @header)) - (AF.headHash af)) - , "deltaq" .= toJSON gsv - , "length" .= toJSON (fragmentLength af)] - where - -- NOTE: this ignores the Byron era with its EBB complication: - -- the length would be underestimated by 1, if the AF is anchored - -- at the epoch boundary. - fragmentLength :: AF.AnchoredFragment header -> Int - fragmentLength f = fromIntegral . unBlockNo $ - case (f, f) of - (AS.Empty{}, AS.Empty{}) -> 0 - (firstHdr AS.:< _, _ AS.:> lastHdr) -> - blockNo lastHdr - blockNo firstHdr + 1 - toObject _verb (BlockFetch.CompletedBlockFetch pt _ _ _ delay blockSize) = - mconcat [ "kind" .= String "CompletedBlockFetch" - , "delay" .= (realToFrac delay :: Double) - , "size" .= getSizeInBytes blockSize - , "block" .= String - (case pt of - GenesisPoint -> "Genesis" - BlockPoint _ h -> renderHeaderHash (Proxy @header) h) - ] - toObject _verb BlockFetch.CompletedFetchBatch {} = - mconcat [ "kind" .= String "CompletedFetchBatch" ] - toObject _verb BlockFetch.StartedFetchBatch {} = - mconcat [ "kind" .= String "StartedFetchBatch" ] - toObject _verb BlockFetch.RejectedFetchBatch {} = - mconcat [ "kind" .= String "RejectedFetchBatch" ] - toObject _verb (BlockFetch.ClientTerminating outstanding) = - mconcat [ "kind" .= String "ClientTerminating" - , "outstanding" .= outstanding - ] - -instance (ToJSON peer, ConvertRawHash header, ToJSON (HeaderHash header)) - => ToObject [TraceLabelPeer peer (FetchDecision [Point header])] where - toObject MinimalVerbosity _ = mempty - toObject _ [] = mempty - toObject _ xs = mconcat - [ "kind" .= String "FetchDecisions" - , "decisions" .= toJSON xs - ] - -instance (ToObject peer, ToObject a) => ToObject (TraceLabelPeer peer a) where - toObject verb (TraceLabelPeer peerid a) = - mconcat [ "peer" .= toObject verb peerid ] <> toObject verb a - -instance (ToJSON peer, ToJSON (Verbose point)) - => ToJSON (Verbose (TraceLabelPeer peer (FetchDecision [point]))) where - toJSON (Verbose (TraceLabelPeer peer decision)) = - Aeson.object - [ "peer" .= toJSON peer - , "decision" .= toJSON (FetchDecisionToJSON $ map Verbose <$> decision) - ] - -newtype FetchDecisionToJSON point = - FetchDecisionToJSON (FetchDecision [point]) - -instance ToJSON point - => ToJSON (FetchDecisionToJSON point) where - toJSON (FetchDecisionToJSON (Left decline)) = - Aeson.object [ "declined" .= String (pack . show $ decline) ] - toJSON (FetchDecisionToJSON (Right points)) = - toJSON points - -instance (ToJSON peer, ConvertRawHash header, ToJSON (HeaderHash header)) - => ToObject (BlockFetch.TraceDecisionEvent peer header) where - toObject verb (BlockFetch.PeersFetch as) = toObject verb as - toObject _verb (BlockFetch.PeerStarvedUs peer) = mconcat - [ "kind" .= String "PeerStarvedUs" - , "peer" .= toJSON peer - ] - -instance ToObject (AnyMessage ps) - => ToObject (TraceSendRecv ps) where - toObject verb (TraceSendMsg m) = mconcat - [ "kind" .= String "Send" , "msg" .= toObject verb m ] - toObject verb (TraceRecvMsg m) = mconcat - [ "kind" .= String "Recv" , "msg" .= toObject verb m ] - - -instance ToObject (Stateful.AnyMessage ps f) - => ToObject (Stateful.TraceSendRecv ps f) where - toObject verb (Stateful.TraceSendMsg m) = mconcat - [ "kind" .= String "Send" , "msg" .= toObject verb m ] - toObject verb (Stateful.TraceRecvMsg m) = mconcat - [ "kind" .= String "Recv" , "msg" .= toObject verb m ] - - -instance (ToJSON txid, ToObject (TxDecision txid tx)) => ToObject (TraceTxSubmissionInbound txid tx) where - toObject _verb (TraceTxSubmissionCollected txids) = - mconcat - [ "kind" .= String "TxSubmissionCollected" - , "count" .= toJSON (length txids) - ] - toObject _verb (TraceTxSubmissionProcessed processed) = - mconcat - [ "kind" .= String "TxSubmissionProcessed" - , "accepted" .= toJSON (ptxcAccepted processed) - , "rejected" .= toJSON (ptxcRejected processed) - ] - toObject _verb TraceTxInboundTerminated = - mconcat - [ "kind" .= String "TxInboundTerminated" - ] - toObject _verb (TraceTxInboundCanRequestMoreTxs count) = - mconcat - [ "kind" .= String "TxInboundCanRequestMoreTxs" - , "count" .= toJSON count - ] - toObject _verb (TraceTxInboundCannotRequestMoreTxs count) = - mconcat - [ "kind" .= String "TxInboundCannotRequestMoreTxs" - , "count" .= toJSON count - ] - toObject _verb (TraceTxInboundAddedToMempool txids duration) = - mconcat - [ "kind" .= String "TraceTxInboundAddedToMempool" - , "count" .= toJSON (length txids) - , "duration" .= toJSON duration - ] - toObject _verb (TraceTxInboundRejectedFromMempool txids duration) = - mconcat - [ "kind" .= String "TraceTxInboundRejectedFromMempool" - , "count" .= toJSON (length txids) - , "duration" .= toJSON duration - ] - toObject _verb (TraceTxInboundError err) = mconcat - [ "kind" .= String "TraceTxInboundError" - , "reason" .= displayException err - ] - toObject verb (TraceTxInboundDecision decision) = mconcat - [ "kind" .= String "TraceTxInboundDecision" - , "reason" .= toObject verb decision - ] - --- TODO: use the json encoding of transactions -instance (Show txid, Show tx) - => ToObject (TraceTxSubmissionOutbound txid tx) where - toObject MaximalVerbosity (TraceTxSubmissionOutboundRecvMsgRequestTxs txids) = - mconcat - [ "kind" .= String "TxSubmissionOutboundRecvMsgRequestTxs" - , "txIds" .= String (pack $ show txids) - ] - toObject _verb (TraceTxSubmissionOutboundRecvMsgRequestTxs _txids) = - mconcat - [ "kind" .= String "TxSubmissionOutboundRecvMsgRequestTxs" - ] - toObject MaximalVerbosity (TraceTxSubmissionOutboundSendMsgReplyTxs txs) = - mconcat - [ "kind" .= String "TxSubmissionOutboundSendMsgReplyTxs" - , "txs" .= String (pack $ show txs) - ] - toObject _verb (TraceTxSubmissionOutboundSendMsgReplyTxs _txs) = - mconcat - [ "kind" .= String "TxSubmissionOutboundSendMsgReplyTxs" - ] - toObject _verb (TraceControlMessage controlMessage) = - mconcat - [ "kind" .= String "ControlMessage" - , "controlMessage" .= String (pack $ show controlMessage) - ] - - -instance Show remotePeer => ToObject (TraceKeepAliveClient remotePeer) where - toObject _verb (AddSample peer rtt pgsv) = - mconcat - [ "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 - - -instance ToObject TraceLedgerPeers where - toObject _verb (PickedBigLedgerPeer addr _ackStake stake) = - mconcat - [ "kind" .= String "PickedBigLedgerPeer" - , "address" .= show addr - , "relativeStake" .= (realToFrac (unPoolStake stake) :: Double) - ] - toObject _verb (PickedBigLedgerPeers (NumberOfPeers n) addrs) = - mconcat - [ "kind" .= String "PickedBigLedgerPeers" - , "desiredCount" .= n - , "count" .= length addrs - , "addresses" .= show addrs - ] - toObject _verb (PickedLedgerPeer addr _ackStake stake) = - mconcat - [ "kind" .= String "PickedLedgerPeer" - , "address" .= show addr - , "relativeStake" .= (realToFrac (unPoolStake stake) :: Double) - ] - toObject _verb (PickedLedgerPeers (NumberOfPeers n) addrs) = - mconcat - [ "kind" .= String "PickedLedgerPeers" - , "desiredCount" .= n - , "count" .= length addrs - , "addresses" .= show addrs - ] - toObject _verb (FetchingNewLedgerState cnt bigCnt) = - mconcat - [ "kind" .= String "FetchingNewLedgerState" - , "numberOfLedgerPeers" .= cnt - , "numberOfBigLedgerPeers" .= bigCnt - ] - toObject _verb DisabledLedgerPeers = - mconcat - [ "kind" .= String "DisabledLedgerPeers" - ] - toObject _verb (TraceUseLedgerPeers ulp) = - mconcat - [ "kind" .= String "UseLedgerPeers" - , "useLedgerPeers" .= ulp - ] - toObject _verb WaitingOnRequest = - mconcat - [ "kind" .= String "WaitingOnRequest" - ] - toObject _verb (RequestForPeers (NumberOfPeers np)) = - mconcat - [ "kind" .= String "RequestForPeers" - , "numberOfPeers" .= np - ] - toObject _verb (ReusingLedgerState cnt age) = - mconcat - [ "kind" .= String "ReusingLedgerState" - , "numberOfPools" .= cnt - , "ledgerStateAge" .= age - ] - toObject _verb FallingBackToPublicRootPeers = - mconcat - [ "kind" .= String "FallingBackToBootstrapPeers" - ] - toObject _verb (NotEnoughLedgerPeers (NumberOfPeers target) numOfLedgerPeers) = - mconcat - [ "kind" .= String "NotEnoughLedgerPeers" - , "target" .= target - , "numOfLedgerPeers" .= numOfLedgerPeers - ] - toObject _verb (NotEnoughBigLedgerPeers (NumberOfPeers target) numOfBigLedgerPeers) = - mconcat - [ "kind" .= String "NotEnoughBigLedgerPeers" - , "target" .= target - , "numOfBigLedgerPeers" .= numOfBigLedgerPeers - ] - toObject _verb (TraceLedgerPeersDomains daps) = - mconcat - [ "kind" .= String "TraceLedgerPeersDomains" - , "domainAccessPoints" .= daps - ] - toObject _verb UsingBigLedgerPeerSnapshot = - mconcat - [ "kind" .= String "UsingBigLedgerPeerSnapshot" - ] - - -instance (Typeable tr, ToObject peer, Show tr) => ToObject (Mux.WithBearer peer tr) where - toObject verb (Mux.WithBearer b ev) = - mconcat [ "kind" .= (show . typeOf $ ev) - , "bearer" .= toObject verb b - , "event" .= show ev ] - -instance ToObject CardanoTraceLocalRootPeers where - toObject _verb (TraceLocalRootDomains groups) = - mconcat [ "kind" .= String "LocalRootDomains" - , "localRootDomains" .= toJSON groups - ] - toObject _verb (TraceLocalRootWaiting d dt) = - mconcat [ "kind" .= String "LocalRootWaiting" - -- TODO: `domainAddress` -> `accessPoint` - , "domainAddress" .= toJSON d - , "diffTime" .= show dt - ] - toObject _verb (TraceLocalRootGroups groups) = - mconcat [ "kind" .= String "LocalRootGroups" - , "localRootGroups" .= toJSON groups - ] - toObject _verb (TraceLocalRootFailure d dexception) = - mconcat [ "kind" .= String "LocalRootFailure" - -- TODO: `domainAddress` -> `accessPoint` - , "domainAddress" .= toJSON d - , "reason" .= displayException dexception - ] - toObject _verb (TraceLocalRootError d dexception) = - mconcat [ "kind" .= String "LocalRootError" - -- TODO: `domainAddress` -> `domain` - , "domainAddress" .= String (pack $ show d) - , "reason" .= displayException dexception - ] - toObject _verb (TraceLocalRootReconfigured _ _) = - mconcat [ "kind" .= String "LocalRootReconfigured" - ] - toObject _verb (TraceLocalRootDNSMap dnsMap) = - mconcat - [ "kind" .= String "TraceLocalRootDNSMap" - , "dnsMap" .= dnsMap - ] - -instance ToJSON IP where - toJSON ip = String (pack . show $ ip) - -instance ToObject TracePublicRootPeers where - toObject _verb (TracePublicRootRelayAccessPoint relays) = - mconcat [ "kind" .= String "PublicRootRelayAddresses" - , "relayAddresses" .= toJSON relays - ] - toObject _verb (TracePublicRootDomains domains) = - mconcat [ "kind" .= String "PublicRootDomains" - , "domainAddresses" .= Aeson.toJSONList domains - ] - -instance - ( ToJSON - ( PublicRootPeers - (Cardano.PublicRootPeers.ExtraPeers SockAddr) - addr - ) - , Ord addr - , ToJSON addr - , ToJSONKey addr - ) => - ToObject (TracePeerSelection Cardano.DebugPeerSelectionState Cardano.PeerTrustable (Cardano.ExtraPeers addr) addr) where - toObject _verb (TraceLocalRootPeersChanged lrp lrp') = - mconcat [ "kind" .= String "LocalRootPeersChanged" - , "previous" .= toJSON lrp - , "current" .= toJSON lrp' - ] - toObject _verb (TraceTargetsChanged pst) = - mconcat [ "kind" .= String "TargetsChanged" - , "current" .= toJSON pst - ] - toObject _verb (TracePublicRootsRequest tRootPeers nRootPeers) = - mconcat [ "kind" .= String "PublicRootsRequest" - , "targetNumberOfRootPeers" .= tRootPeers - , "numberOfRootPeers" .= nRootPeers - ] - toObject _verb (TracePublicRootsResults res group dt) = - mconcat [ "kind" .= String "PublicRootsResults" - , "result" .= toJSON res - , "group" .= group - , "diffTime" .= dt - ] - toObject _verb (TracePublicRootsFailure err group dt) = - mconcat [ "kind" .= String "PublicRootsFailure" - , "reason" .= show err - , "group" .= group - , "diffTime" .= dt - ] - toObject _verb (TraceBigLedgerPeersRequest tBigLedgerPeers nBigLedgerPeers) = - mconcat [ "kind" .= String "BigLedgerPeersRequest" - , "targetNumberOfBigLedgerPeers" .= tBigLedgerPeers - , "numberOfBigLedgerPeers" .= nBigLedgerPeers - ] - toObject _verb (TraceBigLedgerPeersResults res group dt) = - mconcat [ "kind" .= String "BigLedgerPeersResults" - , "result" .= Aeson.toJSONList (toList res) - , "group" .= group - , "diffTime" .= dt - ] - toObject _verb (TraceBigLedgerPeersFailure err group dt) = - mconcat [ "kind" .= String "BigLedgerPeersFailure" - , "reason" .= show err - , "group" .= group - , "diffTime" .= dt - ] - toObject _verb (TraceForgetBigLedgerPeers targetKnown actualKnown sp) = - mconcat [ "kind" .= String "ForgetBigLedgerPeers" - , "targetKnown" .= targetKnown - , "actualKnown" .= actualKnown - , "selectedPeers" .= Aeson.toJSONList (toList sp) - ] - toObject _verb (TracePeerShareRequests targetKnown actualKnown (PeerSharingAmount numRequested) aps sps) = - mconcat [ "kind" .= String "PeerShareRequests" - , "targetKnown" .= targetKnown - , "actualKnown" .= actualKnown - , "numRequested" .= numRequested - , "availablePeers" .= Aeson.toJSONList (toList aps) - , "selectedPeers" .= Aeson.toJSONList (toList sps) - ] - toObject _verb (TracePeerShareResults res) = - mconcat [ "kind" .= String "PeerShareResults" - , "result" .= Aeson.toJSONList (map ( first show <$> ) res) - ] - toObject _verb (TracePeerShareResultsFiltered res) = - mconcat [ "kind" .= String "PeerShareResultsFiltered" - , "result" .= Aeson.toJSONList res - ] - toObject _verb (TraceForgetColdPeers targetKnown actualKnown sp) = - mconcat [ "kind" .= String "ForgetColdPeers" - , "targetKnown" .= targetKnown - , "actualKnown" .= actualKnown - , "selectedPeers" .= Aeson.toJSONList (toList sp) - ] - toObject _verb (TracePromoteColdPeers targetKnown actualKnown sp) = - mconcat [ "kind" .= String "PromoteColdPeers" - , "targetEstablished" .= targetKnown - , "actualEstablished" .= actualKnown - , "selectedPeers" .= Aeson.toJSONList (toList sp) - ] - toObject _verb (TracePromoteColdLocalPeers tLocalEst sp) = - mconcat [ "kind" .= String "PromoteColdLocalPeers" - , "targetLocalEstablished" .= tLocalEst - , "selectedPeers" .= Aeson.toJSONList (toList sp) - ] - toObject _verb (TracePromoteColdFailed tEst aEst p d err forgotten) = - mconcat [ "kind" .= String "PromoteColdFailed" - , "targetEstablished" .= tEst - , "actualEstablished" .= aEst - , "peer" .= toJSON p - , "delay" .= toJSON d - , "reason" .= show err - , "reason" .= show forgotten - ] - toObject _verb (TracePromoteColdDone tEst aEst p) = - mconcat [ "kind" .= String "PromoteColdDone" - , "targetEstablished" .= tEst - , "actualEstablished" .= aEst - , "peer" .= toJSON p - ] - toObject _verb (TracePromoteColdBigLedgerPeers targetKnown actualKnown sp) = - mconcat [ "kind" .= String "PromoteColdBigLedgerPeers" - , "targetEstablished" .= targetKnown - , "actualEstablished" .= actualKnown - , "selectedPeers" .= Aeson.toJSONList (toList sp) - ] - toObject _verb (TracePromoteColdBigLedgerPeerFailed tEst aEst p d err forgotten) = - mconcat [ "kind" .= String "PromoteColdBigLedgerPeerFailed" - , "targetEstablished" .= tEst - , "actualEstablished" .= aEst - , "peer" .= toJSON p - , "delay" .= toJSON d - , "reason" .= show err - , "forgotten" .= show forgotten - ] - toObject _verb (TracePromoteColdBigLedgerPeerDone tEst aEst p) = - mconcat [ "kind" .= String "PromoteColdBigLedgerPeerDone" - , "targetEstablished" .= tEst - , "actualEstablished" .= aEst - , "peer" .= toJSON p - ] - toObject _verb (TracePromoteWarmPeers tActive aActive sp) = - mconcat [ "kind" .= String "PromoteWarmPeers" - , "targetActive" .= tActive - , "actualActive" .= aActive - , "selectedPeers" .= Aeson.toJSONList (toList sp) - ] - toObject _verb (TracePromoteWarmLocalPeers taa sp) = - mconcat [ "kind" .= String "PromoteWarmLocalPeers" - , "targetActualActive" .= Aeson.toJSONList taa - , "selectedPeers" .= Aeson.toJSONList (toList sp) - ] - toObject _verb (TracePromoteWarmFailed tActive aActive p err) = - mconcat [ "kind" .= String "PromoteWarmFailed" - , "targetActive" .= tActive - , "actualActive" .= aActive - , "peer" .= toJSON p - , "reason" .= show err - ] - toObject _verb (TracePromoteWarmDone tActive aActive p) = - mconcat [ "kind" .= String "PromoteWarmDone" - , "targetActive" .= tActive - , "actualActive" .= aActive - , "peer" .= toJSON p - ] - toObject _verb (TracePromoteWarmAborted tActive aActive p) = - mconcat [ "kind" .= String "PromoteWarmAborted" - , "targetActive" .= tActive - , "actualActive" .= aActive - , "peer" .= toJSON p - ] - toObject _verb (TracePromoteWarmBigLedgerPeers tActive aActive sp) = - mconcat [ "kind" .= String "PromoteWarmBigLedgerPeers" - , "targetActive" .= tActive - , "actualActive" .= aActive - , "selectedPeers" .= Aeson.toJSONList (toList sp) - ] - toObject _verb (TracePromoteWarmBigLedgerPeerFailed tActive aActive p err) = - mconcat [ "kind" .= String "PromoteWarmBigLedgerPeerFailed" - , "targetActive" .= tActive - , "actualActive" .= aActive - , "peer" .= toJSON p - , "reason" .= show err - ] - toObject _verb (TracePromoteWarmBigLedgerPeerDone tActive aActive p) = - mconcat [ "kind" .= String "PromoteWarmBigLedgerPeerDone" - , "targetActive" .= tActive - , "actualActive" .= aActive - , "peer" .= toJSON p - ] - toObject _verb (TracePromoteWarmBigLedgerPeerAborted tActive aActive p) = - mconcat [ "kind" .= String "PromoteWarmBigLedgerPeerAborted" - , "targetActive" .= tActive - , "actualActive" .= aActive - , "peer" .= toJSON p - ] - toObject _verb (TraceDemoteWarmPeers tEst aEst sp) = - mconcat [ "kind" .= String "DemoteWarmPeers" - , "targetEstablished" .= tEst - , "actualEstablished" .= aEst - , "selectedPeers" .= Aeson.toJSONList (toList sp) - ] - toObject _verb (TraceDemoteWarmFailed tEst aEst p err) = - mconcat [ "kind" .= String "DemoteWarmFailed" - , "targetEstablished" .= tEst - , "actualEstablished" .= aEst - , "peer" .= toJSON p - , "reason" .= show err - ] - toObject _verb (TraceDemoteWarmDone tEst aEst p) = - mconcat [ "kind" .= String "DemoteWarmDone" - , "targetEstablished" .= tEst - , "actualEstablished" .= aEst - , "peer" .= toJSON p - ] - toObject _verb (TraceDemoteWarmBigLedgerPeers tEst aEst sp) = - mconcat [ "kind" .= String "DemoteWarmBigLedgerPeers" - , "targetEstablished" .= tEst - , "actualEstablished" .= aEst - , "selectedPeers" .= Aeson.toJSONList (toList sp) - ] - toObject _verb (TraceDemoteWarmBigLedgerPeerFailed tEst aEst p err) = - mconcat [ "kind" .= String "DemoteWarmBigLedgerPeerFailed" - , "targetEstablished" .= tEst - , "actualEstablished" .= aEst - , "peer" .= toJSON p - , "reason" .= show err - ] - toObject _verb (TraceDemoteWarmBigLedgerPeerDone tEst aEst p) = - mconcat [ "kind" .= String "DemoteWarmBigLedgerPeerDone" - , "targetEstablished" .= tEst - , "actualEstablished" .= aEst - , "peer" .= toJSON p - ] - toObject _verb (TraceDemoteHotPeers tActive aActive sp) = - mconcat [ "kind" .= String "DemoteHotPeers" - , "targetActive" .= tActive - , "actualActive" .= aActive - , "selectedPeers" .= Aeson.toJSONList (toList sp) - ] - toObject _verb (TraceDemoteLocalHotPeers taa sp) = - mconcat [ "kind" .= String "DemoteLocalHotPeers" - , "targetActualActive" .= Aeson.toJSONList taa - , "selectedPeers" .= Aeson.toJSONList (toList sp) - ] - toObject _verb (TraceDemoteHotFailed tActive aActive p err) = - mconcat [ "kind" .= String "DemoteHotFailed" - , "targetActive" .= tActive - , "actualActive" .= aActive - , "peer" .= toJSON p - , "reason" .= show err - ] - toObject _verb (TraceDemoteHotDone tActive aActive p) = - mconcat [ "kind" .= String "DemoteHotDone" - , "targetActive" .= tActive - , "actualActive" .= aActive - , "peer" .= toJSON p - ] - toObject _verb (TraceDemoteHotBigLedgerPeers tActive aActive sp) = - mconcat [ "kind" .= String "DemoteHotBigLedgerPeers" - , "targetActive" .= tActive - , "actualActive" .= aActive - , "selectedPeers" .= Aeson.toJSONList (toList sp) - ] - toObject _verb (TraceDemoteHotBigLedgerPeerFailed tActive aActive p err) = - mconcat [ "kind" .= String "DemoteHotBigLedgerPeerFailed" - , "targetActive" .= tActive - , "actualActive" .= aActive - , "peer" .= toJSON p - , "reason" .= show err - ] - toObject _verb (TraceDemoteHotBigLedgerPeerDone tActive aActive p) = - mconcat [ "kind" .= String "DemoteHotBigLedgerPeerDone" - , "targetActive" .= tActive - , "actualActive" .= aActive - , "peer" .= toJSON p - ] - toObject _verb (TraceDemoteAsynchronous msp) = - mconcat [ "kind" .= String "DemoteAsynchronous" - , "state" .= toJSON msp - ] - toObject _verb (TraceDemoteLocalAsynchronous msp) = - mconcat [ "kind" .= String "DemoteLocalAsynchronous" - , "state" .= toJSON msp - ] - toObject _verb (TraceDemoteBigLedgerPeersAsynchronous msp) = - mconcat [ "kind" .= String "DemoteBigLedgerPeersAsynchronous" - , "state" .= toJSON msp - ] - toObject _verb TraceGovernorWakeup = - mconcat [ "kind" .= String "GovernorWakeup" - ] - toObject _verb (TraceChurnWait dt) = - mconcat [ "kind" .= String "ChurnWait" - , "diffTime" .= toJSON dt - ] - toObject _verb (TracePickInboundPeers targetNumberOfKnownPeers numberOfKnownPeers selected available) = - mconcat [ "kind" .= String "PickInboundPeers" - , "targetKnown" .= targetNumberOfKnownPeers - , "actualKnown" .= numberOfKnownPeers - , "selected" .= selected - , "available" .= available - ] - toObject _verb TraceOnlyBootstrapPeers = - mconcat [ "kind" .= String "OnlyBootstrapPeers" ] - toObject _verb TraceBootstrapPeersFlagChangedWhilstInSensitiveState = - mconcat [ "kind" .= String "BootstrapPeersFlagChangedWhilstInSensitiveState" - ] - toObject _verb (TraceVerifyPeerSnapshot result) = - mconcat [ "kind" .= String "VerifyPeerSnapshot" - , "result" .= toJSON result ] - toObject _verb (TraceOutboundGovernorCriticalFailure err) = - mconcat [ "kind" .= String "OutboundGovernorCriticalFailure" - , "reason" .= show err - ] - toObject _verb (TraceChurnAction duration action counter) = - mconcat [ "kind" .= String "ChurnAction" - , "action" .= show action - , "counter" .= counter - , "duration" .= duration - ] - toObject _verb (TraceChurnTimeout duration action counter) = - mconcat [ "kind" .= String "ChurnTimeout" - , "action" .= show action - , "counter" .= counter - , "duration" .= duration - ] - toObject _verb (TraceDebugState mtime ds) = - mconcat [ "kind" .= String "DebugState" - , "monotonicTime" .= mtime - , "targets" .= peerSelectionTargetsToObject (dpssTargets ds) - , "localRootPeers" .= dpssLocalRootPeers ds - , "publicRootPeers" .= dpssPublicRootPeers ds - , "knownPeers" .= KnownPeers.allPeers (dpssKnownPeers ds) - , "establishedPeers" .= dpssEstablishedPeers ds - , "activePeers" .= dpssActivePeers ds - , "publicRootBackoffs" .= dpssPublicRootBackoffs ds - , "publicRootRetryTime" .= dpssPublicRootRetryTime ds - , "bigLedgerPeerBackoffs" .= dpssBigLedgerPeerBackoffs ds - , "bigLedgerPeerRetryTime" .= dpssBigLedgerPeerRetryTime ds - , "inProgressBigLedgerPeersReq" .= dpssInProgressBigLedgerPeersReq ds - , "inProgressPeerShareReqs" .= dpssInProgressPeerShareReqs ds - , "inProgressPromoteCold" .= dpssInProgressPromoteCold ds - , "inProgressPromoteWarm" .= dpssInProgressPromoteWarm ds - , "inProgressDemoteWarm" .= dpssInProgressDemoteWarm ds - , "inProgressDemoteHot" .= dpssInProgressDemoteHot ds - , "inProgressDemoteToCold" .= dpssInProgressDemoteToCold ds - , "upstreamyness" .= dpssUpstreamyness ds - , "fetchynessBlocks" .= dpssFetchynessBlocks ds - , "ledgerStateJudgement" .= Cardano.debugLedgerStateJudgement (dpssExtraState ds) - , "associationMode" .= dpssAssociationMode ds - ] - toObject _verb (ExtraTrace (Cardano.TraceLedgerStateJudgementChanged new)) = - mconcat [ "kind" .= String "LedgerStateJudgementChanged" - , "new" .= show new ] - toObject _verb (ExtraTrace (Cardano.TraceUseBootstrapPeersChanged ubp)) = - mconcat [ "kind" .= String "UseBootstrapPeersChanged" - , "bootstrapPeers" .= show ubp ] - - -peerSelectionTargetsToObject :: PeerSelectionTargets -> Value -peerSelectionTargetsToObject - PeerSelectionTargets { targetNumberOfRootPeers, - targetNumberOfKnownPeers, - targetNumberOfEstablishedPeers, - targetNumberOfActivePeers, - targetNumberOfKnownBigLedgerPeers, - targetNumberOfEstablishedBigLedgerPeers, - targetNumberOfActiveBigLedgerPeers - } = - Object $ - mconcat [ "roots" .= targetNumberOfRootPeers - , "knownPeers" .= targetNumberOfKnownPeers - , "established" .= targetNumberOfEstablishedPeers - , "active" .= targetNumberOfActivePeers - , "knownBigLedgerPeers" .= targetNumberOfKnownBigLedgerPeers - , "establishedBigLedgerPeers" .= targetNumberOfEstablishedBigLedgerPeers - , "activeBigLedgerPeers" .= targetNumberOfActiveBigLedgerPeers - ] - -instance ToObject CardanoDebugPeerSelection where - toObject verb (TraceGovernorState blockedAt wakeupAfter - st@PeerSelectionState { targets }) - | verb <= NormalVerbosity = - mconcat [ "kind" .= String "DebugPeerSelection" - , "blockedAt" .= String (pack $ show blockedAt) - , "wakeupAfter" .= String (pack $ show wakeupAfter) - , "targets" .= peerSelectionTargetsToObject targets - , "counters" .= toObject verb (peerSelectionStateToCounters - st) - - ] - toObject _ (TraceGovernorState blockedAt wakeupAfter ev) = - mconcat [ "kind" .= String "DebugPeerSelection" - , "blockedAt" .= String (pack $ show blockedAt) - , "wakeupAfter" .= String (pack $ show wakeupAfter) - , "peerSelectionState" .= String (pack $ show ev) - ] - --- TODO: Write PeerStatusChangeType ToJSON at ouroboros-network --- For that an export is needed at ouroboros-network -instance Show lAddr => ToObject (PeerSelectionActionsTrace SockAddr lAddr) where - toObject _verb (PeerStatusChanged ps) = - mconcat [ "kind" .= String "PeerStatusChanged" - , "peerStatusChangeType" .= show ps - ] - toObject _verb (PeerHotDuration connId dur) = - mconcat [ "kind" .= String "PeerHotDuration" - , "connectionId" .= connId - , "duration" .= show dur - ] - toObject _verb (PeerStatusChangeFailure ps f) = - mconcat [ "kind" .= String "PeerStatusChangeFailure" - , "peerStatusChangeType" .= show ps - , "reason" .= show f - ] - toObject _verb (PeerMonitoringError connId s) = - mconcat [ "kind" .= String "PeerMonitoringError" - , "connectionId" .= toJSON connId - , "reason" .= show s - ] - toObject _verb (PeerMonitoringResult connId wf) = - mconcat [ "kind" .= String "PeerMonitoringResult" - , "connectionId" .= toJSON connId - , "withProtocolTemp" .= show wf - ] - toObject _verb (AcquireConnectionError exception) = - mconcat [ "kind" .= String "AcquireConnectionError" - , "error" .= displayException exception - ] - -instance ToObject CardanoPeerSelectionCounters where - toObject _verb PeerSelectionCounters {..} = - mconcat [ "kind" .= String "PeerSelectionCounters" - - , "knownPeers" .= numberOfKnownPeers - , "rootPeers" .= numberOfRootPeers - , "coldPeersPromotions" .= numberOfColdPeersPromotions - , "establishedPeers" .= numberOfEstablishedPeers - , "warmPeersDemotions" .= numberOfWarmPeersDemotions - , "warmPeersPromotions" .= numberOfWarmPeersPromotions - , "activePeers" .= numberOfActivePeers - , "activePeersDemotions" .= numberOfActivePeersDemotions - - , "knownBigLedgerPeers" .= numberOfKnownBigLedgerPeers - , "coldBigLedgerPeersPromotions" .= numberOfColdBigLedgerPeersPromotions - , "establishedBigLedgerPeers" .= numberOfEstablishedBigLedgerPeers - , "warmBigLedgerPeersDemotions" .= numberOfWarmBigLedgerPeersDemotions - , "warmBigLedgerPeersPromotions" .= numberOfWarmBigLedgerPeersPromotions - , "activeBigLedgerPeers" .= numberOfActiveBigLedgerPeers - , "activeBigLedgerPeersDemotions" .= numberOfActiveBigLedgerPeersDemotions - - , "knownLocalRootPeers" .= numberOfKnownLocalRootPeers - , "establishedLocalRootPeers" .= numberOfEstablishedLocalRootPeers - , "warmLocalRootPeersPromotions" .= numberOfWarmLocalRootPeersPromotions - , "activeLocalRootPeers" .= numberOfActiveLocalRootPeers - , "activeLocalRootPeersDemotions" .= numberOfActiveLocalRootPeersDemotions - - , "knownNonRootPeers" .= numberOfKnownNonRootPeers - , "coldNonRootPeersPromotions" .= numberOfColdNonRootPeersPromotions - , "establishedNonRootPeers" .= numberOfEstablishedNonRootPeers - , "warmNonRootPeersDemotions" .= numberOfWarmNonRootPeersDemotions - , "warmNonRootPeersPromotions" .= numberOfWarmNonRootPeersPromotions - , "activeNonRootPeers" .= numberOfActiveNonRootPeers - , "activeNonRootPeersDemotions" .= numberOfActiveNonRootPeersDemotions - - , "knownBootstrapPeers" .= snd (Cardano.viewKnownBootstrapPeers extraCounters) - , "coldBootstrapPeersPromotions" .= snd (Cardano.viewColdBootstrapPeersPromotions extraCounters) - , "establishedBootstrapPeers" .= snd (Cardano.viewEstablishedBootstrapPeers extraCounters) - , "warmBootstrapPeersDemotions" .= snd (Cardano.viewWarmBootstrapPeersDemotions extraCounters) - , "warmBootstrapPeersPromotions" .= snd (Cardano.viewWarmBootstrapPeersPromotions extraCounters) - , "activeBootstrapPeers" .= snd (Cardano.viewActiveBootstrapPeers extraCounters) - , "activeBootstrapPeersDemotions" .= snd (Cardano.viewActiveBootstrapPeersDemotions extraCounters) - ] - -instance (Show versionNumber, ToJSON versionNumber, ToJSON agreedOptions) - => ToObject (ConnectionHandlerTrace versionNumber agreedOptions) where - toObject _verb (TrHandshakeSuccess versionNumber agreedOptions) = - mconcat - [ "kind" .= String "HandshakeSuccess" - , "versionNumber" .= toJSON versionNumber - , "agreedOptions" .= toJSON agreedOptions - ] - toObject _verb (TrHandshakeQuery vMap) = - mconcat - [ "kind" .= String "HandshakeQuery" - , "versions" .= toJSON ((\(k,v) -> Aeson.object [ - "versionNumber" .= k - , "options" .= v - ]) <$> Map.toList vMap) - ] - toObject _verb (TrHandshakeClientError err) = - mconcat - [ "kind" .= String "HandshakeClientError" - , "reason" .= toJSON err - ] - toObject _verb (TrHandshakeServerError err) = - mconcat - [ "kind" .= String "HandshakeServerError" - , "reason" .= toJSON err - ] - toObject _verb (TrConnectionHandlerError e err cerr) = - mconcat - [ "kind" .= String "Error" - , "context" .= show e - , "reason" .= show err - , "command" .= show cerr - ] - -instance ToObject ConnStateId where - toObject _ connStateId = mconcat [ "connStateId" .= toJSON connStateId ] - -instance (Show addr, Show versionNumber, Show agreedOptions, ToObject addr, - ToJSON addr, ToJSON versionNumber, ToJSON agreedOptions) - => ToObject (ConnMgr.Trace addr (ConnectionHandlerTrace versionNumber agreedOptions)) where - toObject verb ev = - case ev of - TrIncludeConnection prov peerAddr -> - mconcat $ reverse - [ "kind" .= String "IncludeConnection" - , "remoteAddress" .= toObject verb peerAddr - , "provenance" .= String (pack . show $ prov) - ] - TrReleaseConnection prov connId -> - mconcat $ reverse - [ "kind" .= String "UnregisterConnection" - , "remoteAddress" .= toJSON connId - , "provenance" .= String (pack . show $ prov) - ] - TrConnect (Just localAddress) remoteAddress diffusionMode -> - mconcat - [ "kind" .= String "Connect" - , "connectionId" .= toJSON ConnectionId { localAddress, remoteAddress } - , "diffusionMode" .= toJSON diffusionMode - ] - TrConnect Nothing remoteAddress diffusionMode -> - mconcat - [ "kind" .= String "Connect" - , "remoteAddress" .= toObject verb remoteAddress - , "diffusionMode" .= toJSON diffusionMode - ] - TrConnectError (Just localAddress) remoteAddress err -> - mconcat - [ "kind" .= String "ConnectError" - , "connectionId" .= toJSON ConnectionId { localAddress, remoteAddress } - , "reason" .= String (pack . show $ err) - ] - TrConnectError Nothing remoteAddress err -> - mconcat - [ "kind" .= String "ConnectError" - , "remoteAddress" .= toObject verb remoteAddress - , "reason" .= String (pack . show $ err) - ] - TrTerminatingConnection prov connId -> - mconcat - [ "kind" .= String "TerminatingConnection" - , "provenance" .= String (pack . show $ prov) - , "connectionId" .= toJSON connId - ] - TrTerminatedConnection prov remoteAddress -> - mconcat - [ "kind" .= String "TerminatedConnection" - , "provenance" .= String (pack . show $ prov) - , "remoteAddress" .= toObject verb remoteAddress - ] - TrConnectionHandler connId a -> - mconcat - [ "kind" .= String "ConnectionHandler" - , "connectionId" .= toJSON connId - , "connectionHandler" .= toObject verb a - ] - TrShutdown -> - mconcat - [ "kind" .= String "Shutdown" - ] - TrConnectionExists prov remoteAddress inState -> - mconcat - [ "kind" .= String "ConnectionExists" - , "provenance" .= String (pack . show $ prov) - , "remoteAddress" .= toObject verb remoteAddress - , "state" .= toJSON inState - ] - TrForbiddenConnection connId -> - mconcat - [ "kind" .= String "ForbiddenConnection" - , "connectionId" .= toJSON connId - ] - TrConnectionFailure connId -> - mconcat - [ "kind" .= String "ConnectionFailure" - , "connectionId" .= toJSON connId - ] - TrConnectionNotFound prov remoteAddress -> - mconcat - [ "kind" .= String "ConnectionNotFound" - , "remoteAddress" .= toObject verb remoteAddress - , "provenance" .= String (pack . show $ prov) - ] - TrForbiddenOperation remoteAddress connState -> - mconcat - [ "kind" .= String "ForbiddenOperation" - , "remoteAddress" .= toObject verb remoteAddress - , "connectionState" .= toJSON connState - ] - TrPruneConnections pruningSet numberPruned chosenPeers -> - mconcat - [ "kind" .= String "PruneConnections" - , "prunedPeers" .= toJSON pruningSet - , "numberPrunedPeers" .= toJSON numberPruned - , "choiceSet" .= toJSON (toJSON `Set.map` chosenPeers) - ] - TrConnectionCleanup connId -> - mconcat - [ "kind" .= String "ConnectionCleanup" - , "connectionId" .= toJSON connId - ] - TrConnectionTimeWait connId -> - mconcat - [ "kind" .= String "ConnectionTimeWait" - , "connectionId" .= toJSON connId - ] - TrConnectionTimeWaitDone connId -> - mconcat - [ "kind" .= String "ConnectionTimeWaitDone" - , "connectionId" .= toJSON connId - ] - TrConnectionManagerCounters cmCounters -> - mconcat - [ "kind" .= String "ConnectionManagerCounters" - , "state" .= toJSON cmCounters - ] - TrState cmState -> - mconcat - [ "kind" .= String "ConnectionManagerState" - , "state" .= listValue (\(remoteAddr, inner) -> - Aeson.object - [ "connections" .= - listValue (\(localAddr, connState) -> - Aeson.object - [ "localAddress" .= localAddr - , "state" .= toJSON connState - ] - ) - (Map.toList inner) - , "remoteAddress" .= toJSON remoteAddr - ] - ) - (Map.toList (getConnMap cmState)) - ] - ConnMgr.TrUnexpectedlyFalseAssertion info -> - mconcat - [ "kind" .= String "UnexpectedlyFalseAssertion" - , "info" .= String (pack . show $ info) - ] - TrInboundConnectionNotFound peerAddr -> - mconcat $ reverse - [ "kind" .= String "InboundConnectionNotFound" - , "remoteAddress" .= toJSON peerAddr - ] - -instance (Show addr, ToObject addr, ToJSON addr) - => ToObject (ConnMgr.AbstractTransitionTrace addr) where - toObject _verb (ConnMgr.TransitionTrace addr tr) = - mconcat [ "kind" .= String "ConnectionManagerTransition" - , "address" .= toJSON addr - , "from" .= toJSON (ConnMgr.fromState tr) - , "to" .= toJSON (ConnMgr.toState tr) - ] - -instance (Show addr, ToObject addr, ToJSON addr) - => ToObject (Server.Trace addr) where - toObject _verb (Server.TrAcceptConnection connId) = - mconcat [ "kind" .= String "AcceptConnection" - , "connectionId" .= toJSON connId - ] - toObject _verb (Server.TrAcceptError exception) = - mconcat [ "kind" .= String "AcceptErroor" - , "reason" .= show exception - ] - toObject verb (Server.TrAcceptPolicyTrace policyTrace) = - mconcat [ "kind" .= String "AcceptPolicyServer.Trace" - , "policy" .= toObject verb policyTrace - ] - toObject verb (Server.TrServerStarted peerAddrs) = - mconcat [ "kind" .= String "AcceptPolicyServer.Trace" - , "addresses" .= toJSON (toObject verb `map` peerAddrs) - ] - toObject _verb Server.TrServerStopped = - mconcat [ "kind" .= String "ServerStopped" - ] - toObject _verb (Server.TrServerError exception) = - mconcat [ "kind" .= String "ServerError" - , "reason" .= show exception - ] - -instance ToObject NtN.RemoteAddress where - toObject _verb (SockAddrInet port addr) = - let ip = IP.fromHostAddress addr in - mconcat [ "addr" .= show ip - , "port" .= show port - ] - toObject _verb (SockAddrInet6 port _ addr _) = - let ip = IP.fromHostAddress6 addr in - mconcat [ "addr" .= show ip - , "port" .= show port - ] - toObject _verb (SockAddrUnix path) = - mconcat [ "path" .= show path ] - -instance ToObject NtN.RemoteConnectionId where - toObject verb (NtN.ConnectionId l r) = - mconcat [ "local" .= toObject verb l - , "remote" .= toObject verb r - ] - -instance ToObject LocalAddress where - toObject _verb (LocalAddress path) = - mconcat ["path" .= path] - -instance ToObject NtC.LocalConnectionId where - toObject verb (NtC.ConnectionId l r) = - mconcat [ "local" .= toObject verb l - , "remote" .= toObject verb r - ] -instance (ToJSON addr, Show addr, Aeson.ToJSONKey addr) - => ToObject (InboundGovernor.Trace addr) where - toObject _verb (InboundGovernor.TrNewConnection p connId) = - mconcat [ "kind" .= String "NewConnection" - , "provenance" .= show p - , "connectionId" .= toJSON connId - ] - toObject _verb (InboundGovernor.TrResponderRestarted connId m) = - mconcat [ "kind" .= String "ResponderStarted" - , "connectionId" .= toJSON connId - , "miniProtocolNum" .= toJSON m - ] - toObject _verb (InboundGovernor.TrResponderStartFailure connId m s) = - mconcat [ "kind" .= String "ResponderStartFailure" - , "connectionId" .= toJSON connId - , "miniProtocolNum" .= toJSON m - , "reason" .= show s - ] - toObject _verb (InboundGovernor.TrResponderErrored connId m s) = - mconcat [ "kind" .= String "ResponderErrored" - , "connectionId" .= toJSON connId - , "miniProtocolNum" .= toJSON m - , "reason" .= show s - ] - toObject _verb (InboundGovernor.TrResponderStarted connId m) = - mconcat [ "kind" .= String "ResponderStarted" - , "connectionId" .= toJSON connId - , "miniProtocolNum" .= toJSON m - ] - toObject _verb (InboundGovernor.TrResponderTerminated connId m) = - mconcat [ "kind" .= String "ResponderTerminated" - , "connectionId" .= toJSON connId - , "miniProtocolNum" .= toJSON m - ] - toObject _verb (InboundGovernor.TrPromotedToWarmRemote connId opRes) = - mconcat [ "kind" .= String "PromotedToWarmRemote" - , "connectionId" .= toJSON connId - , "result" .= toJSON opRes - ] - toObject _verb (InboundGovernor.TrPromotedToHotRemote connId) = - mconcat [ "kind" .= String "PromotedToHotRemote" - , "connectionId" .= toJSON connId - ] - toObject _verb (InboundGovernor.TrDemotedToColdRemote connId od) = - mconcat [ "kind" .= String "DemotedToColdRemote" - , "connectionId" .= toJSON connId - , "result" .= show od - ] - toObject _verb (InboundGovernor.TrDemotedToWarmRemote connId) = - mconcat [ "kind" .= String "DemotedToWarmRemote" - , "connectionId" .= toJSON connId - ] - toObject _verb (InboundGovernor.TrWaitIdleRemote connId opRes) = - mconcat [ "kind" .= String "WaitIdleRemote" - , "connectionId" .= toJSON connId - , "result" .= toJSON opRes - ] - toObject _verb (InboundGovernor.TrMuxCleanExit connId) = - mconcat [ "kind" .= String "MuxCleanExit" - , "connectionId" .= toJSON connId - ] - toObject _verb (InboundGovernor.TrMuxErrored connId s) = - mconcat [ "kind" .= String "MuxErrored" - , "connectionId" .= toJSON connId - , "reason" .= show s - ] - toObject _verb (InboundGovernor.TrInboundGovernorCounters counters) = - mconcat [ "kind" .= String "InboundGovernorCounters" - , "idlePeers" .= InboundGovernor.idlePeersRemote counters - , "coldPeers" .= InboundGovernor.coldPeersRemote counters - , "warmPeers" .= InboundGovernor.warmPeersRemote counters - , "hotPeers" .= InboundGovernor.hotPeersRemote counters - ] - toObject _verb (InboundGovernor.TrRemoteState st) = - mconcat [ "kind" .= String "RemoteState" - , "remoteSt" .= toJSON st - ] - toObject _verb (InboundGovernor.TrUnexpectedlyFalseAssertion info) = - mconcat [ "kind" .= String "UnexpectedlyFalseAssertion" - , "remoteSt" .= String (pack . show $ info) - ] - toObject _verb (InboundGovernor.TrInboundGovernorError err) = - mconcat [ "kind" .= String "InboundGovernorError" - , "remoteSt" .= String (pack . show $ err) - ] - toObject _verb (InboundGovernor.TrMaturedConnections matured fresh) = - mconcat [ "kind" .= String "MaturedConnections" - , "matured" .= toJSON matured - , "fresh" .= toJSON fresh - ] - toObject _verb (InboundGovernor.TrInactive fresh) = - mconcat [ "kind" .= String "Inactive" - , "fresh" .= toJSON fresh - ] - -instance ToJSON addr - => ToObject (Server.RemoteTransitionTrace addr) where - toObject _verb (ConnMgr.TransitionTrace addr tr) = - mconcat [ "kind" .= String "InboundGovernorTransition" - , "address" .= toJSON addr - , "from" .= toJSON (ConnMgr.fromState tr) - , "to" .= toJSON (ConnMgr.toState tr) - ] - -instance HasPrivacyAnnotation TraceChurnMode where -instance HasSeverityAnnotation TraceChurnMode where - getSeverityAnnotation TraceChurnMode {} = Info -instance Transformable Text IO TraceChurnMode where - trTransformer = trStructuredText -instance HasTextFormatter TraceChurnMode where - formatText a _ = pack (show a) -instance ToObject TraceChurnMode where - toObject _verb (TraceChurnMode churnMode) = - mconcat [ "kind" .= String "ChurnMode" - , "churnMode" .= String (pack . show $ churnMode) - ] - -instance HasPrivacyAnnotation DNSTrace where -instance HasSeverityAnnotation DNSTrace where - getSeverityAnnotation _ = Info -instance Transformable Text IO DNSTrace where - trTransformer = trStructuredText -instance HasTextFormatter DNSTrace where - formatText a _ = pack (show a) -instance ToObject DNSTrace where - toObject _verb (DNSLookupResult peerKind domain Nothing results) = - mconcat [ "kind" .= String "DNSLookupResult" - , "peerKind" .= String (pack . show $ peerKind) - , "domain" .= String (pack . show $ domain) - , "results" .= results - ] - toObject _verb (DNSLookupResult peerKind domain (Just srv) results) = - mconcat [ "kind" .= String "DNSLookupResult" - , "peerKind" .= String (pack . show $ peerKind) - , "domain" .= String (pack . show $ domain) - , "srv" .= String (pack . show $ srv) - , "results" .= results - ] - toObject _verb (DNSLookupError peerKind lookupType domain dnsError) = - mconcat [ "kind" .= String "DNSLookupError" - , "peerKind" .= String (pack . show $ peerKind) - , "lookupKind" .= String (pack . show $ lookupType) - , "domain" .= String (pack . show $ domain) - , "dnsError" .= String (pack . show $ dnsError) - ] - toObject _verb (SRVLookupResult peerKind domain results) = - mconcat [ "kind" .= String "SRVLookupResult" - , "peerKind" .= String (pack . show $ peerKind) - , "domain" .= String (pack . show $ domain) - , "results" .= [ (show a, b, c, d, e) - | (a, b, c, d, e) <- results - ] - ] - toObject _verb (SRVLookupError peerKind domain) = - mconcat [ "kind" .= String "SRVLookupError" - , "peerKind" .= String (pack . show $ peerKind) - , "domain" .= String (pack . show $ domain) - ] - -instance HasPrivacyAnnotation (TraceTxLogic txid tx addr) where -instance HasSeverityAnnotation (TraceTxLogic txid tx addr) where - getSeverityAnnotation _ = Debug -instance (Show txid, Show tx, Show addr) => ToObject (TraceTxLogic txid tx addr) where - -instance HasPrivacyAnnotation TxSubmissionCounters where -instance HasSeverityAnnotation TxSubmissionCounters where - getSeverityAnnotation _ = Debug -instance ToObject TxSubmissionCounters where - toObject _ TxSubmissionCounters {..} = - mconcat [ "kind" .= String "TxSubmissionCounters" - , "numOfOutstandingTxIds" .= numOfOutstandingTxIds - , "numOfBufferedTxs" .= numOfBufferedTxs - , "numOfInSubmissionToMempoolTxs" .= numOfInSubmissionToMempoolTxs - , "numOfTxIdsInflight" .= numOfTxIdsInflight - ] - -instance Show txid => ToObject (TxDecision txid tx) where - toObject verb decision = - ("kind" .= String "TraceTxDecisions") - <> case verb of - MaximalVerbosity -> "decision" .= - let g (TxsToMempool txs) = map (show . fst) txs - f TxDecision {..} = - [( fromIntegral txdTxIdsToAcknowledge :: Int, fromIntegral txdTxIdsToRequest :: Int - , map (first show) . Map.toList $ txdTxsToRequest, g txdTxsToMempool)] - in f decision - _otherwise -> mempty diff --git a/cardano-node/src/Cardano/Tracing/OrphanInstances/Shelley.hs b/cardano-node/src/Cardano/Tracing/OrphanInstances/Shelley.hs deleted file mode 100644 index d067a4a2e4b..00000000000 --- a/cardano-node/src/Cardano/Tracing/OrphanInstances/Shelley.hs +++ /dev/null @@ -1,1638 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE DisambiguateRecordFields #-} -{-# LANGUAGE EmptyCase #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuantifiedConstraints #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - -{-# OPTIONS_GHC -Wno-orphans #-} - -module Cardano.Tracing.OrphanInstances.Shelley () where - -import Cardano.Api (textShow) -import qualified Cardano.Api as Api - -import qualified Cardano.Crypto.Hash.Class as Crypto -import qualified Cardano.Crypto.VRF.Class as Crypto -import Cardano.Ledger.Allegra.Rules (AllegraUtxoPredFailure) -import qualified Cardano.Ledger.Allegra.Rules as Allegra -import qualified Cardano.Ledger.Alonzo.Plutus.Evaluate as Alonzo -import Cardano.Ledger.Alonzo.Rules (AlonzoBbodyPredFailure (..), AlonzoUtxoPredFailure, - AlonzoUtxosPredFailure, AlonzoUtxowPredFailure (..)) -import qualified Cardano.Ledger.Alonzo.Rules as Alonzo -import qualified Cardano.Ledger.Api as Ledger -import Cardano.Ledger.Babbage.Rules (BabbageUtxoPredFailure, BabbageUtxowPredFailure) -import qualified Cardano.Ledger.Babbage.Rules as Babbage -import Cardano.Ledger.BaseTypes (Mismatch (..), activeSlotLog, strictMaybeToMaybe) -import Cardano.Ledger.Chain -import Cardano.Ledger.Conway.Governance (govActionIdToText) -import Cardano.Ledger.Conway.Rules (ConwayUtxosPredFailure) -import qualified Cardano.Ledger.Conway.Rules as Conway -import qualified Cardano.Ledger.Core as Core -import qualified Cardano.Ledger.Core as Ledger -import qualified Cardano.Ledger.Dijkstra.Rules as Dijkstra -import qualified Cardano.Ledger.Hashes as Hashes -import Cardano.Ledger.Shelley.API -import Cardano.Ledger.Shelley.Rules -import Cardano.Node.Tracing.Render (renderIncompleteWithdrawals, renderMissingRedeemers, - renderScriptHash, renderScriptIntegrityHash) -import Cardano.Node.Tracing.Tracers.KESInfo () -import qualified Cardano.Protocol.Crypto as Core -import Cardano.Protocol.TPraos.API (ChainTransitionError (ChainTransitionError)) -import Cardano.Protocol.TPraos.BHeader (LastAppliedBlock, labBlockNo) -import Cardano.Protocol.TPraos.OCert (KESPeriod (KESPeriod)) -import Cardano.Protocol.TPraos.Rules.OCert -import Cardano.Protocol.TPraos.Rules.Overlay -import Cardano.Protocol.TPraos.Rules.Prtcl -import Cardano.Protocol.TPraos.Rules.Tickn -import Cardano.Protocol.TPraos.Rules.Updn -import Cardano.Slotting.Block (BlockNo (..)) -import Cardano.Tracing.OrphanInstances.Common -import Cardano.Tracing.OrphanInstances.Consensus () -import Cardano.Tracing.Render (renderTxId) -import qualified Ouroboros.Consensus.Cardano.Block as Consensus -import Ouroboros.Consensus.Ledger.SupportsMempool (txId) -import qualified Ouroboros.Consensus.Ledger.SupportsMempool as SupportsMempool -import qualified Ouroboros.Consensus.Protocol.Ledger.HotKey as HotKey -import qualified Ouroboros.Consensus.Protocol.Praos as Praos -import qualified Ouroboros.Consensus.Protocol.Praos.Common as Praos -import Ouroboros.Consensus.Protocol.TPraos (TPraosCannotForge (..)) -import Ouroboros.Consensus.Shelley.Ledger hiding (TxId) -import Ouroboros.Consensus.Shelley.Ledger.Inspect -import qualified Ouroboros.Consensus.Shelley.Protocol.Praos as Praos -import Ouroboros.Consensus.Util.Condense (condense) -import Ouroboros.Network.Block (SlotNo (..), blockHash, blockNo, blockSlot) -import Ouroboros.Network.Point (WithOrigin, withOriginToMaybe) - -import Data.Aeson (Value (..)) -import qualified Data.Aeson.Key as Aeson (fromText) -import qualified Data.Aeson.Types as Aeson -import qualified Data.ByteString.Base16 as B16 -import qualified Data.List.NonEmpty as NonEmpty -import qualified Data.Map as Map -import Data.Set (Set) -import qualified Data.Set as Set -import qualified Data.Set.NonEmpty as NonEmptySet -import Data.Text (Text) -import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text - -{- HLINT ignore "Use :" -} - --- --- | instances of @ToObject@ --- --- NOTE: this list is sorted in roughly topological order. - -instance - ( Consensus.ShelleyBasedEra ledgerera - ) => ToObject (GenTx (ShelleyBlock protocol ledgerera)) where - toObject _ tx = mconcat [ "txid" .= Text.take 8 (renderTxId (txId tx)) ] - -instance ToJSON (SupportsMempool.TxId (GenTx (ShelleyBlock protocol era))) where - toJSON = String . Text.take 8 . renderTxId - -instance ShelleyCompatible protocol era => ToObject (Header (ShelleyBlock protocol era)) where - toObject _verb b = mconcat - [ "kind" .= String "ShelleyBlock" - , "hash" .= condense (blockHash b) - , "slotNo" .= condense (blockSlot b) - , "blockNo" .= condense (blockNo b) --- , "delegate" .= condense (headerSignerVk h) - ] - -instance - ( ToObject (PredicateFailure (Core.EraRule "LEDGER" ledgerera)) - , ToJSON (ApplyTxError ledgerera) -- provided by cardano-api - ) => ToObject (ApplyTxError ledgerera) where - -instance Core.Crypto crypto => ToObject (TPraosCannotForge crypto) where - toObject _verb (TPraosCannotForgeKeyNotUsableYet wallClockPeriod keyStartPeriod) = - mconcat - [ "kind" .= String "TPraosCannotForgeKeyNotUsableYet" - , "keyStart" .= keyStartPeriod - , "wallClock" .= wallClockPeriod - ] - toObject _verb (TPraosCannotForgeWrongVRF genDlgVRFHash coreNodeVRFHash) = - mconcat - [ "kind" .= String "TPraosCannotLeadWrongVRF" - , "expected" .= genDlgVRFHash - , "actual" .= coreNodeVRFHash - ] - -instance - ( ToObject (PredicateFailure (Ledger.EraRule "BBODY" era)) - ) => ToObject (BlockTransitionError era) where - toObject verb (BlockTransitionError fs) = - mconcat [ "kind" .= String "BlockTransitionError" - , "failures" .= fmap (toObject verb) fs - ] - -instance - ( Ledger.Era ledgerera - , Show (Ledger.PParamsHKD Identity ledgerera) - ) => ToObject (ShelleyLedgerUpdate ledgerera) where - toObject _verb (ShelleyUpdatedPParams updates epochNo) = - mconcat [ "kind" .= String "ShelleyUpdatedPParams" - , "updates" .= show updates - , "epochNo" .= show epochNo - ] -instance - ( ToObject (PredicateFailure (Ledger.EraRule "DELEG" era)) - , ToObject (PredicateFailure (Ledger.EraRule "POOL" era)) - , ToObject (PredicateFailure (Ledger.EraRule "GOVCERT" era)) - ) => ToObject (Conway.ConwayCertPredFailure era) where - toObject verb = mconcat . \case - Conway.DelegFailure f -> - [ "kind" .= String "DelegFailure " , "failure" .= toObject verb f ] - Conway.PoolFailure f -> - [ "kind" .= String "PoolFailure" , "failure" .= toObject verb f ] - Conway.GovCertFailure f -> - [ "kind" .= String "GovCertFailure" , "failure" .= toObject verb f ] - -instance ToObject (Conway.ConwayGovCertPredFailure era) where - toObject _verb = mconcat . \case - Conway.ConwayDRepAlreadyRegistered credential -> - [ "kind" .= String "ConwayDRepAlreadyRegistered" - , "credential" .= String (textShow credential) - , "error" .= String "DRep is already registered" - ] - Conway.ConwayDRepNotRegistered credential -> - [ "kind" .= String "ConwayDRepNotRegistered" - , "credential" .= String (textShow credential) - , "error" .= String "DRep is not registered" - ] - Conway.ConwayDRepIncorrectDeposit Mismatch {mismatchSupplied, mismatchExpected} -> - [ "kind" .= String "ConwayDRepIncorrectDeposit" - , "givenCoin" .= mismatchSupplied - , "expectedCoin" .= mismatchExpected - , "error" .= String "DRep delegation has incorrect deposit" - ] - Conway.ConwayCommitteeHasPreviouslyResigned kHash -> - [ "kind" .= String "ConwayCommitteeHasPreviouslyResigned" - , "credential" .= String (textShow kHash) - , "error" .= String "Committee has resigned" - ] - Conway.ConwayCommitteeIsUnknown kHash -> - [ "kind" .= String "ConwayCommitteeIsUnknown" - , "credential" .= String (textShow kHash) - , "error" .= String "Committee is Unknown" - ] - Conway.ConwayDRepIncorrectRefund Mismatch {mismatchSupplied, mismatchExpected} -> - [ "kind" .= String "ConwayDRepIncorrectRefund" - , "givenRefund" .= String (textShow mismatchSupplied) - , "expectedRefund" .= String (textShow mismatchExpected) - , "error" .= String "Refund given does not match the expected one" - ] - - -instance ToObject (Conway.ConwayDelegPredFailure era) where - toObject _verb = mconcat . \case - Conway.DelegateeStakePoolNotRegisteredDELEG (KeyHash targetPool) -> - [ "kind" .= String "DelegateeNotRegisteredDELEG" - , "targetPool" .= Crypto.hashToTextAsHex targetPool - ] - Conway.IncorrectDepositDELEG coin -> - [ "kind" .= String "IncorrectDepositDELEG" - , "amount" .= coin - , "error" .= String "Incorrect deposit amount" - ] - Conway.StakeKeyRegisteredDELEG credential -> - [ "kind" .= String "StakeKeyRegisteredDELEG" - , "credential" .= String (textShow credential) - , "error" .= String "Stake key already registered" - ] - Conway.StakeKeyNotRegisteredDELEG credential -> - [ "kind" .= String "StakeKeyNotRegisteredDELEG" - , "amount" .= String (textShow credential) - , "error" .= String "Stake key not registered" - ] - Conway.StakeKeyHasNonZeroAccountBalanceDELEG coin -> - [ "kind" .= String "StakeKeyHasNonZeroAccountBalanceDELEG" - , "amount" .= coin - , "error" .= String "Stake key has non-zero account balance" - ] - Conway.DelegateeDRepNotRegisteredDELEG credential -> - [ "kind" .= String "DelegateeDRepNotRegisteredDELEG" - , "credential" .= String (textShow credential) - , "error" .= String "Delegated rep is not registered for provided stake key" - ] - Conway.DepositIncorrectDELEG Mismatch {mismatchSupplied, mismatchExpected} -> - [ "kind" .= String "DepositIncorrectDELEG" - , "givenRefund" .= mismatchSupplied - , "expectedRefund" .= mismatchExpected - , "error" .= String "Deposit mismatch" - ] - Conway.RefundIncorrectDELEG Mismatch {mismatchSupplied, mismatchExpected} -> - [ "kind" .= String "RefundIncorrectDELEG" - , "givenRefund" .= mismatchSupplied - , "expectedRefund" .= mismatchExpected - , "error" .= String "Refund mismatch" - ] - -instance ToObject (Set (Credential Staking)) where - toObject _verb creds = - mconcat [ "kind" .= String "StakeCreds" - , "stakeCreds" .= map toJSON (Set.toList creds) - ] - -instance ToObject (NonEmpty.NonEmpty (KeyHash Staking)) where - toObject _verb keyHashes = - mconcat [ "kind" .= String "StakeKeyHashes" - , "stakeKeyHashes" .= toJSON keyHashes - ] - -instance Core.Crypto crypto => ToObject (ChainTransitionError crypto) where - toObject verb (ChainTransitionError fs) = - mconcat [ "kind" .= String "ChainTransitionError" - , "failures" .= fmap (toObject verb) fs - ] - -instance ToObject ChainPredicateFailure where - toObject _verb (HeaderSizeTooLargeCHAIN hdrSz maxHdrSz) = - mconcat [ "kind" .= String "HeaderSizeTooLarge" - , "headerSize" .= hdrSz - , "maxHeaderSize" .= maxHdrSz - ] - toObject _verb (BlockSizeTooLargeCHAIN blkSz maxBlkSz) = - mconcat [ "kind" .= String "BlockSizeTooLarge" - , "blockSize" .= blkSz - , "maxBlockSize" .= maxBlkSz - ] - toObject _verb (ObsoleteNodeCHAIN currentPtcl supportedPtcl) = - mconcat [ "kind" .= String "ObsoleteNode" - , "explanation" .= String explanation - , "currentProtocol" .= currentPtcl - , "supportedProtocol" .= supportedPtcl ] - where - explanation = mconcat - [ "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." - ] - -instance ToObject PrtlSeqFailure where - toObject _verb (WrongSlotIntervalPrtclSeq (SlotNo lastSlot) (SlotNo currSlot)) = - mconcat [ "kind" .= String "WrongSlotInterval" - , "lastSlot" .= lastSlot - , "currentSlot" .= currSlot - ] - toObject _verb (WrongBlockNoPrtclSeq lab currentBlockNo) = - mconcat [ "kind" .= String "WrongBlockNo" - , "lastAppliedBlockNo" .= showLastAppBlockNo lab - , "currentBlockNo" .= (String . textShow $ unBlockNo currentBlockNo) - ] - toObject _verb (WrongBlockSequencePrtclSeq lastAppliedHash currentHash) = - mconcat [ "kind" .= String "WrongBlockSequence" - , "lastAppliedBlockHash" .= String (textShow lastAppliedHash) - , "currentBlockHash" .= String (textShow currentHash) - ] - -instance - ( ToObject (PredicateFailure (Ledger.EraRule "LEDGERS" ledgerera)) - ) => ToObject (ShelleyBbodyPredFailure ledgerera) where - toObject _verb (WrongBlockBodySizeBBODY Mismatch { mismatchSupplied = actualBodySz - , mismatchExpected = claimedBodySz }) = - mconcat [ "kind" .= String "WrongBlockBodySizeBBODY" - , "actualBlockBodySize" .= actualBodySz - , "claimedBlockBodySize" .= claimedBodySz - ] - toObject _verb (InvalidBodyHashBBODY Mismatch { mismatchSupplied = actualHash - , mismatchExpected = claimedHash }) = - mconcat [ "kind" .= String "InvalidBodyHashBBODY" - , "actualBodyHash" .= textShow actualHash - , "claimedBodyHash" .= textShow claimedHash - ] - toObject verb (LedgersFailure f) = toObject verb f - - -instance - ( ToObject (PredicateFailure (Core.EraRule "LEDGER" ledgerera)) - ) => ToObject (ShelleyLedgersPredFailure ledgerera) where - toObject verb (LedgerFailure f) = toObject verb f - -instance ToObject Withdrawals where - toObject _verb (Withdrawals ws) = - mconcat ["kind" .= String "Withdrawals" - , "withdrawals" .= Aeson.object (map renderTuple $ Map.toList ws) - ] - where - renderTuple :: (Ledger.AccountAddress, Coin) -> Aeson.Pair - renderTuple (address, mismatch) = - Aeson.fromText (Api.serialiseAddress $ Api.fromShelleyStakeAddr address) .= show mismatch - -instance - ( ToObject (PredicateFailure (Core.EraRule "DELEGS" ledgerera)) - , ToObject (PredicateFailure (Core.EraRule "UTXOW" ledgerera)) - ) => ToObject (ShelleyLedgerPredFailure ledgerera) where - toObject verb (UtxowFailure f) = toObject verb f - toObject verb (DelegsFailure f) = toObject verb f - toObject verb (ShelleyWithdrawalsMissingAccounts withdrawals) = toObject verb withdrawals - toObject _verb (ShelleyIncompleteWithdrawals payload) = - mconcat ["kind" .= String "ShelleyIncompleteWithdrawals" - , "withdrawals" .= renderIncompleteWithdrawals payload] - - -instance - ( ToObject (PredicateFailure (Core.EraRule "CERTS" ledgerera)) - , ToObject (PredicateFailure (Core.EraRule "UTXOW" ledgerera)) - , ToObject (PredicateFailure (Core.EraRule "GOV" ledgerera)) - ) => ToObject (Conway.ConwayLedgerPredFailure ledgerera) where - toObject verb (Conway.ConwayUtxowFailure f) = toObject verb f - toObject _ (Conway.ConwayWithdrawalsMissingAccounts missingWithdrawals) = - mconcat [ "kind" .= String "ConwayWithdrawalsMissingAccounts" - , "withdrawals" .= unWithdrawals missingWithdrawals - ] - toObject _ (Conway.ConwayIncompleteWithdrawals incompleteWithdrawals) = - mconcat [ "kind" .= String "ConwayIncompleteWithdrawals" - , "withdrawals" .= renderIncompleteWithdrawals incompleteWithdrawals - ] - toObject _ (Conway.ConwayTxRefScriptsSizeTooBig Mismatch {mismatchSupplied, mismatchExpected}) = - mconcat [ "kind" .= String "ConwayTxRefScriptsSizeTooBig" - , "actual" .= mismatchSupplied - , "limit" .= mismatchExpected - ] - toObject verb (Conway.ConwayCertsFailure f) = toObject verb f - toObject verb (Conway.ConwayGovFailure f) = toObject verb f - toObject verb (Conway.ConwayWdrlNotDelegatedToDRep f) = toObject verb f - toObject _ (Conway.ConwayTreasuryValueMismatch Mismatch {mismatchSupplied, mismatchExpected}) = - mconcat [ "kind" .= String "ConwayTreasuryValueMismatch" - , "actual" .= mismatchExpected - , "submittedInTx" .= mismatchSupplied - ] - toObject _ (Conway.ConwayMempoolFailure msg) = - mconcat [ "kind" .= String "ConwayMempoolFailure" - , "message" .= msg - ] - - -instance Ledger.EraPParams era => ToObject (Conway.ConwayGovPredFailure era) where - toObject _ (Conway.GovActionsDoNotExist govActionIds) = - mconcat [ "kind" .= String "GovActionsDoNotExist" - , "govActionIds" .= map govActionIdToText (NonEmpty.toList govActionIds) - ] - toObject _ (Conway.MalformedProposal govAction) = - mconcat [ "kind" .= String "MalformedProposal" - , "govAction" .= govAction - ] - toObject _ (Conway.ProposalProcedureNetworkIdMismatch rewardAcnt network) = - mconcat [ "kind" .= String "ProposalProcedureNetworkIdMismatch" - , "rewardAccount" .= toJSON rewardAcnt - , "expectedNetworkId" .= toJSON network - ] - toObject _ (Conway.TreasuryWithdrawalsNetworkIdMismatch rewardAcnts network) = - mconcat [ "kind" .= String "TreasuryWithdrawalsNetworkIdMismatch" - , "rewardAccounts" .= toJSON rewardAcnts - , "expectedNetworkId" .= toJSON network - ] - toObject _ (Conway.ProposalDepositIncorrect Mismatch {mismatchSupplied, mismatchExpected}) = - mconcat [ "kind" .= String "ProposalDepositIncorrect" - , "deposit" .= mismatchSupplied - , "expectedDeposit" .= mismatchExpected - ] - toObject _ (Conway.DisallowedVoters govActionIdToVoter) = - mconcat [ "kind" .= String "DisallowedVoters" - , "govActionIdToVoter" .= NonEmpty.toList govActionIdToVoter - ] - toObject _ (Conway.VotersDoNotExist creds) = - mconcat [ "kind" .= String "VotersDoNotExist" - , "credentials" .= creds - ] - toObject _ (Conway.ConflictingCommitteeUpdate creds) = - mconcat [ "kind" .= String "ConflictingCommitteeUpdate" - , "credentials" .= creds - ] - toObject _ (Conway.ExpirationEpochTooSmall credsToEpoch) = - mconcat [ "kind" .= String "ExpirationEpochTooSmall" - , "credentialsToEpoch" .= credsToEpoch - ] - toObject _ (Conway.InvalidPrevGovActionId proposalProcedure) = - mconcat [ "kind" .= String "InvalidPrevGovActionId" - , "proposalProcedure" .= proposalProcedure - ] - toObject _ (Conway.VotingOnExpiredGovAction actions) = - mconcat [ "kind" .= String "VotingOnExpiredGovAction" - , "action" .= actions - ] - toObject _ (Conway.ProposalCantFollow prevGovActionId Mismatch {mismatchSupplied, mismatchExpected}) = - mconcat [ "kind" .= String "ProposalCantFollow" - , "prevGovActionId" .= prevGovActionId - , "protVer" .= mismatchSupplied - , "prevProtVer" .= mismatchExpected - ] - toObject _ (Conway.DisallowedProposalDuringBootstrap proposal) = - mconcat [ "kind" .= String "DisallowedProposalDuringBootstrap" - , "proposal" .= proposal - ] - - toObject _ (Conway.DisallowedVotesDuringBootstrap votes) = - mconcat [ "kind" .= String "DisallowedVotesDuringBootstrap" - , "votes" .= votes - ] - - toObject _ (Conway.ZeroTreasuryWithdrawals govAction) = - mconcat [ "kind" .= String "ZeroTreasuryWithdrawals" - , "govAction" .= govAction - ] - - toObject _ (Conway.ProposalReturnAccountDoesNotExist account) = - mconcat [ "kind" .= String "DisallowedVotesDuringBootstrap" - , "invalidAccount" .= account - ] - - toObject _ (Conway.TreasuryWithdrawalReturnAccountsDoNotExist accounts) = - mconcat [ "kind" .= String "TreasuryWithdrawalReturnAccountsDoNotExist" - , "invalidAccounts" .= accounts - ] - toObject _ (Conway.UnelectedCommitteeVoters creds) = - mconcat [ "kind" .= String "UnelectedCommitteeVoters" - , "unelectedCommitteeVoters" .= creds - ] - toObject _ (Conway.InvalidGuardrailsScriptHash actualScriptHash expectedScriptHash) = - mconcat [ "kind" .= String "InvalidGuardrailsScriptHash" - , "actualGuardrailsScriptHash" .= actualScriptHash - , "expectedGuardrailsScriptHash" .= expectedScriptHash - ] - -instance - ( ToObject (PredicateFailure (Ledger.EraRule "CERT" era)) - ) => ToObject (Conway.ConwayCertsPredFailure era) where - toObject verb = \case - Conway.WithdrawalsNotInRewardsCERTS incorrectWithdrawals -> - mconcat [ "kind" .= String "WithdrawalsNotInRewardsCERTS" , "incorrectWithdrawals" .= unWithdrawals incorrectWithdrawals ] - Conway.CertFailure f -> toObject verb f - -instance - ( ToObject (PredicateFailure (Core.EraRule "CERTS" ledgerera)) - , ToObject (PredicateFailure (Core.EraRule "UTXOW" ledgerera)) - , ToObject (PredicateFailure (Core.EraRule "GOV" ledgerera)) - ) => ToObject (Dijkstra.DijkstraLedgerPredFailure ledgerera) where - toObject _verb = error "Dijkstra era is not active yet" - -instance - (ToObject (PredicateFailure (Core.EraRule "CERTS" ledgerera)) - ) => ToObject (Dijkstra.DijkstraGovCertPredFailure ledgerera) where - toObject _verb = error "Dijkstra era is not active yet" - -instance - (ToObject (PredicateFailure (Core.EraRule "CERTS" ledgerera)) - ) => ToObject (Dijkstra.DijkstraGovPredFailure ledgerera) where - toObject _verb = error "Dijkstra era is not active yet" - -instance - (ToObject (PredicateFailure (Core.EraRule "UTXOW" ledgerera)) - ) => ToObject (Dijkstra.DijkstraUtxowPredFailure ledgerera) where - toObject _verb = error "Dijkstra era is not active yet" - -instance - (ToObject (PredicateFailure (Core.EraRule "CERTS" ledgerera)) - ) => ToObject (Dijkstra.DijkstraBbodyPredFailure ledgerera) where - toObject _verb = error "Dijkstra era is not active yet" - -instance - (ToObject (PredicateFailure (Core.EraRule "CERTS" ledgerera)) - ) => ToObject (Dijkstra.DijkstraUtxoPredFailure ledgerera) where - toObject _verb = error "Dijkstra era is not active yet" - -instance - ( Api.ShelleyLedgerEra era ~ ledgerera - , Api.IsShelleyBasedEra era - , ToObject (Ledger.EraRuleFailure "PPUP" ledgerera) - , ToObject (PredicateFailure (Ledger.EraRule "UTXO" ledgerera)) - , Show (Ledger.Value ledgerera) - , ToJSON (Ledger.Value ledgerera) - , ToJSON (Ledger.TxOut ledgerera) - ) => ToObject (AlonzoUtxowPredFailure ledgerera) where - toObject v (ShelleyInAlonzoUtxowPredFailure utxoPredFail) = - toObject v utxoPredFail - toObject _ (MissingRedeemers scripts) = - mconcat [ "kind" .= String "MissingRedeemers" - , "scripts" .= renderMissingRedeemers Api.shelleyBasedEra scripts - ] - toObject _ (MissingRequiredDatums required received) = - mconcat [ "kind" .= String "MissingRequiredDatums" - , "required" .= map (Crypto.hashToTextAsHex . Hashes.extractHash) - (NonEmptySet.toList required) - , "received" .= map (Crypto.hashToTextAsHex . Hashes.extractHash) - (Set.toList received) - ] - toObject _ (PPViewHashesDontMatch Mismatch {mismatchSupplied, mismatchExpected}) = - mconcat [ "kind" .= String "PPViewHashesDontMatch" - , "fromTxBody" .= renderScriptIntegrityHash (strictMaybeToMaybe mismatchSupplied) - , "fromPParams" .= renderScriptIntegrityHash (strictMaybeToMaybe mismatchExpected) - ] - toObject _ (UnspendableUTxONoDatumHash txins) = - mconcat [ "kind" .= String "MissingRequiredSigners" - , "txins" .= NonEmptySet.toList txins - ] - toObject _ (NotAllowedSupplementalDatums disallowed acceptable) = - mconcat [ "kind" .= String "NotAllowedSupplementalDatums" - , "disallowed" .= NonEmptySet.toList disallowed - , "acceptable" .= Set.toList acceptable - ] - toObject _ (ExtraRedeemers rdmrs) = - Api.caseShelleyToMaryOrAlonzoEraOnwards - (const mempty) - (\alonzoOnwards -> - mconcat - [ "kind" .= String "ExtraRedeemers" - , "rdmrs" .= map (Api.toScriptIndex alonzoOnwards) (NonEmpty.toList rdmrs) - ] - ) - (Api.shelleyBasedEra :: Api.ShelleyBasedEra era) - toObject _ (ScriptIntegrityHashMismatch poolId vrfKeyHash) = - mconcat [ "kind" .= String "VRFKeyHashAlreadyRegistered" - , "poolId" .= String (textShow poolId) - , "vrfKeyHash" .= String (textShow vrfKeyHash) - , "error" .= String "Pool with the same VRF Key Hash is already registered" - ] - -instance - ( ToObject (PredicateFailure (Core.EraRule "UTXO" ledgerera)) - ) => ToObject (ShelleyUtxowPredFailure ledgerera) where - toObject _verb (ExtraneousScriptWitnessesUTXOW extraneousScripts) = - mconcat [ "kind" .= String "ExtraneousScriptWitnessesUTXOW" - , "extraneousScripts" .= map renderScriptHash (NonEmptySet.toList extraneousScripts) - ] - toObject _verb (InvalidWitnessesUTXOW wits') = - mconcat [ "kind" .= String "InvalidWitnessesUTXOW" - , "invalidWitnesses" .= map textShow (NonEmpty.toList wits') - ] - toObject _verb (MissingVKeyWitnessesUTXOW wits') = - mconcat [ "kind" .= String "MissingVKeyWitnessesUTXOW" - , "missingWitnesses" .= wits' - ] - toObject _verb (MissingScriptWitnessesUTXOW missingScripts) = - mconcat [ "kind" .= String "MissingScriptWitnessesUTXOW" - , "missingScripts" .= missingScripts - ] - toObject _verb (ScriptWitnessNotValidatingUTXOW failedScripts) = - mconcat [ "kind" .= String "ScriptWitnessNotValidatingUTXOW" - , "failedScripts" .= failedScripts - ] - toObject verb (UtxoFailure f) = toObject verb f - toObject _verb (MIRInsufficientGenesisSigsUTXOW genesisSigs) = - mconcat [ "kind" .= String "MIRInsufficientGenesisSigsUTXOW" - , "genesisSigs" .= genesisSigs - ] - toObject _verb (MissingTxBodyMetadataHash metadataHash) = - mconcat [ "kind" .= String "MissingTxBodyMetadataHash" - , "metadataHash" .= metadataHash - ] - toObject _verb (MissingTxMetadata txBodyMetadataHash) = - mconcat [ "kind" .= String "MissingTxMetadata" - , "txBodyMetadataHash" .= txBodyMetadataHash - ] - -- TODO are these arguments in the right order? - toObject _verb (ConflictingMetadataHash Mismatch { mismatchSupplied = txBodyMetadataHash - , mismatchExpected = fullMetadataHash }) = - mconcat [ "kind" .= String "ConflictingMetadataHash" - , "txBodyMetadataHash" .= txBodyMetadataHash - , "fullMetadataHash" .= fullMetadataHash - ] - toObject _verb InvalidMetadata = - mconcat [ "kind" .= String "InvalidMetadata" - ] - -instance - ( ToObject (Ledger.EraRuleFailure "PPUP" ledgerera) - , Show (Ledger.Value ledgerera) - , ToJSON (Ledger.Value ledgerera) - , ToJSON (Ledger.TxOut ledgerera) - ) => ToObject (ShelleyUtxoPredFailure ledgerera) where - toObject _verb (BadInputsUTxO badInputs) = - mconcat [ "kind" .= String "BadInputsUTxO" - , "badInputs" .= badInputs - , "error" .= renderBadInputsUTxOErr (NonEmptySet.toSet badInputs) - ] - toObject _verb (ExpiredUTxO Mismatch {mismatchSupplied, mismatchExpected}) = - mconcat [ "kind" .= String "ExpiredUTxO" - , "ttl" .= mismatchSupplied - , "slot" .= mismatchExpected ] - toObject _verb (MaxTxSizeUTxO Mismatch { mismatchSupplied = txsize - , mismatchExpected = maxtxsize }) = - mconcat [ "kind" .= String "MaxTxSizeUTxO" - , "size" .= txsize - , "maxSize" .= maxtxsize ] - -- TODO: Add the minimum allowed UTxO value to OutputTooSmallUTxO - toObject _verb (OutputTooSmallUTxO badOutputs) = - mconcat [ "kind" .= String "OutputTooSmallUTxO" - , "outputs" .= badOutputs - , "error" .= String - ( mconcat - [ "The output is smaller than the allow minimum " - , "UTxO value defined in the protocol parameters" - ] - ) - ] - toObject _verb (OutputBootAddrAttrsTooBig badOutputs) = - mconcat [ "kind" .= String "OutputBootAddrAttrsTooBig" - , "outputs" .= badOutputs - , "error" .= String "The Byron address attributes are too big" - ] - toObject _verb InputSetEmptyUTxO = - mconcat [ "kind" .= String "InputSetEmptyUTxO" ] - toObject _verb (FeeTooSmallUTxO Mismatch { mismatchSupplied = minfee - , mismatchExpected = txfee }) = - mconcat [ "kind" .= String "FeeTooSmallUTxO" - , "minimum" .= minfee - , "fee" .= txfee ] - toObject _verb (ValueNotConservedUTxO Mismatch {mismatchSupplied, mismatchExpected}) = - mconcat [ "kind" .= String "ValueNotConservedUTxO" - , "consumed" .= mismatchSupplied - , "produced" .= mismatchExpected - , "error" .= renderValueNotConservedErr mismatchSupplied mismatchExpected - ] - toObject verb (UpdateFailure f) = toObject verb f - - toObject _verb (WrongNetwork network addrs) = - mconcat [ "kind" .= String "WrongNetwork" - , "network" .= network - , "addrs" .= addrs - ] - toObject _verb (WrongNetworkWithdrawal network addrs) = - mconcat [ "kind" .= String "WrongNetworkWithdrawal" - , "network" .= network - , "addrs" .= addrs - ] - -instance - ( ToObject (Ledger.EraRuleFailure "PPUP" ledgerera) - , ToJSON (Ledger.TxOut ledgerera) - , Show (Ledger.Value ledgerera) - , ToJSON (Ledger.Value ledgerera) - ) => ToObject (AllegraUtxoPredFailure ledgerera) where - toObject _verb (Allegra.BadInputsUTxO badInputs) = - mconcat [ "kind" .= String "BadInputsUTxO" - , "badInputs" .= badInputs - , "error" .= renderBadInputsUTxOErr (NonEmptySet.toSet badInputs) - ] - toObject _verb (Allegra.OutsideValidityIntervalUTxO validityInterval slot) = - mconcat [ "kind" .= String "ExpiredUTxO" - , "validityInterval" .= validityInterval - , "slot" .= slot ] - toObject _verb (Allegra.MaxTxSizeUTxO Mismatch {mismatchSupplied, mismatchExpected}) = - mconcat [ "kind" .= String "MaxTxSizeUTxO" - , "size" .= mismatchSupplied - , "maxSize" .= mismatchExpected ] - toObject _verb Allegra.InputSetEmptyUTxO = - mconcat [ "kind" .= String "InputSetEmptyUTxO" ] - toObject _verb (Allegra.FeeTooSmallUTxO Mismatch {mismatchSupplied, mismatchExpected}) = - mconcat [ "kind" .= String "FeeTooSmallUTxO" - , "minimum" .= mismatchExpected - , "fee" .= mismatchSupplied ] - toObject _verb (Allegra.ValueNotConservedUTxO Mismatch {mismatchSupplied, mismatchExpected}) = - mconcat [ "kind" .= String "ValueNotConservedUTxO" - , "consumed" .= mismatchSupplied - , "produced" .= mismatchExpected - , "error" .= renderValueNotConservedErr mismatchSupplied mismatchExpected - ] - toObject _verb (Allegra.WrongNetwork network addrs) = - mconcat [ "kind" .= String "WrongNetwork" - , "network" .= network - , "addrs" .= addrs - ] - toObject _verb (Allegra.WrongNetworkWithdrawal network addrs) = - mconcat [ "kind" .= String "WrongNetworkWithdrawal" - , "network" .= network - , "addrs" .= addrs - ] - -- TODO: Add the minimum allowed UTxO value to OutputTooSmallUTxO - toObject _verb (Allegra.OutputTooSmallUTxO badOutputs) = - mconcat [ "kind" .= String "OutputTooSmallUTxO" - , "outputs" .= badOutputs - , "error" .= String - ( mconcat - [ "The output is smaller than the allow minimum " - , "UTxO value defined in the protocol parameters" - ] - ) - ] - toObject verb (Allegra.UpdateFailure f) = toObject verb f - toObject _verb (Allegra.OutputBootAddrAttrsTooBig badOutputs) = - mconcat [ "kind" .= String "OutputBootAddrAttrsTooBig" - , "outputs" .= badOutputs - , "error" .= String "The Byron address attributes are too big" - ] - toObject _verb (Allegra.OutputTooBigUTxO badOutputs) = - mconcat [ "kind" .= String "OutputTooBigUTxO" - , "outputs" .= badOutputs - , "error" .= String "Too many asset ids in the tx output" - ] - -renderBadInputsUTxOErr :: Set TxIn -> Aeson.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 -> Aeson.Value -renderValueNotConservedErr consumed produced = String $ - "This transaction consumed " <> textShow consumed <> " but produced " <> textShow produced - -instance Ledger.Era era => ToObject (ShelleyPpupPredFailure era) where - toObject _verb (NonGenesisUpdatePPUP Mismatch { mismatchSupplied = proposalKeys - , mismatchExpected = genesisKeys }) = - mconcat [ "kind" .= String "NonGenesisUpdatePPUP" - , "keys" .= proposalKeys Set.\\ genesisKeys ] - toObject _verb (PPUpdateWrongEpoch currEpoch intendedEpoch votingPeriod) = - mconcat [ "kind" .= String "PPUpdateWrongEpoch" - , "currentEpoch" .= currEpoch - , "intendedEpoch" .= intendedEpoch - , "votingPeriod" .= String (textShow votingPeriod) - ] - toObject _verb (PVCannotFollowPPUP badPv) = - mconcat [ "kind" .= String "PVCannotFollowPPUP" - , "badProtocolVersion" .= badPv - ] - - -instance - ( ToObject (PredicateFailure (Core.EraRule "DELPL" ledgerera)) - ) => ToObject (ShelleyDelegsPredFailure ledgerera) where - toObject verb (DelplFailure f) = toObject verb f - - -instance - ( ToObject (PredicateFailure (Core.EraRule "POOL" ledgerera)) - , ToObject (PredicateFailure (Core.EraRule "DELEG" ledgerera)) - ) => ToObject (ShelleyDelplPredFailure ledgerera) where - toObject verb (PoolFailure f) = toObject verb f - toObject verb (DelegFailure f) = toObject verb f - -instance Ledger.Era era => ToObject (ShelleyDelegPredFailure era) where - toObject _verb (StakeKeyAlreadyRegisteredDELEG alreadyRegistered) = - mconcat [ "kind" .= String "StakeKeyAlreadyRegisteredDELEG" - , "credential" .= String (textShow alreadyRegistered) - , "error" .= String "Staking credential already registered" - ] - toObject _verb (StakeKeyNotRegisteredDELEG notRegistered) = - mconcat [ "kind" .= String "StakeKeyNotRegisteredDELEG" - , "credential" .= String (textShow notRegistered) - , "error" .= String "Staking credential not registered" - ] - toObject _verb (StakeKeyNonZeroAccountBalanceDELEG remBalance) = - mconcat [ "kind" .= String "StakeKeyNonZeroAccountBalanceDELEG" - , "remainingBalance" .= remBalance - ] - toObject _verb (StakeDelegationImpossibleDELEG unregistered) = - mconcat [ "kind" .= String "StakeDelegationImpossibleDELEG" - , "credential" .= String (textShow unregistered) - , "error" .= String "Cannot delegate this stake credential because it is not registered" - ] - toObject _verb WrongCertificateTypeDELEG = - mconcat [ "kind" .= String "WrongCertificateTypeDELEG" ] - toObject _verb (GenesisKeyNotInMappingDELEG (KeyHash genesisKeyHash)) = - mconcat [ "kind" .= String "GenesisKeyNotInMappingDELEG" - , "unknownKeyHash" .= String (textShow genesisKeyHash) - , "error" .= String "This genesis key is not in the delegation mapping" - ] - toObject _verb (DuplicateGenesisDelegateDELEG (KeyHash genesisKeyHash)) = - mconcat [ "kind" .= String "DuplicateGenesisDelegateDELEG" - , "duplicateKeyHash" .= String (textShow genesisKeyHash) - , "error" .= String "This genesis key has already been delegated to" - ] - toObject _verb (InsufficientForInstantaneousRewardsDELEG mirpot Mismatch {mismatchSupplied, mismatchExpected}) = - mconcat [ "kind" .= String "InsufficientForInstantaneousRewardsDELEG" - , "pot" .= String (case mirpot of - ReservesMIR -> "Reserves" - TreasuryMIR -> "Treasury") - , "neededAmount" .= mismatchSupplied - , "reserves" .= mismatchExpected - ] - toObject _verb (MIRCertificateTooLateinEpochDELEG Mismatch {mismatchSupplied, mismatchExpected}) = - mconcat [ "kind" .= String "MIRCertificateTooLateinEpochDELEG" - , "currentSlotNo" .= mismatchSupplied - , "mustBeSubmittedBeforeSlotNo" .= mismatchExpected - ] - toObject _verb (DuplicateGenesisVRFDELEG vrfKeyHash) = - mconcat [ "kind" .= String "DuplicateGenesisVRFDELEG" - , "keyHash" .= vrfKeyHash - ] - toObject _verb MIRTransferNotCurrentlyAllowed = - mconcat [ "kind" .= String "MIRTransferNotCurrentlyAllowed" - ] - toObject _verb MIRNegativesNotCurrentlyAllowed = - mconcat [ "kind" .= String "MIRNegativesNotCurrentlyAllowed" - ] - toObject _verb (InsufficientForTransferDELEG mirpot Mismatch {mismatchSupplied, mismatchExpected}) = - mconcat [ "kind" .= String "DuplicateGenesisVRFDELEG" - , "pot" .= String (case mirpot of - ReservesMIR -> "Reserves" - TreasuryMIR -> "Treasury") - , "attempted" .= mismatchSupplied - , "available" .= mismatchExpected - ] - toObject _verb MIRProducesNegativeUpdate = - mconcat [ "kind" .= String "MIRProducesNegativeUpdate" - ] - toObject _verb (MIRNegativeTransfer pot coin) = - mconcat [ "kind" .= String "MIRNegativeTransfer" - , "error" .= String "Attempt to transfer a negative amount from a pot." - , "pot" .= String (case pot of - ReservesMIR -> "Reserves" - TreasuryMIR -> "Treasury") - , "amount" .= coin - ] - toObject _verb (DelegateeNotRegisteredDELEG keyHash) = - mconcat [ "kind" .= String "DelegateeNotRegisteredDELEG" - , "unregisteredKeyHash" .= keyHash - ] - -instance ToObject (ShelleyPoolPredFailure era) where - toObject _verb (StakePoolNotRegisteredOnKeyPOOL (KeyHash unregStakePool)) = - mconcat [ "kind" .= String "StakePoolNotRegisteredOnKeyPOOL" - , "unregisteredKeyHash" .= String (textShow unregStakePool) - , "error" .= String "This stake pool key hash is unregistered" - ] - toObject _dtal (StakePoolRetirementWrongEpochPOOL - -- inspired by Ledger's Test.Cardano.Ledger.Generic.PrettyCore - -- but is it correct here? - Mismatch { mismatchExpected = currentEpoch } - Mismatch { mismatchSupplied = intendedRetireEpoch - , mismatchExpected = maxRetireEpoch}) = - mconcat [ "kind" .= String "StakePoolRetirementWrongEpochPOOL" - , "currentEpoch" .= String (textShow currentEpoch) - , "intendedRetirementEpoch" .= String (textShow intendedRetireEpoch) - , "maxEpochForRetirement" .= String (textShow maxRetireEpoch) - ] - -- TODO is this in the right order? - toObject _verb (StakePoolCostTooLowPOOL - Mismatch { mismatchSupplied = certCost - , mismatchExpected = protCost }) = - mconcat [ "kind" .= String "StakePoolCostTooLowPOOL" - , "certificateCost" .= String (textShow certCost) - , "protocolParCost" .= String (textShow protCost) - , "error" .= String "The stake pool cost is too low" - ] - toObject _verb (PoolMedataHashTooBig poolID hashSize) = - mconcat [ "kind" .= String "PoolMedataHashTooBig" - , "poolID" .= String (textShow poolID) - , "hashSize" .= String (textShow hashSize) - , "error" .= String "The stake pool metadata hash is too large" - ] - toObject _ (VRFKeyHashAlreadyRegistered poolId vrfKeyHash) = - mconcat [ "kind" .= String "VRFKeyHashAlreadyRegistered" - , "poolId" .= String (textShow poolId) - , "vrfKeyHash" .= String (textShow vrfKeyHash) - , "error" .= String "Pool with the same VRF Key Hash is already registered" - ] - --- Apparently this should never happen according to the Shelley exec spec - -- toObject _verb (WrongCertificateTypePOOL index) = - -- case index of - -- 0 -> mconcat [ "kind" .= String "WrongCertificateTypePOOL" - -- , "error" .= String "Wrong certificate type: Delegation certificate" - -- ] - -- 1 -> mconcat [ "kind" .= String "WrongCertificateTypePOOL" - -- , "error" .= String "Wrong certificate type: MIR certificate" - -- ] - -- 2 -> mconcat [ "kind" .= String "WrongCertificateTypePOOL" - -- , "error" .= String "Wrong certificate type: Genesis certificate" - -- ] - -- k -> mconcat [ "kind" .= String "WrongCertificateTypePOOL" - -- , "certificateType" .= k - -- , "error" .= String "Wrong certificate type: Unknown certificate type" - -- ] - - -- TODO are these in the right order? - toObject _verb (WrongNetworkPOOL Mismatch { mismatchSupplied = networkId - , mismatchExpected = listedNetworkId } - poolId) = - mconcat [ "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 ToObject TicknPredicateFailure where - toObject _verb x = case x of {} -- no constructors - -instance Core.Crypto crypto => ToObject (PrtclPredicateFailure crypto) where - toObject verb (OverlayFailure f) = toObject verb f - toObject verb (UpdnFailure f) = toObject verb f - - -instance Core.Crypto crypto => ToObject (OverlayPredicateFailure crypto) where - toObject _verb (UnknownGenesisKeyOVERLAY (KeyHash genKeyHash)) = - mconcat [ "kind" .= String "UnknownGenesisKeyOVERLAY" - , "unknownKeyHash" .= String (textShow genKeyHash) - ] - toObject _verb (VRFKeyBadLeaderValue seedNonce (SlotNo currSlotNo) prevHashNonce leaderElecVal) = - mconcat [ "kind" .= String "VRFKeyBadLeaderValueOVERLAY" - , "seedNonce" .= String (textShow seedNonce) - , "currentSlot" .= String (textShow currSlotNo) - , "previousHashAsNonce" .= String (textShow prevHashNonce) - , "leaderElectionValue" .= String (textShow leaderElecVal) - ] - toObject _verb (VRFKeyBadNonce seedNonce (SlotNo currSlotNo) prevHashNonce blockNonce) = - mconcat [ "kind" .= String "VRFKeyBadNonceOVERLAY" - , "seedNonce" .= String (textShow seedNonce) - , "currentSlot" .= String (textShow currSlotNo) - , "previousHashAsNonce" .= String (textShow prevHashNonce) - , "blockNonce" .= String (textShow blockNonce) - ] - toObject _verb (VRFKeyWrongVRFKey issuerHash regVRFKeyHash unregVRFKeyHash) = - mconcat [ "kind" .= String "VRFKeyWrongVRFKeyOVERLAY" - , "poolHash" .= textShow issuerHash - , "registeredVRFKeHash" .= textShow regVRFKeyHash - , "unregisteredVRFKeyHash" .= textShow unregVRFKeyHash - ] - --TODO: Pipe slot number with VRFKeyUnknown - toObject _verb (VRFKeyUnknown (KeyHash kHash)) = - mconcat [ "kind" .= String "VRFKeyUnknownOVERLAY" - , "keyHash" .= String (textShow kHash) - ] - toObject _verb (VRFLeaderValueTooBig leadElecVal weightOfDelegPool actSlotCoefff) = - mconcat [ "kind" .= String "VRFLeaderValueTooBigOVERLAY" - , "leaderElectionValue" .= String (textShow leadElecVal) - , "delegationPoolWeight" .= String (textShow weightOfDelegPool) - , "activeSlotCoefficient" .= String (textShow actSlotCoefff) - ] - toObject _verb (NotActiveSlotOVERLAY notActiveSlotNo) = - -- TODO: Elaborate on NotActiveSlot error - mconcat [ "kind" .= String "NotActiveSlotOVERLAY" - , "slot" .= String (textShow notActiveSlotNo) - ] - toObject _verb (WrongGenesisColdKeyOVERLAY actual expected) = - mconcat [ "kind" .= String "WrongGenesisColdKeyOVERLAY" - , "actual" .= actual - , "expected" .= expected ] - toObject _verb (WrongGenesisVRFKeyOVERLAY issuer actual expected) = - mconcat [ "kind" .= String "WrongGenesisVRFKeyOVERLAY" - , "issuer" .= issuer - , "actual" .= actual - , "expected" .= expected ] - toObject verb (OcertFailure f) = toObject verb f - - -instance ToObject OcertPredicateFailure where - toObject _verb (KESBeforeStartOCERT (KESPeriod oCertstart) (KESPeriod current)) = - mconcat [ "kind" .= String "KESBeforeStartOCERT" - , "opCertKESStartPeriod" .= String (textShow oCertstart) - , "currentKESPeriod" .= String (textShow current) - , "error" .= String - ( mconcat - [ "Your operational certificate's KES start period " - , "is before the KES current period." - ] - ) - ] - toObject _verb (KESAfterEndOCERT (KESPeriod current) (KESPeriod oCertstart) maxKESEvolutions) = - mconcat [ "kind" .= String "KESAfterEndOCERT" - , "currentKESPeriod" .= String (textShow current) - , "opCertKESStartPeriod" .= String (textShow oCertstart) - , "maxKESEvolutions" .= String (textShow maxKESEvolutions) - , "error" .= String - ( mconcat - [ "The operational certificate's KES start period is " - , "greater than the max number of KES + the KES current period" - ] - ) - ] - toObject _verb (CounterTooSmallOCERT lastKEScounterUsed currentKESCounter) = - mconcat [ "kind" .= String "CounterTooSmallOCert" - , "currentKESCounter" .= String (textShow currentKESCounter) - , "lastKESCounter" .= String (textShow lastKEScounterUsed) - , "error" .= String - ( mconcat - [ "The operational certificate's last KES counter is greater " - , "than the current KES counter." - ] - ) - ] - toObject _verb (InvalidSignatureOCERT oCertCounter oCertKESStartPeriod) = - mconcat [ "kind" .= String "InvalidSignatureOCERT" - , "opCertKESStartPeriod" .= String (textShow oCertKESStartPeriod) - , "opCertCounter" .= String (textShow oCertCounter) - ] - toObject _verb (InvalidKesSignatureOCERT currKESPeriod startKESPeriod expectedKESEvolutions err) = - mconcat [ "kind" .= String "InvalidKesSignatureOCERT" - , "opCertKESStartPeriod" .= String (textShow startKESPeriod) - , "opCertKESCurrentPeriod" .= String (textShow currKESPeriod) - , "opCertExpectedKESEvolutions" .= String (textShow expectedKESEvolutions) - , "error" .= err ] - toObject _verb (NoCounterForKeyHashOCERT (KeyHash stakePoolKeyHash)) = - mconcat [ "kind" .= String "NoCounterForKeyHashOCERT" - , "stakePoolKeyHash" .= String (textShow stakePoolKeyHash) - , "error" .= String "A counter was not found for this stake pool key hash" - ] - -instance ToObject HotKey.KESInfo where - toObject _verb HotKey.KESInfo { kesStartPeriod, kesEndPeriod, kesEvolution } = - mconcat - [ "kind" .= String "KESInfo" - , "startPeriod" .= kesStartPeriod - , "endPeriod" .= kesEndPeriod - , "evolution" .= kesEvolution - ] - -instance ToObject HotKey.KESEvolutionError where - toObject verb (HotKey.KESCouldNotEvolve kesInfo targetPeriod) = - mconcat - [ "kind" .= String "KESCouldNotEvolve" - , "kesInfo" .= toObject verb kesInfo - , "targetPeriod" .= targetPeriod - ] - toObject verb (HotKey.KESKeyAlreadyPoisoned kesInfo targetPeriod) = - mconcat - [ "kind" .= String "KESKeyAlreadyPoisoned" - , "kesInfo" .= toObject verb kesInfo - , "targetPeriod" .= targetPeriod - ] - -instance ToObject (UpdnPredicateFailure crypto) where - toObject _verb x = case x of {} -- no constructors - --- instance ToObject (ShelleyUpecPredFailure era) where --- toObject _verb (NewPpFailure (UnexpectedDepositPot totalOutstanding depositPot)) = --- mconcat [ "kind" .= String "UnexpectedDepositPot" --- , "totalOutstanding" .= String (textShow totalOutstanding) --- , "depositPot" .= String (textShow depositPot) --- ] - - --------------------------------------------------------------------------------- --- Alonzo related --------------------------------------------------------------------------------- - - -instance - ( Ledger.Era ledgerera - , ToObject (PredicateFailure (Ledger.EraRule "UTXOS" ledgerera)) - , ToObject (Ledger.EraRuleFailure "PPUP" ledgerera) - , ToJSON (Ledger.TxOut ledgerera) - , Show (Ledger.Value ledgerera) - , ToJSON (Ledger.Value ledgerera) - ) => ToObject (AlonzoUtxoPredFailure ledgerera) where - toObject _verb (Alonzo.BadInputsUTxO badInputs) = - mconcat [ "kind" .= String "BadInputsUTxO" - , "badInputs" .= badInputs - , "error" .= renderBadInputsUTxOErr (NonEmptySet.toSet badInputs) - ] - toObject _verb (Alonzo.OutsideValidityIntervalUTxO validtyInterval slot) = - mconcat [ "kind" .= String "ExpiredUTxO" - , "validityInterval" .= validtyInterval - , "slot" .= slot - ] - toObject _verb (Alonzo.MaxTxSizeUTxO Mismatch {mismatchSupplied, mismatchExpected}) = - mconcat [ "kind" .= String "MaxTxSizeUTxO" - , "size" .= mismatchSupplied - , "maxSize" .= mismatchExpected - ] - toObject _verb Alonzo.InputSetEmptyUTxO = - mconcat [ "kind" .= String "InputSetEmptyUTxO" ] - toObject _verb (Alonzo.FeeTooSmallUTxO Mismatch {mismatchSupplied, mismatchExpected}) = - mconcat [ "kind" .= String "FeeTooSmallUTxO" - , "minimum" .= mismatchExpected - , "fee" .= mismatchSupplied - ] - toObject _verb (Alonzo.ValueNotConservedUTxO Mismatch {mismatchSupplied, mismatchExpected}) = - mconcat [ "kind" .= String "ValueNotConservedUTxO" - , "consumed" .= mismatchSupplied - , "produced" .= mismatchExpected - , "error" .= renderValueNotConservedErr mismatchSupplied mismatchExpected - ] - toObject _verb (Alonzo.WrongNetwork network addrs) = - mconcat [ "kind" .= String "WrongNetwork" - , "network" .= network - , "addrs" .= addrs - ] - toObject _verb (Alonzo.WrongNetworkWithdrawal network addrs) = - mconcat [ "kind" .= String "WrongNetworkWithdrawal" - , "network" .= network - , "addrs" .= addrs - ] - toObject _verb (Alonzo.OutputTooSmallUTxO badOutputs) = - mconcat [ "kind" .= String "OutputTooSmallUTxO" - , "outputs" .= badOutputs - , "error" .= String - ( mconcat - [ "The output is smaller than the allow minimum " - , "UTxO value defined in the protocol parameters" - ] - ) - ] - toObject verb (Alonzo.UtxosFailure predFailure) = - toObject verb predFailure - toObject _verb (Alonzo.OutputBootAddrAttrsTooBig txouts) = - mconcat [ "kind" .= String "OutputBootAddrAttrsTooBig" - , "outputs" .= txouts - , "error" .= String "The Byron address attributes are too big" - ] - toObject _verb (Alonzo.OutputTooBigUTxO badOutputs) = - mconcat [ "kind" .= String "OutputTooBigUTxO" - , "outputs" .= badOutputs - , "error" .= String "Too many asset ids in the tx output" - ] - toObject _verb (Alonzo.InsufficientCollateral computedBalance suppliedFee) = - mconcat [ "kind" .= String "InsufficientCollateral" - , "balance" .= computedBalance - , "txfee" .= suppliedFee - ] - toObject _verb (Alonzo.ScriptsNotPaidUTxO utxos) = - mconcat [ "kind" .= String "ScriptsNotPaidUTxO" - , "utxos" .= utxos - ] - toObject _verb (Alonzo.ExUnitsTooBigUTxO Mismatch {mismatchSupplied, mismatchExpected}) = - mconcat [ "kind" .= String "ExUnitsTooBigUTxO" - , "maxexunits" .= mismatchExpected - , "exunits" .= mismatchSupplied - ] - toObject _verb (Alonzo.CollateralContainsNonADA inputs) = - mconcat [ "kind" .= String "CollateralContainsNonADA" - , "inputs" .= inputs - ] - toObject _verb (Alonzo.WrongNetworkInTxBody Mismatch {mismatchSupplied, mismatchExpected}) = - mconcat [ "kind" .= String "WrongNetworkInTxBody" - , "networkid" .= mismatchExpected - , "txbodyNetworkId" .= mismatchSupplied - ] - toObject _verb (Alonzo.OutsideForecast slotNum) = - mconcat [ "kind" .= String "OutsideForecast" - , "slot" .= slotNum - ] - toObject _verb (Alonzo.TooManyCollateralInputs Mismatch {mismatchSupplied, mismatchExpected}) = - mconcat [ "kind" .= String "TooManyCollateralInputs" - , "max" .= mismatchExpected - , "inputs" .= mismatchSupplied - ] - toObject _verb Alonzo.NoCollateralInputs = - mconcat [ "kind" .= String "NoCollateralInputs" ] - -instance - ( ToJSON (Alonzo.CollectError ledgerera) - , ToObject (Ledger.EraRuleFailure "PPUP" ledgerera) - ) => ToObject (AlonzoUtxosPredFailure ledgerera) where - toObject _ (Alonzo.ValidationTagMismatch isValidating reason) = - mconcat [ "kind" .= String "ValidationTagMismatch" - , "isvalidating" .= isValidating - , "reason" .= reason - ] - toObject _ (Alonzo.CollectErrors errors) = - mconcat [ "kind" .= String "CollectErrors" - , "errors" .= errors - ] - toObject verb (Alonzo.UpdateFailure pFailure) = - toObject verb pFailure - -instance - ( Ledger.Era ledgerera - , Show (PredicateFailure (Ledger.EraRule "LEDGERS" ledgerera)) - ) => ToObject (AlonzoBbodyPredFailure ledgerera) where - toObject _ err = mconcat [ "kind" .= String "AlonzoBbodyPredFail" - , "error" .= String (textShow err) - ] - --------------------------------------------------------------------------------- --- Babbage related --------------------------------------------------------------------------------- - -instance - ( Ledger.Era ledgerera - , ToObject (ShelleyUtxowPredFailure ledgerera) - , ToObject (PredicateFailure (Ledger.EraRule "UTXOS" ledgerera)) - , ToObject (Ledger.EraRuleFailure "PPUP" ledgerera) - , ToJSON (Ledger.TxOut ledgerera) - , Show (Ledger.Value ledgerera) - , ToJSON (Ledger.Value ledgerera) - ) => ToObject (BabbageUtxoPredFailure ledgerera) where - toObject v err = - case err of - Babbage.AlonzoInBabbageUtxoPredFailure alonzoFail -> - toObject v alonzoFail - - Babbage.IncorrectTotalCollateralField provided declared -> - mconcat [ "kind" .= String "UnequalCollateralReturn" - , "collateralProvided" .= provided - , "collateralDeclared" .= declared - ] - Babbage.BabbageOutputTooSmallUTxO outputs-> - mconcat [ "kind" .= String "BabbageOutputTooSmall" - , "outputs" .= outputs - ] - - Babbage.BabbageNonDisjointRefInputs nonDisjointInputs -> - mconcat [ "kind" .= String "BabbageNonDisjointRefInputs" - , "outputs" .= nonDisjointInputs - ] - -instance - ( Api.ShelleyLedgerEra era ~ ledgerera - , Api.IsShelleyBasedEra era - , Ledger.Era ledgerera - , Show (Ledger.Value ledgerera) - , ToObject (Ledger.EraRuleFailure "PPUP" ledgerera) - , ToObject (PredicateFailure (Ledger.EraRule "UTXO" ledgerera)) - , ToJSON (Ledger.Value ledgerera) - , ToJSON (Ledger.TxOut ledgerera) - ) => ToObject (BabbageUtxowPredFailure ledgerera) where - toObject v err = - case err of - Babbage.AlonzoInBabbageUtxowPredFailure alonzoFail -> - toObject v alonzoFail - Babbage.UtxoFailure utxoFail -> - toObject v utxoFail - -- TODO: Plutus team needs to expose a better error type. - Babbage.MalformedScriptWitnesses s -> - mconcat [ "kind" .= String "MalformedScriptWitnesses" - , "scripts" .= s - ] - Babbage.MalformedReferenceScripts s -> - mconcat [ "kind" .= String "MalformedReferenceScripts" - , "scripts" .= s - ] - Babbage.ScriptIntegrityHashMismatch Mismatch {mismatchSupplied, mismatchExpected} mBytes -> - mconcat [ "kind" .= String "ScriptIntegrityHashMismatch" - , "supplied" .= renderScriptIntegrityHash (strictMaybeToMaybe mismatchSupplied) - , "expected" .= renderScriptIntegrityHash (strictMaybeToMaybe mismatchExpected) - , "hashHexPreimage" .= formatAsHex (strictMaybeToMaybe mBytes) - ] - -formatAsHex :: Maybe Crypto.ByteString -> String -formatAsHex Nothing = "" -formatAsHex (Just bs) = show bs - -instance Core.Crypto crypto => ToObject (Praos.PraosValidationErr crypto) where - toObject _ err' = - case err' of - Praos.VRFKeyUnknown unknownKeyHash -> - mconcat [ "kind" .= String "VRFKeyUnknown" - , "vrfKey" .= unknownKeyHash - ] - Praos.VRFKeyWrongVRFKey stakePoolKeyHash registeredVrfForSaidStakepool wrongKeyHashInBlockHeader -> - mconcat [ "kind" .= String "VRFKeyWrongVRFKey" - , "stakePoolKeyHash" .= stakePoolKeyHash - , "stakePoolVrfKey" .= registeredVrfForSaidStakepool - , "blockHeaderVrfKey" .= wrongKeyHashInBlockHeader - ] - Praos.VRFKeyBadProof slotNo nonce vrfCalculatedVal-> - mconcat [ "kind" .= String "VRFKeyBadProof" - , "slotNumberUsedInVrfCalculation" .= slotNo - , "nonceUsedInVrfCalculation" .= nonce - , "calculatedVrfValue" .= String (textShow vrfCalculatedVal) - ] - Praos.VRFLeaderValueTooBig leaderValue sigma f-> - mconcat [ "kind" .= String "VRFLeaderValueTooBig" - , "leaderValue" .= leaderValue - , "sigma" .= sigma - , "f" .= activeSlotLog f - ] - Praos.KESBeforeStartOCERT startKesPeriod currKesPeriod -> - mconcat [ "kind" .= String "KESBeforeStartOCERT" - , "opCertStartingKesPeriod" .= startKesPeriod - , "currentKesPeriod" .= currKesPeriod - ] - Praos.KESAfterEndOCERT currKesPeriod startKesPeriod maxKesKeyEvos -> - mconcat [ "kind" .= String "KESAfterEndOCERT" - , "opCertStartingKesPeriod" .= startKesPeriod - , "currentKesPeriod" .= currKesPeriod - , "maxKesKeyEvolutions" .= maxKesKeyEvos - ] - Praos.CounterTooSmallOCERT lastCounter currentCounter -> - mconcat [ "kind" .= String "CounterTooSmallOCERT" - , "lastCounter" .= lastCounter - , "currentCounter" .= currentCounter - ] - Praos.CounterOverIncrementedOCERT lastCounter currentCounter -> - mconcat [ "kind" .= String "CounterOverIncrementedOCERT" - , "lastCounter" .= lastCounter - , "currentCounter" .= currentCounter - ] - Praos.InvalidSignatureOCERT counter oCertStartKesPeriod err -> - mconcat [ "kind" .= String "InvalidSignatureOCERT" - , "counter" .= counter - , "opCertStartingKesPeriod" .= oCertStartKesPeriod - , "error" .= err - ] - Praos.InvalidKesSignatureOCERT currentKesPeriod opCertStartKesPeriod expectedKesEvos maxKesEvos err -> - mconcat [ "kind" .= String "InvalidKesSignatureOCERT" - , "currentKesPeriod" .= currentKesPeriod - , "opCertStartingKesPeriod" .= opCertStartKesPeriod - , "expectedKesEvolutions" .= expectedKesEvos - , "maximumKesEvolutions" .= maxKesEvos - , "error" .= err - ] - Praos.NoCounterForKeyHashOCERT stakePoolKeyHash-> - mconcat [ "kind" .= String "NoCounterForKeyHashOCERT" - , "stakePoolKeyHash" .= stakePoolKeyHash - ] - -instance ToObject (Praos.PraosCannotForge crypto) where - toObject _ (Praos.PraosCannotForgeKeyNotUsableYet currentKesPeriod startingKesPeriod) = - mconcat [ "kind" .= String "PraosCannotForgeKeyNotUsableYet" - , "currentKesPeriod" .= currentKesPeriod - , "opCertStartingKesPeriod" .= startingKesPeriod - ] - -instance ToObject Praos.PraosEnvelopeError where - toObject _ err' = - case err' of - Praos.ObsoleteNode maxPtclVersionFromPparams blkHeaderPtclVersion -> - mconcat [ "kind" .= String "ObsoleteNode" - , "maxMajorProtocolVersion" .= maxPtclVersionFromPparams - , "headerProtocolVersion" .= blkHeaderPtclVersion - ] - Praos.HeaderSizeTooLarge headerSize ledgerViewMaxHeaderSize -> - mconcat [ "kind" .= String "HeaderSizeTooLarge" - , "maxHeaderSize" .= ledgerViewMaxHeaderSize - , "headerSize" .= headerSize - ] - Praos.BlockSizeTooLarge blockSize ledgerViewMaxBlockSize -> - mconcat [ "kind" .= String "BlockSizeTooLarge" - , "maxBlockSize" .= ledgerViewMaxBlockSize - , "blockSize" .= blockSize - ] - -instance ToJSON ShelleyNodeToNodeVersion where - toJSON ShelleyNodeToNodeVersion1 = String "ShelleyNodeToNodeVersion1" - -instance ToJSON ShelleyNodeToClientVersion where - toJSON ShelleyNodeToClientVersion8 = String "ShelleyNodeToClientVersion8" - toJSON ShelleyNodeToClientVersion9 = String "ShelleyNodeToClientVersion9" - toJSON ShelleyNodeToClientVersion10 = String "ShelleyNodeToClientVersion10" - toJSON ShelleyNodeToClientVersion11 = String "ShelleyNodeToClientVersion11" - toJSON ShelleyNodeToClientVersion12 = String "ShelleyNodeToClientVersion12" - toJSON ShelleyNodeToClientVersion13 = String "ShelleyNodeToClientVersion13" - toJSON ShelleyNodeToClientVersion14 = String "ShelleyNodeToClientVersion14" - toJSON ShelleyNodeToClientVersion15 = String "ShelleyNodeToClientVersion15" - --------------------------------------------------------------------------------- --- Conway related --------------------------------------------------------------------------------- - -instance - ( Ledger.Era ledgerera - , Show (PredicateFailure (Ledger.EraRule "LEDGERS" ledgerera)) - ) => ToObject (Conway.ConwayBbodyPredFailure ledgerera) where - toObject _ err = mconcat [ "kind" .= String "ConwayBbodyPredFail" - , "error" .= String (textShow err) - ] - -instance - ( ToJSON (Alonzo.CollectError ledgerera) - ) => ToObject (ConwayUtxosPredFailure ledgerera) where - toObject _ (Conway.ValidationTagMismatch isValidating reason) = - mconcat [ "kind" .= String "ValidationTagMismatch" - , "isvalidating" .= isValidating - , "reason" .= reason - ] - toObject _ (Conway.CollectErrors errors) = - mconcat [ "kind" .= String "CollectErrors" - , "errors" .= errors - ] - --- We define this bogus instance as it is required by some of the --- 'ToObject' instances in this module -instance ToObject (Ledger.VoidEraRule rule era) where - -- NOTE: There are no values of type 'Ledger.VoidEraRule rule era' - toObject _ = \case - -instance - ( Ledger.Era ledgerera - , ToObject (PredicateFailure (Ledger.EraRule "UTXOS" ledgerera)) - , Show (Ledger.Value ledgerera) - , ToJSON (Ledger.Value ledgerera) - , ToJSON (Ledger.TxOut ledgerera) - ) => ToObject (Conway.ConwayUtxoPredFailure ledgerera) where - toObject v = \case - Conway.UtxosFailure utxosPredFailure -> toObject v utxosPredFailure - Conway.BadInputsUTxO badInputs -> - mconcat [ "kind" .= String "BadInputsUTxO" - , "badInputs" .= badInputs - , "error" .= renderBadInputsUTxOErr (NonEmptySet.toSet badInputs) - ] - Conway.OutsideValidityIntervalUTxO validityInterval slot -> - mconcat [ "kind" .= String "ExpiredUTxO" - , "validityInterval" .= validityInterval - , "slot" .= slot - ] - Conway.MaxTxSizeUTxO Mismatch {mismatchSupplied, mismatchExpected} -> - mconcat [ "kind" .= String "MaxTxSizeUTxO" - , "size" .= mismatchSupplied - , "maxSize" .= mismatchExpected - ] - Conway.InputSetEmptyUTxO -> - mconcat [ "kind" .= String "InputSetEmptyUTxO" ] - Conway.FeeTooSmallUTxO Mismatch {mismatchSupplied, mismatchExpected} -> - mconcat [ "kind" .= String "FeeTooSmallUTxO" - , "minimum" .= mismatchExpected - , "fee" .= mismatchSupplied - ] - Conway.ValueNotConservedUTxO Mismatch {mismatchSupplied, mismatchExpected} -> - mconcat [ "kind" .= String "ValueNotConservedUTxO" - , "consumed" .= mismatchSupplied - , "produced" .= mismatchExpected - , "error" .= renderValueNotConservedErr mismatchSupplied mismatchExpected - ] - Conway.WrongNetwork network addrs -> - mconcat [ "kind" .= String "WrongNetwork" - , "network" .= network - , "addrs" .= addrs - ] - Conway.WrongNetworkWithdrawal network addrs -> - mconcat [ "kind" .= String "WrongNetworkWithdrawal" - , "network" .= network - , "addrs" .= addrs - ] - Conway.OutputTooSmallUTxO badOutputs -> - mconcat [ "kind" .= String "OutputTooSmallUTxO" - , "outputs" .= badOutputs - , "error" .= String - ( mconcat - [ "The output is smaller than the allow minimum " - , "UTxO value defined in the protocol parameters" - ] - ) - ] - Conway.OutputBootAddrAttrsTooBig badOutputs -> - mconcat [ "kind" .= String "OutputBootAddrAttrsTooBig" - , "outputs" .= badOutputs - , "error" .= String "The Byron address attributes are too big" - ] - Conway.OutputTooBigUTxO badOutputs -> - mconcat [ "kind" .= String "OutputTooBigUTxO" - , "outputs" .= badOutputs - , "error" .= String "Too many asset ids in the tx output" - ] - Conway.InsufficientCollateral computedBalance suppliedFee -> - mconcat [ "kind" .= String "InsufficientCollateral" - , "balance" .= computedBalance - , "txfee" .= suppliedFee - ] - Conway.ScriptsNotPaidUTxO utxos -> - mconcat [ "kind" .= String "ScriptsNotPaidUTxO" - , "utxos" .= utxos - ] - Conway.ExUnitsTooBigUTxO Mismatch {mismatchSupplied, mismatchExpected} -> - mconcat [ "kind" .= String "ExUnitsTooBigUTxO" - , "maxexunits" .= mismatchExpected - , "exunits" .= mismatchSupplied - ] - Conway.CollateralContainsNonADA inputs -> - mconcat [ "kind" .= String "CollateralContainsNonADA" - , "inputs" .= inputs - ] - Conway.WrongNetworkInTxBody Mismatch {mismatchSupplied, mismatchExpected} -> - mconcat [ "kind" .= String "WrongNetworkInTxBody" - , "networkid" .= mismatchExpected - , "txbodyNetworkId" .= mismatchSupplied - ] - Conway.OutsideForecast slotNum -> - mconcat [ "kind" .= String "OutsideForecast" - , "slot" .= slotNum - ] - Conway.TooManyCollateralInputs Mismatch {mismatchSupplied, mismatchExpected} -> - mconcat [ "kind" .= String "TooManyCollateralInputs" - , "max" .= mismatchExpected - , "inputs" .= mismatchSupplied - ] - Conway.NoCollateralInputs -> - mconcat [ "kind" .= String "NoCollateralInputs" ] - Conway.IncorrectTotalCollateralField provided declared -> - mconcat [ "kind" .= String "UnequalCollateralReturn" - , "collateralProvided" .= provided - , "collateralDeclared" .= declared - ] - Conway.BabbageOutputTooSmallUTxO outputs -> - mconcat [ "kind" .= String "BabbageOutputTooSmall" - , "outputs" .= outputs - ] - Conway.BabbageNonDisjointRefInputs nonDisjointInputs -> - mconcat [ "kind" .= String "BabbageNonDisjointRefInputs" - , "outputs" .= nonDisjointInputs - ] - -instance - ( Api.ShelleyLedgerEra era ~ ledgerera - , Api.IsShelleyBasedEra era - , Ledger.Era ledgerera - , Show (Ledger.Value ledgerera) - , ToObject (PredicateFailure (Ledger.EraRule "UTXO" ledgerera)) - , ToJSON (Ledger.Value ledgerera) - , ToJSON (Ledger.TxOut ledgerera) - ) => ToObject (Conway.ConwayUtxowPredFailure ledgerera) where - toObject v = \case - Conway.UtxoFailure utxoPredFail -> toObject v utxoPredFail - Conway.InvalidWitnessesUTXOW ws -> - mconcat [ "kind" .= String "InvalidWitnessesUTXOW" - , "invalidWitnesses" .= map textShow (NonEmpty.toList ws) - ] - Conway.MissingVKeyWitnessesUTXOW ws -> - mconcat [ "kind" .= String "MissingVKeyWitnessesUTXOW" - , "missingWitnesses" .= ws - ] - Conway.MissingScriptWitnessesUTXOW scripts -> - mconcat [ "kind" .= String "MissingScriptWitnessesUTXOW" - , "missingScripts" .= scripts - ] - Conway.ScriptWitnessNotValidatingUTXOW failedScripts -> - mconcat [ "kind" .= String "ScriptWitnessNotValidatingUTXOW" - , "failedScripts" .= failedScripts - ] - Conway.MissingTxBodyMetadataHash hash -> - mconcat [ "kind" .= String "MissingTxMetadata" - , "txBodyMetadataHash" .= hash - ] - Conway.MissingTxMetadata hash -> - mconcat [ "kind" .= String "MissingTxMetadata" - , "txBodyMetadataHash" .= hash - ] - Conway.ConflictingMetadataHash Mismatch {mismatchSupplied, mismatchExpected} -> - mconcat [ "kind" .= String "ConflictingMetadataHash" - , "txBodyMetadataHash" .= mismatchSupplied - , "fullMetadataHash" .= mismatchExpected - ] - Conway.InvalidMetadata -> - mconcat [ "kind" .= String "InvalidMetadata" - ] - Conway.ExtraneousScriptWitnessesUTXOW scripts -> - mconcat [ "kind" .= String "InvalidWitnessesUTXOW" - , "extraneousScripts" .= Set.map renderScriptHash (NonEmptySet.toSet scripts) - ] - Conway.MissingRedeemers scripts -> - mconcat [ "kind" .= String "MissingRedeemers" - , "scripts" .= renderMissingRedeemers Api.shelleyBasedEra scripts - ] - Conway.MissingRequiredDatums required received -> - mconcat [ "kind" .= String "MissingRequiredDatums" - , "required" .= map (Crypto.hashToTextAsHex . Hashes.extractHash) - (NonEmptySet.toList required) - , "received" .= map (Crypto.hashToTextAsHex . Hashes.extractHash) - (Set.toList received) - ] - Conway.NotAllowedSupplementalDatums disallowed acceptable -> - mconcat [ "kind" .= String "NotAllowedSupplementalDatums" - , "disallowed" .= NonEmptySet.toList disallowed - , "acceptable" .= Set.toList acceptable - ] - Conway.PPViewHashesDontMatch Mismatch {mismatchSupplied, mismatchExpected} -> - mconcat [ "kind" .= String "PPViewHashesDontMatch" - , "fromTxBody" .= renderScriptIntegrityHash (strictMaybeToMaybe mismatchSupplied) - , "fromPParams" .= renderScriptIntegrityHash (strictMaybeToMaybe mismatchExpected) - ] - Conway.UnspendableUTxONoDatumHash ins -> - mconcat [ "kind" .= String "MissingRequiredSigners" - , "txins" .= NonEmptySet.toList ins - ] - Conway.ExtraRedeemers rs -> - Api.caseShelleyToMaryOrAlonzoEraOnwards - (const mempty) - (\alonzoOnwards -> - mconcat - [ "kind" .= String "ExtraRedeemers" - , "rdmrs" .= map (Api.toScriptIndex alonzoOnwards) (NonEmpty.toList rs) - ] - ) - (Api.shelleyBasedEra :: Api.ShelleyBasedEra era) - Conway.MalformedScriptWitnesses scripts -> - mconcat [ "kind" .= String "MalformedScriptWitnesses" - , "scripts" .= scripts - ] - Conway.MalformedReferenceScripts scripts -> - mconcat [ "kind" .= String "MalformedReferenceScripts" - , "scripts" .= scripts - ] - Conway.ScriptIntegrityHashMismatch Mismatch {mismatchSupplied, mismatchExpected} mBytes -> - mconcat [ "kind" .= String "ScriptIntegrityHashMismatch" - , "supplied" .= renderScriptIntegrityHash (strictMaybeToMaybe mismatchSupplied) - , "expected" .= renderScriptIntegrityHash (strictMaybeToMaybe mismatchExpected) - , "hashHexPreimage" .= formatAsHex (strictMaybeToMaybe mBytes) - ] - -instance Core.Crypto c => ToObject (Praos.PraosTiebreakerView c) where - toObject _v Praos.PraosTiebreakerView { - ptvSlotNo - , ptvIssuer - , ptvIssueNo - , ptvTieBreakVRF - } = - mconcat [ "kind" .= String "PraosTiebreakerView" - , "slotNo" .= ptvSlotNo - , "issuerHash" .= hashKey ptvIssuer - , "issueNo" .= ptvIssueNo - , "tieBreakVRF" .= renderVRF ptvTieBreakVRF - ] - where - renderVRF = Text.decodeUtf8 . B16.encode . Crypto.getOutputVRFBytes - --------------------------------------------------------------------------------- --- Helper functions --------------------------------------------------------------------------------- - -showLastAppBlockNo :: WithOrigin LastAppliedBlock -> Text -showLastAppBlockNo wOblk = case withOriginToMaybe wOblk of - Nothing -> "Genesis Block" - Just blk -> textShow . unBlockNo $ labBlockNo blk diff --git a/cardano-node/src/Cardano/Tracing/Render.hs b/cardano-node/src/Cardano/Tracing/Render.hs deleted file mode 100644 index 3e678f42ba5..00000000000 --- a/cardano-node/src/Cardano/Tracing/Render.hs +++ /dev/null @@ -1,160 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} - -module Cardano.Tracing.Render - ( renderBlockOrEBB - , renderChunkNo - , renderHeaderHash - , renderHeaderHashForVerbosity - , renderChainHash - , renderTipBlockNo - , renderTipHash - , renderPoint - , renderPointAsPhrase - , renderPointForVerbosity - , renderRealPoint - , renderRealPointAsPhrase - , renderSlotNo - , renderTip - , renderTipForVerbosity - , renderTxId - , renderTxIdForVerbosity - , renderWithOrigin - ) where - -import Cardano.BM.Tracing (TracingVerbosity (..)) -import Cardano.Node.Queries (ConvertTxId (..)) -import Cardano.Slotting.Slot (EpochNo (..), SlotNo (..), WithOrigin (..)) -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.Network.Block (ChainHash (..), HeaderHash, StandardHash, Tip, - getTipPoint) - -import qualified Data.ByteString.Base16 as B16 -import Data.Proxy (Proxy (..)) -import Data.Text (Text) -import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text - -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 - -renderTxIdForVerbosity - :: ConvertTxId blk - => TracingVerbosity - -> TxId (GenTx blk) - -> Text -renderTxIdForVerbosity verb = trimHashTextForVerbosity verb . 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 - -renderPointForVerbosity - :: forall blk. - ConvertRawHash blk - => TracingVerbosity - -> Point blk - -> Text -renderPointForVerbosity verb point = - case point of - GenesisPoint -> "genesis (origin)" - BlockPoint slot h -> - renderHeaderHashForVerbosity (Proxy @blk) verb h - <> "@" - <> renderSlotNo slot - -renderPoint :: ConvertRawHash blk => Point blk -> Text -renderPoint = renderPointForVerbosity MaximalVerbosity - --- | 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 - -renderTipForVerbosity - :: ConvertRawHash blk - => TracingVerbosity - -> Tip blk - -> Text -renderTipForVerbosity verb = renderPointForVerbosity verb . getTipPoint - -renderTip :: ConvertRawHash blk => Tip blk -> Text -renderTip = renderTipForVerbosity MaximalVerbosity - -renderHeaderHashForVerbosity - :: ConvertRawHash blk - => proxy blk - -> TracingVerbosity - -> HeaderHash blk - -> Text -renderHeaderHashForVerbosity p verb = - trimHashTextForVerbosity verb . 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 - -trimHashTextForVerbosity :: TracingVerbosity -> Text -> Text -trimHashTextForVerbosity verb = - case verb of - MinimalVerbosity -> Text.take 7 - NormalVerbosity -> id - MaximalVerbosity -> id diff --git a/cardano-node/src/Cardano/Tracing/Shutdown.hs b/cardano-node/src/Cardano/Tracing/Shutdown.hs deleted file mode 100644 index 6fa67c90d5c..00000000000 --- a/cardano-node/src/Cardano/Tracing/Shutdown.hs +++ /dev/null @@ -1,30 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} - -{-# OPTIONS_GHC -Wno-orphans #-} - -module Cardano.Tracing.Shutdown () where - -import Cardano.BM.Data.Tracer (HasTextFormatter (..), trStructuredText) -import Cardano.BM.Tracing (HasPrivacyAnnotation (..), HasSeverityAnnotation (..), - Severity (..), ToObject (..), Transformable (..)) -import Cardano.Logging (LogFormatting (..)) -import Cardano.Node.Handlers.Shutdown -import Cardano.Node.Tracing.Compat -import Cardano.Node.Tracing.Tracers.Shutdown - -import Prelude (IO) - -import Data.Text (Text) - -instance HasPrivacyAnnotation ShutdownTrace -instance HasSeverityAnnotation ShutdownTrace where - getSeverityAnnotation _ = Warning - -instance Transformable Text IO ShutdownTrace where - trTransformer = trStructuredText - -instance HasTextFormatter ShutdownTrace where - formatText a _ = ppShutdownTrace a - -instance ToObject ShutdownTrace where - toObject verb = forMachine (toDetailLevel verb) diff --git a/cardano-node/src/Cardano/Tracing/Startup.hs b/cardano-node/src/Cardano/Tracing/Startup.hs deleted file mode 100644 index 4103c50ed13..00000000000 --- a/cardano-node/src/Cardano/Tracing/Startup.hs +++ /dev/null @@ -1,57 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE UndecidableInstances #-} - -{-# OPTIONS_GHC -Wno-orphans #-} - -module Cardano.Tracing.Startup where - -import Cardano.BM.Data.Tracer (HasTextFormatter (..), trStructuredText) -import Cardano.BM.Tracing (HasPrivacyAnnotation (..), HasSeverityAnnotation (..), - Severity (..), ToObject (..), Transformable (..)) -import Cardano.Logging (LogFormatting (..)) -import Cardano.Node.Startup -import Cardano.Node.Tracing.Compat -import Cardano.Node.Tracing.Tracers.Startup -import Cardano.Tracing.OrphanInstances.Network () -import Ouroboros.Consensus.Node.NetworkProtocolVersion (BlockNodeToClientVersion, - BlockNodeToNodeVersion) - -import Prelude - -import Data.Aeson (ToJSON) -import Data.Text (Text) - - -instance HasSeverityAnnotation (StartupTrace blk) where - getSeverityAnnotation (StartupSocketConfigError _) = Error - getSeverityAnnotation NetworkConfigUpdate = Notice - getSeverityAnnotation (NetworkConfigUpdateError _) = Error - getSeverityAnnotation (NetworkConfigUpdateWarning _) = Warning - getSeverityAnnotation (NetworkConfigUpdateInfo _) = Info - getSeverityAnnotation NetworkConfigUpdateUnsupported = Warning - getSeverityAnnotation NonP2PWarning = Warning - getSeverityAnnotation WarningDevelopmentNodeToNodeVersions {} = Warning - getSeverityAnnotation WarningDevelopmentNodeToClientVersions {} = Warning - getSeverityAnnotation _ = Info - -instance HasPrivacyAnnotation (StartupTrace blk) - -instance ( Show (BlockNodeToNodeVersion blk) - , Show (BlockNodeToClientVersion blk) - , ToJSON (BlockNodeToNodeVersion blk) - , ToJSON (BlockNodeToClientVersion blk) - ) - => Transformable Text IO (StartupTrace blk) where - trTransformer = trStructuredText - -instance HasTextFormatter (StartupTrace blk) where - formatText a _ = ppStartupInfoTrace a - -instance ( Show (BlockNodeToNodeVersion blk) - , Show (BlockNodeToClientVersion blk) - , ToJSON (BlockNodeToNodeVersion blk) - , ToJSON (BlockNodeToClientVersion blk) - ) - => ToObject (StartupTrace blk) where - toObject verb = forMachine (toDetailLevel verb) diff --git a/cardano-node/src/Cardano/Tracing/Tracers.hs b/cardano-node/src/Cardano/Tracing/Tracers.hs deleted file mode 100644 index 6cd5a36219d..00000000000 --- a/cardano-node/src/Cardano/Tracing/Tracers.hs +++ /dev/null @@ -1,1855 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PackageImports #-} -{-# LANGUAGE QuantifiedConstraints #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE UndecidableInstances #-} - -{-# OPTIONS_GHC -Wno-orphans #-} -{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} - - -module Cardano.Tracing.Tracers - ( Tracers (..) - , TraceOptions - , mkTracers - , nullDiffusionTracers - , traceCounter - ) where - -import Cardano.BM.Data.Aggregated (Measurable (..)) -import Cardano.BM.Data.Tracer (WithSeverity (..), annotateSeverity) -import Cardano.BM.Data.Transformers -import Cardano.BM.Internal.ElidingTracer -import Cardano.BM.Trace (traceNamedObject) -import Cardano.BM.Tracing -import Cardano.Network.Diffusion (CardanoPeerSelectionCounters) -import qualified Cardano.Network.Diffusion.Types as Cardano.Diffusion -import Cardano.Network.NodeToClient (LocalAddress) -import Cardano.Network.NodeToNode (RemoteAddress) -import qualified Cardano.Network.PeerSelection.ExtraRootPeers as Cardano -import Cardano.Node.Configuration.Logging -import Cardano.Node.Protocol.Byron () -import Cardano.Node.Protocol.Shelley () -import Cardano.Node.Queries -import Cardano.Node.Startup -import qualified Cardano.Node.STM as STM -import Cardano.Node.TraceConstraints -import Cardano.Node.Tracing -import qualified Cardano.Node.Tracing.Tracers.Consensus as ConsensusTracers -import Cardano.Node.Tracing.Tracers.NodeVersion -import Cardano.Node.Tracing.Tracers.Rpc () -import Cardano.Protocol.TPraos.OCert (KESPeriod (..)) -import Cardano.Slotting.Slot (EpochNo (..), SlotNo (..), WithOrigin (..)) -import Cardano.Tracing.Config -import Cardano.Tracing.HasIssuer (BlockIssuerVerificationKeyHash (..), HasIssuer (..)) -import Cardano.Tracing.Metrics -import Cardano.Tracing.OrphanInstances.Network () -import Cardano.Tracing.Render (renderChainHash, renderHeaderHash) -import Cardano.Tracing.Shutdown () -import Cardano.Tracing.Startup () -import Ouroboros.Consensus.Block (BlockConfig, BlockProtocol, CannotForge, - ConvertRawHash (..), ForgeStateInfo, ForgeStateUpdateError, Header, HeaderHash, - realPointHash, realPointSlot) -import Ouroboros.Consensus.BlockchainTime (SystemStart (..), - TraceBlockchainTimeEvent (..)) -import Ouroboros.Consensus.HeaderValidation (OtherHeaderEnvelopeError) -import Ouroboros.Consensus.Ledger.Abstract (LedgerErr, LedgerState) -import Ouroboros.Consensus.Ledger.Extended (ledgerState) -import Ouroboros.Consensus.Ledger.Inspect (InspectLedger, LedgerEvent) -import Ouroboros.Consensus.Ledger.Query (BlockQuery, Query) -import Ouroboros.Consensus.Ledger.SupportsMempool (ApplyTxErr, ByteSize32 (..), GenTx, - GenTxId, HasTxs, LedgerSupportsMempool) -import Ouroboros.Consensus.Ledger.SupportsProtocol (LedgerSupportsProtocol) -import Ouroboros.Consensus.Mempool (MempoolSize (..), TraceEventMempool (..)) -import Ouroboros.Consensus.MiniProtocol.BlockFetch.Server -import Ouroboros.Consensus.MiniProtocol.ChainSync.Server -import qualified Ouroboros.Consensus.Network.NodeToClient as NodeToClient -import qualified Ouroboros.Consensus.Network.NodeToNode as NodeToNode -import qualified Ouroboros.Consensus.Node.Run as Consensus (RunNode) -import qualified Ouroboros.Consensus.Node.Tracers as Consensus -import Ouroboros.Consensus.Peras.SelectView -import Ouroboros.Consensus.Protocol.Abstract (ValidationErr) -import qualified Ouroboros.Consensus.Protocol.Ledger.HotKey as HotKey -import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB -import qualified Ouroboros.Consensus.Storage.LedgerDB as LedgerDB -import Ouroboros.Consensus.Util.Enclose -import qualified Ouroboros.Network.AnchoredFragment as AF -import Ouroboros.Network.Block (BlockNo (..), ChainUpdate (..), HasHeader (..), Point, - StandardHash, blockNo, pointSlot, unBlockNo) -import Ouroboros.Network.BlockFetch.ClientState (TraceFetchClientState (..), - TraceLabelPeer (..)) -import Ouroboros.Network.BlockFetch.Decision (FetchDecision, FetchDecline (..)) -import Ouroboros.Network.BlockFetch.Decision.Trace -import Ouroboros.Network.ConnectionId (ConnectionId) -import qualified Ouroboros.Network.ConnectionManager.Core as ConnectionManager -import Ouroboros.Network.ConnectionManager.Types (ConnectionManagerCounters (..)) -import qualified Ouroboros.Network.Diffusion as Diffusion -import qualified Ouroboros.Network.Driver.Stateful as Stateful -import qualified Ouroboros.Network.InboundGovernor as InboundGovernor -import Ouroboros.Network.InboundGovernor.State as InboundGovernor -import Ouroboros.Network.PeerSelection.Governor (PeerSelectionView (..)) -import qualified Ouroboros.Network.PeerSelection.Governor as Governor -import qualified Ouroboros.Network.PeerSelection.Governor.Types as Governor -import Ouroboros.Network.Point (fromWithOrigin, withOrigin) -import Ouroboros.Network.Protocol.LocalStateQuery.Type (LocalStateQuery, ShowQuery) -import qualified Ouroboros.Network.Protocol.LocalStateQuery.Type as LocalStateQuery -import Ouroboros.Network.TxSubmission.Inbound.V2 - -import Codec.CBOR.Read (DeserialiseFailure) -import Control.Concurrent (MVar, modifyMVar_) -import Control.Concurrent.STM (STM, atomically) -import qualified Control.Concurrent.STM as STM -import Control.Monad (forM_, when) -import "contra-tracer" Control.Tracer -import Control.Tracer.Transformers -import Data.Aeson (ToJSON (..), Value (..)) -import qualified Data.Aeson.KeyMap as KeyMap -import qualified Data.ByteString.Base16 as B16 -import Data.Functor ((<&>)) -import Data.Int (Int64) -import Data.IntPSQ (IntPSQ) -import qualified Data.IntPSQ as Pq -import qualified Data.List as List -import qualified Data.Map.Strict as Map -import Data.Proxy (Proxy (..)) -import Data.Text (Text) -import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text -import Data.Time (NominalDiffTime, UTCTime) -import Data.Word (Word64) -import GHC.Clock (getMonotonicTimeNSec) -import GHC.TypeLits (KnownNat, Nat, natVal) -import qualified Network.Mux as Mux -import qualified System.Metrics.Counter as Counter -import qualified System.Metrics.Gauge as Gauge -import qualified System.Metrics.Label as Label -import qualified System.Remote.Monitoring.Wai as EKG - - -{-# OPTIONS_GHC -Wno-redundant-constraints #-} --- needs different instances on ghc8 and on ghc9 - -{- HLINT ignore "Redundant bracket" -} -{- HLINT ignore "Use record patterns" -} - -data ForgeTracers = ForgeTracers - { ftForged :: Trace IO Text - , ftForgeAboutToLead :: Trace IO Text - , ftCouldNotForge :: Trace IO Text - , ftAdopted :: Trace IO Text - , ftDidntAdoptBlock :: Trace IO Text - , ftForgedInvalid :: Trace IO Text - , ftTraceNodeNotLeader :: Trace IO Text - , ftTraceNodeCannotForge :: Trace IO Text - , ftTraceForgeStateUpdateError :: Trace IO Text - , ftTraceBlockFromFuture :: Trace IO Text - , ftTraceSlotIsImmutable :: Trace IO Text - , ftTraceNodeIsLeader :: Trace IO Text - , ftTraceAdoptionThreadDied :: Trace IO Text - } - -nullDiffusionTracers :: Applicative m => Cardano.Diffusion.CardanoTracers m -nullDiffusionTracers = Cardano.Diffusion.nullTracers - -indexGCType :: ChainDB.TraceGCEvent a -> Int -indexGCType ChainDB.ScheduledGC{} = 1 -indexGCType ChainDB.PerformedGC{} = 2 - --- helper to classify meaningful progress changes (i.e. in the ten thousandths) -replayProgress :: LedgerDB.TraceReplayProgressEvent a -> Integer -replayProgress (LedgerDB.ReplayedBlock pt _ledgerEvents (LedgerDB.ReplayStart replayFrom) (LedgerDB.ReplayGoal replayTo)) = - let fromSlot = withOrigin 0 Prelude.id $ unSlotNo <$> pointSlot replayFrom - atSlot = unSlotNo $ realPointSlot pt - atDiff = atSlot - fromSlot - toSlot = withOrigin 0 Prelude.id $ unSlotNo <$> pointSlot replayTo - toDiff = toSlot - fromSlot - in if toDiff == 0 then 0 else round (10000 * fromIntegral atDiff / fromIntegral toDiff :: Float) - -instance ElidingTracer (WithSeverity (ChainDB.TraceEvent blk)) where - -- equivalent by type and severity - isEquivalent (WithSeverity s1 (ChainDB.TraceGCEvent ev1)) - (WithSeverity s2 (ChainDB.TraceGCEvent ev2)) = - s1 == s2 && indexGCType ev1 == indexGCType ev2 - isEquivalent (WithSeverity _s1 (ChainDB.TraceAddBlockEvent _)) - (WithSeverity _s2 (ChainDB.TraceAddBlockEvent _)) = True - isEquivalent (WithSeverity _s1 (ChainDB.TraceGCEvent _ev1)) - (WithSeverity _s2 (ChainDB.TraceAddBlockEvent _)) = True - isEquivalent (WithSeverity _s1 (ChainDB.TraceAddBlockEvent _)) - (WithSeverity _s2 (ChainDB.TraceGCEvent _ev2)) = True - isEquivalent (WithSeverity _s1 (ChainDB.TraceGCEvent _ev1)) - (WithSeverity _s2 (ChainDB.TraceCopyToImmutableDBEvent _)) = True - isEquivalent (WithSeverity _s1 (ChainDB.TraceCopyToImmutableDBEvent _)) - (WithSeverity _s2 (ChainDB.TraceGCEvent _ev2)) = True - isEquivalent (WithSeverity _s1 (ChainDB.TraceCopyToImmutableDBEvent _)) - (WithSeverity _s2 (ChainDB.TraceAddBlockEvent _)) = True - isEquivalent (WithSeverity _s1 (ChainDB.TraceAddBlockEvent _)) - (WithSeverity _s2 (ChainDB.TraceCopyToImmutableDBEvent _)) = True - isEquivalent (WithSeverity _s1 (ChainDB.TraceCopyToImmutableDBEvent _)) - (WithSeverity _s2 (ChainDB.TraceCopyToImmutableDBEvent _)) = True - isEquivalent (WithSeverity _s1 (ChainDB.TraceLedgerDBEvent - (LedgerDB.LedgerReplayEvent - (LedgerDB.TraceReplayProgressEvent _)))) - (WithSeverity _s2 (ChainDB.TraceLedgerDBEvent - (LedgerDB.LedgerReplayEvent - (LedgerDB.TraceReplayProgressEvent _)))) = True - - -- HACK: we never want any of the forker or flavor events to break the elision. - -- - -- when a forker event arrives, it will be compared as @(ev `isEquivalent`)@, but once it is - -- processed the next time it will be compared as @(`isEquivalent` ev)@, hence the flipped - -- versions below this comment - isEquivalent (WithSeverity _s1 (ChainDB.TraceLedgerDBEvent LedgerDB.LedgerDBForkerEvent{})) _ = True - isEquivalent (WithSeverity _s1 (ChainDB.TraceLedgerDBEvent LedgerDB.LedgerDBFlavorImplEvent{})) _ = True - isEquivalent _ (WithSeverity _s1 (ChainDB.TraceLedgerDBEvent LedgerDB.LedgerDBForkerEvent{})) = True - isEquivalent _ (WithSeverity _s1 (ChainDB.TraceLedgerDBEvent LedgerDB.LedgerDBFlavorImplEvent{})) = True - - isEquivalent (WithSeverity _s1 (ChainDB.TraceInitChainSelEvent ev1)) - (WithSeverity _s2 (ChainDB.TraceInitChainSelEvent ev2)) = - case (ev1, ev2) of - (ChainDB.InitChainSelValidation ( - ChainDB.UpdateLedgerDbTraceEvent ( - LedgerDB.StartedPushingBlockToTheLedgerDb _ _ _)), - ChainDB.InitChainSelValidation ( - ChainDB.UpdateLedgerDbTraceEvent ( - LedgerDB.StartedPushingBlockToTheLedgerDb _ _ _))) -> True - _ -> False - isEquivalent _ _ = False - -- the types to be elided - doelide (WithSeverity _ (ChainDB.TraceLedgerDBEvent - (LedgerDB.LedgerReplayEvent - (LedgerDB.TraceReplayProgressEvent _)))) = True - doelide (WithSeverity _ (ChainDB.TraceLedgerDBEvent - LedgerDB.LedgerDBForkerEvent{})) = True - doelide (WithSeverity _ (ChainDB.TraceLedgerDBEvent - LedgerDB.LedgerDBFlavorImplEvent{})) = True - doelide (WithSeverity _ (ChainDB.TraceGCEvent _)) = True - doelide (WithSeverity _ (ChainDB.TraceAddBlockEvent (ChainDB.IgnoreBlockOlderThanImmTip _))) = False - doelide (WithSeverity _ (ChainDB.TraceAddBlockEvent (ChainDB.IgnoreInvalidBlock _ _))) = False - doelide (WithSeverity _ (ChainDB.TraceAddBlockEvent (ChainDB.StoreButDontChange _))) = False - doelide (WithSeverity _ (ChainDB.TraceAddBlockEvent (ChainDB.TrySwitchToAFork _ _))) = False - doelide (WithSeverity _ (ChainDB.TraceAddBlockEvent (ChainDB.SwitchedToAFork{}))) = False - doelide (WithSeverity _ (ChainDB.TraceAddBlockEvent (ChainDB.AddBlockValidation (ChainDB.InvalidBlock _ _)))) = False - doelide (WithSeverity _ (ChainDB.TraceAddBlockEvent (ChainDB.AddBlockValidation _))) = True - doelide (WithSeverity _ (ChainDB.TraceAddBlockEvent (ChainDB.AddedToCurrentChain events _ _ _ _))) = null events - doelide (WithSeverity _ (ChainDB.TraceAddBlockEvent (ChainDB.PipeliningEvent{}))) = True - doelide (WithSeverity _ (ChainDB.TraceAddBlockEvent _)) = True - doelide (WithSeverity _ (ChainDB.TraceCopyToImmutableDBEvent _)) = True - doelide (WithSeverity _ (ChainDB.TraceInitChainSelEvent (ChainDB.InitChainSelValidation (ChainDB.UpdateLedgerDbTraceEvent{})))) = True - doelide _ = False - - conteliding _tverb _tr _ (Nothing, _count) = return (Nothing, 0) - conteliding tverb tr ev@(WithSeverity _ (ChainDB.TraceAddBlockEvent ChainDB.AddedToCurrentChain{})) (_old, oldt) = do - tnow <- getMonotonicTimeNSec - let tnow' = fromIntegral tnow - deltat = tnow' - oldt - if deltat > 1250000000 -- report at most every 1250 ms - then do - traceWith (toLogObject' tverb tr) ev - return (Just ev, tnow') - else return (Just ev, oldt) - conteliding _tverb _tr ev@(WithSeverity _ (ChainDB.TraceAddBlockEvent _)) (_old, count) = - return (Just ev, count) - conteliding _tverb _tr ev@(WithSeverity _ (ChainDB.TraceCopyToImmutableDBEvent _)) (_old, count) = - return (Just ev, count) - conteliding _tverb _tr ev@(WithSeverity _ (ChainDB.TraceGCEvent _)) (_old, count) = - return (Just ev, count) - conteliding tverb tr ev@(WithSeverity _ (ChainDB.TraceLedgerDBEvent - (LedgerDB.LedgerReplayEvent - (LedgerDB.TraceReplayProgressEvent inner)))) (_old, previous) = - let current = replayProgress inner - in if current > previous - then traceWith (toLogObject' tverb tr) ev >> return (Just ev, current) - else return (Just ev, previous) - conteliding _tverb _tr ev@(WithSeverity _ (ChainDB.TraceLedgerDBEvent LedgerDB.LedgerDBForkerEvent{})) (_old, count) = do - return (Just ev, count) - conteliding _tverb _tr ev@(WithSeverity _ (ChainDB.TraceLedgerDBEvent LedgerDB.LedgerDBFlavorImplEvent{})) (_old, count) = do - return (Just ev, count) - conteliding _tverb _tr ev@(WithSeverity _ (ChainDB.TraceInitChainSelEvent - (ChainDB.InitChainSelValidation - (ChainDB.UpdateLedgerDbTraceEvent - (LedgerDB.StartedPushingBlockToTheLedgerDb - _ _ (LedgerDB.Pushing curr)))))) (_old, count) = return $ - let currSlot = fromIntegral $ unSlotNo $ realPointSlot curr in - if count == 0 - then (Just ev, currSlot) - else if count + 10000 < currSlot - then (Nothing, 0) - else (Just ev, count) - conteliding _ _ _ _ = return (Nothing, 0) - - reportelided _tverb _tr (WithSeverity _ (ChainDB.TraceLedgerDBEvent - (LedgerDB.LedgerReplayEvent - (LedgerDB.TraceReplayProgressEvent _)))) _count = pure () - reportelided t tr ev count = defaultelidedreporting t tr ev count - -instance (StandardHash header, Eq peer) => ElidingTracer - (WithSeverity [TraceLabelPeer peer (FetchDecision [Point header])]) where - -- equivalent by type and severity - isEquivalent (WithSeverity s1 _peers1) - (WithSeverity s2 _peers2) = s1 == s2 - -- the types to be elided - doelide (WithSeverity _ peers) = - let checkDecision :: TraceLabelPeer peer (Either FetchDecline result) -> Bool - checkDecision (TraceLabelPeer _peer (Left FetchDeclineChainNotPlausible)) = True - checkDecision (TraceLabelPeer _peer (Left (FetchDeclineConcurrencyLimit _ _))) = True - checkDecision (TraceLabelPeer _peer (Left (FetchDeclinePeerBusy _ _ _))) = True - checkDecision _ = False - in any checkDecision peers - conteliding _tverb _tr _ (Nothing, _count) = return (Nothing, 0) - conteliding tverb tr ev (_old, count) = do - when (count > 0 && count `mod` 1000 == 0) $ -- report every 1000th message - traceWith (toLogObject' tverb tr) ev - return (Just ev, count + 1) - --- | Tracers for all system components. --- -mkTracers - :: forall blk. - ( Consensus.RunNode blk - , TraceConstraints blk - ) - => BlockConfig blk - -> TraceOptions - -> Trace IO Text - -> NodeKernelData blk - -> Maybe EKGDirect - -> IO (Tracers RemoteAddress LocalAddress blk IO) -mkTracers blockConfig tOpts@(TracingOnLegacy trSel) tr nodeKern ekgDirect = do - fStats <- mkForgingStats - consensusTracers <- mkConsensusTracers ekgDirect trSel verb tr nodeKern fStats - elidedChainDB <- newstate -- for eliding messages in ChainDB tracer - let churnModeTracer = tracerOnOff (traceChurnMode trSel) verb "Churn" tr - tForks <- STM.newTVarIO 0 - - pure Tracers - { chainDBTracer = tracerOnOff' (traceChainDB trSel) $ - annotateSeverity $ teeTraceChainTip - blockConfig - fStats - tOpts elidedChainDB - ekgDirect - tForks - (appendName "ChainDB" tr) - (appendName "metrics" tr) - , consensusTracers = consensusTracers - , nodeToClientTracers = nodeToClientTracers' trSel verb tr - , nodeToNodeTracers = nodeToNodeTracers' trSel verb tr - , diffusionTracers - , churnModeTracer - -- TODO: startupTracer should ignore severity level (i.e. it should always - -- be printed)! - , startupTracer = toLogObject' verb (appendName "startup" tr) - <> Tracer (\(ev :: StartupTrace blk) -> traceForgeEnabledMetric ekgDirect ev) - - , shutdownTracer = toLogObject' verb $ appendName "shutdown" tr - , nodeVersionTracer = Tracer (\(ev :: NodeVersionTrace) -> traceVersionMetric ekgDirect ev) - -- The remaining tracers are completely unused by the legacy tracing: - , nodeInfoTracer = nullTracer - , nodeStartupInfoTracer = nullTracer - , nodeStateTracer = nullTracer - , resourcesTracer = nullTracer - , ledgerMetricsTracer = nullTracer - , rpcTracer = nullTracer - } - where - traceForgeEnabledMetric :: Maybe EKGDirect -> StartupTrace blk -> IO () - traceForgeEnabledMetric mbEKGDirect ev = - case mbEKGDirect of - Just ekgDirect' -> - case ev of - BlockForgingUpdate b -> sendEKGDirectInt ekgDirect' "cardano.node.metrics.forging_enabled" - (case b of - EnabledBlockForging -> 1 :: Int - DisabledBlockForging -> 0 :: Int - NotEffective -> 0 :: Int) - _ -> pure () - Nothing -> pure () - traceVersionMetric :: Maybe EKGDirect -> NodeVersionTrace -> IO () - traceVersionMetric mbEKGDirect ev = do - case mbEKGDirect of - Just ekgDirect' -> - case ev of - NodeVersionTrace {} -> - sendEKGDirectPrometheusLabel - ekgDirect' - "cardano.node.metrics.cardano_build_info" - (getCardanoBuildInfo ev) - Nothing -> pure () - - diffusionTracers :: Cardano.Diffusion.CardanoTracers IO - diffusionTracers = Cardano.Diffusion.Tracers - { Diffusion.dtMuxTracer = muxTracer ekgDirect trSel tr - , Diffusion.dtChannelTracer = channelTracer - , Diffusion.dtBearerTracer = bearerTracer - , Diffusion.dtHandshakeTracer = handshakeTracer - , Diffusion.dtLocalMuxTracer = localMuxTracer - , Diffusion.dtLocalChannelTracer = localChannelTracer - , Diffusion.dtLocalBearerTracer = localBearerTracer - , Diffusion.dtLocalHandshakeTracer = localHandshakeTracer - , Diffusion.dtDiffusionTracer = initializationTracer - , Diffusion.dtTraceLocalRootPeersTracer = - tracerOnOff (traceLocalRootPeers trSel) - verb "LocalRootPeers" tr - , Diffusion.dtTracePublicRootPeersTracer = - tracerOnOff (tracePublicRootPeers trSel) - verb "PublicRootPeers" tr - , Diffusion.dtTracePeerSelectionTracer = - tracerOnOff (tracePeerSelection trSel) - verb "PeerSelection" tr - <> tracePeerSelectionTracerMetrics - (tracePeerSelection trSel) - ekgDirect - , Diffusion.dtTracePeerSelectionCounters = - tracePeerSelectionCountersMetrics - (tracePeerSelectionCounters trSel) - ekgDirect - <> tracerOnOff (tracePeerSelectionCounters trSel) - verb "PeerSelectionCounters" tr - , Diffusion.dtPeerSelectionActionsTracer = - tracerOnOff (tracePeerSelectionActions trSel) - verb "PeerSelectionActions" tr - , Diffusion.dtConnectionManagerTracer = - traceConnectionManagerTraceMetrics - (traceConnectionManagerCounters trSel) - ekgDirect - <> tracerOnOff (traceConnectionManager trSel) - verb "ConnectionManager" tr - , Diffusion.dtConnectionManagerTransitionTracer = - tracerOnOff (traceConnectionManagerTransitions trSel) - verb "ConnectionManagerTransition" tr - , Diffusion.dtServerTracer = - tracerOnOff (traceServer trSel) verb "Server" tr - , Diffusion.dtInboundGovernorTracer = - traceInboundGovernorCountersMetrics - (traceInboundGovernorCounters trSel) - ekgDirect - <> tracerOnOff (traceInboundGovernor trSel) - verb "InboundGovernor" tr - , Diffusion.dtInboundGovernorTransitionTracer = - tracerOnOff (traceInboundGovernorTransitions trSel) - verb "InboundGovernorTransition" tr - , Diffusion.dtLocalConnectionManagerTracer = - tracerOnOff (traceLocalConnectionManager trSel) - verb "LocalConnectionManager" tr - , Diffusion.dtLocalServerTracer = - tracerOnOff (traceLocalServer trSel) - verb "LocalServer" tr - , Diffusion.dtLocalInboundGovernorTracer = - tracerOnOff (traceLocalInboundGovernor trSel) - verb "LocalInboundGovernor" tr - , Diffusion.dtTraceLedgerPeersTracer = - tracerOnOff (traceLedgerPeers trSel) - verb "LedgerPeers" tr - , Diffusion.dtDnsTracer = - tracerOnOff (traceDNS trSel) verb "DNS" tr - , Diffusion.dtDebugPeerSelectionTracer = - tracerOnOff (traceDNS trSel) verb "DebugPeerSelection" tr - } - verb :: TracingVerbosity - verb = traceVerbosity trSel - channelTracer = - tracerOnOff (traceMux trSel) verb "MuxChannel" tr - bearerTracer = - tracerOnOff (traceMux trSel) verb "MuxBearerTracer" tr - localMuxTracer = - tracerOnOff (traceLocalMux trSel) verb "MuxLocal" tr - localChannelTracer = - tracerOnOff (traceMux trSel) verb "LocalMuxChannel" tr - localBearerTracer = - tracerOnOff (traceMux trSel) verb "LocalMuxBearerTracer" tr - localHandshakeTracer = - tracerOnOff (traceLocalHandshake trSel) verb "LocalHandshake" tr - handshakeTracer = - tracerOnOff (traceHandshake trSel) verb "Handshake" tr - initializationTracer = - tracerOnOff (traceDiffusionInitialization trSel) verb - "DiffusionInitializationTracer" tr - -mkTracers _ _ _ _ _ = - pure Tracers - { chainDBTracer = nullTracer - , consensusTracers = Consensus.Tracers - { Consensus.chainSyncClientTracer = nullTracer - , Consensus.chainSyncServerHeaderTracer = nullTracer - , Consensus.chainSyncServerBlockTracer = nullTracer - , Consensus.consensusSanityCheckTracer = nullTracer - , Consensus.blockFetchDecisionTracer = nullTracer - , Consensus.blockFetchClientTracer = nullTracer - , Consensus.blockFetchServerTracer = nullTracer - , Consensus.keepAliveClientTracer = nullTracer - , Consensus.forgeStateInfoTracer = nullTracer - , Consensus.gddTracer = nullTracer - , Consensus.txInboundTracer = nullTracer - , Consensus.txOutboundTracer = nullTracer - , Consensus.localTxSubmissionServerTracer = nullTracer - , Consensus.mempoolTracer = nullTracer - , Consensus.forgeTracer = nullTracer - , Consensus.blockchainTimeTracer = nullTracer - , Consensus.consensusErrorTracer = nullTracer - , Consensus.gsmTracer = nullTracer - , Consensus.csjTracer = nullTracer - , Consensus.dbfTracer = nullTracer - , Consensus.kesAgentTracer = nullTracer - , Consensus.txLogicTracer = nullTracer - , Consensus.txCountersTracer = nullTracer - } - , nodeToClientTracers = NodeToClient.Tracers - { NodeToClient.tChainSyncTracer = nullTracer - , NodeToClient.tTxMonitorTracer = nullTracer - , NodeToClient.tTxSubmissionTracer = nullTracer - , NodeToClient.tStateQueryTracer = nullTracer - } - , nodeToNodeTracers = NodeToNode.Tracers - { NodeToNode.tChainSyncTracer = nullTracer - , NodeToNode.tChainSyncSerialisedTracer = nullTracer - , NodeToNode.tBlockFetchTracer = nullTracer - , NodeToNode.tBlockFetchSerialisedTracer = nullTracer - , NodeToNode.tTxSubmission2Tracer = nullTracer - , NodeToNode.tKeepAliveTracer = nullTracer - , NodeToNode.tPeerSharingTracer = nullTracer - , NodeToNode.tTxLogicTracer = nullTracer - } - , diffusionTracers = Diffusion.nullTracers - , churnModeTracer = nullTracer - , startupTracer = nullTracer - , shutdownTracer = nullTracer - , nodeInfoTracer = nullTracer - , nodeStartupInfoTracer = nullTracer - , nodeStateTracer = nullTracer - , nodeVersionTracer = nullTracer - , resourcesTracer = nullTracer - , ledgerMetricsTracer = nullTracer - , rpcTracer = nullTracer - } - --------------------------------------------------------------------------------- --- Diffusion Layer Tracers --------------------------------------------------------------------------------- - -notifyTxsMempoolTimeoutHard :: Maybe EKGDirect -> Tracer IO Mux.Trace -notifyTxsMempoolTimeoutHard mbEKGDirect = case mbEKGDirect of - Nothing -> nullTracer - Just ekgDirect -> Tracer $ \ev -> do - when (impliesMempoolTimeoutHard ev) $ do - sendEKGDirectCounter ekgDirect $ "cardano.node.metrics." <> txsMempoolTimeoutHardCounterName - -impliesMempoolTimeoutHard :: Mux.Trace -> Bool -impliesMempoolTimeoutHard = \case - Mux.TraceExceptionExit _mid _dir e -{-- TODO: In cardano-node master this is implemented as: - -- - -- > | Just _ <- fromException @ExnMempoolTimeout e - -- > -> True - -- - -- but `ExnMempoolTimeout` is defined in `ouroboros-consensus` which is not a - -- dependency of `ouroboros-network`. - --} - | List.isPrefixOf "ExnMempoolTimeout " (show e) -> True - _ -> False - -txsMempoolTimeoutHardCounterName :: Text -txsMempoolTimeoutHardCounterName = "txsMempoolTimeoutHard" - -muxTracer - :: Maybe EKGDirect - -> TraceSelection - -> Trace IO Text - -> Tracer IO (Mux.WithBearer (ConnectionId RemoteAddress) Mux.Trace) -muxTracer mbEKGDirect trSel tracer = Tracer $ \ev -> do - -- Update the EKG metric even when this tracer is turned off. - flip traceWith (Mux.wbEvent ev) $ - notifyTxsMempoolTimeoutHard mbEKGDirect - whenOn (traceMux trSel) $ do - flip traceWith ev $ - annotateSeverity $ - toLogObject' (traceVerbosity trSel) $ - appendName "Mux" tracer - --------------------------------------------------------------------------------- --- Chain DB Tracers --------------------------------------------------------------------------------- - -teeTraceChainTip - :: ( ConvertRawHash blk - , HasIssuer blk - , LedgerSupportsProtocol blk - , InspectLedger blk - , ToObject (Header blk) - , ToObject (LedgerEvent blk) - , ToObject (WeightedSelectView (BlockProtocol blk)) - , ToJSON (HeaderHash blk) - ) - => BlockConfig blk - -> ForgingStats - -> TraceOptions - -> MVar (Maybe (WithSeverity (ChainDB.TraceEvent blk)), Integer) - -> Maybe EKGDirect - -> STM.TVar Word64 - -> Trace IO Text - -> Trace IO Text - -> Tracer IO (WithSeverity (ChainDB.TraceEvent blk)) -teeTraceChainTip _ _ TracingOff _ _ _ _ _ = nullTracer -teeTraceChainTip _ _ TraceDispatcher{} _ _ _ _ _ = nullTracer -teeTraceChainTip blockConfig fStats (TracingOnLegacy trSel) elided ekgDirect tFork trTrc trMet = - Tracer $ \ev -> do - traceWith (teeTraceChainTipElide (traceVerbosity trSel) elided trTrc) ev - traceWith (ignoringSeverity (traceChainMetrics ekgDirect tFork blockConfig fStats trMet)) ev - -teeTraceChainTipElide - :: ( ConvertRawHash blk - , LedgerSupportsProtocol blk - , InspectLedger blk - , ToObject (Header blk) - , ToObject (LedgerEvent blk) - , ToObject (WeightedSelectView (BlockProtocol blk)) - , ToJSON (HeaderHash blk) - ) - => TracingVerbosity - -> MVar (Maybe (WithSeverity (ChainDB.TraceEvent blk)), Integer) - -> Trace IO Text - -> Tracer IO (WithSeverity (ChainDB.TraceEvent blk)) -teeTraceChainTipElide = elideToLogObject -{-# INLINE teeTraceChainTipElide #-} - -ignoringSeverity :: Tracer IO a -> Tracer IO (WithSeverity a) -ignoringSeverity tr = Tracer $ \(WithSeverity _ ev) -> traceWith tr ev -{-# INLINE ignoringSeverity #-} - -traceChainMetrics - :: forall blk. () - => HasHeader (Header blk) - => ConvertRawHash blk - => HasIssuer blk - => Maybe EKGDirect - -> STM.TVar Word64 - -> BlockConfig blk - -> ForgingStats - -> Trace IO Text - -> Tracer IO (ChainDB.TraceEvent blk) -traceChainMetrics Nothing _ _ _ _ = nullTracer -traceChainMetrics (Just _ekgDirect) tForks _blockConfig _fStats tr = do - Tracer $ \ev -> - maybe (pure ()) doTrace (chainTipInformation ev) - where - chainTipInformation :: ChainDB.TraceEvent blk -> Maybe ChainInformation - chainTipInformation = \case - ChainDB.TraceAddBlockEvent ev -> case ev of - ChainDB.SwitchedToAFork _warnings selChangedInfo oldChain newChain _switchReason -> - let fork = not $ AF.withinFragmentBounds (AF.headPoint oldChain) - newChain in - Just $ chainInformation selChangedInfo fork oldChain newChain 0 - ChainDB.AddedToCurrentChain _warnings selChangedInfo oldChain newChain _switchReason -> - Just $ chainInformation selChangedInfo False oldChain newChain 0 - _ -> Nothing - _ -> Nothing - - doTrace :: ChainInformation -> IO () - doTrace - ChainInformation { slots, blocks, density, epoch, slotInEpoch, fork, tipBlockHash, tipBlockParentHash, tipBlockIssuerVerificationKeyHash } = do - -- TODO this is executed each time the newChain changes. How cheap is it? - meta <- mkLOMeta Critical Public - - traceD tr meta "density" (fromRational density) - traceI tr meta "slotNum" slots - traceI tr meta "blockNum" blocks - traceI tr meta "slotInEpoch" slotInEpoch - traceI tr meta "epoch" (unEpochNo epoch) - when fork $ - traceI tr meta "forks" =<< STM.modifyReadTVarIO tForks succ - - let tipBlockIssuerVkHashText :: Text - tipBlockIssuerVkHashText = - case tipBlockIssuerVerificationKeyHash of - NoBlockIssuer -> "NoBlockIssuer" - BlockIssuerVerificationKeyHash bs -> - Text.decodeLatin1 (B16.encode bs) - traceNamedObject - (appendName "tipBlockHash" tr) - (meta, LogMessage tipBlockHash) - - traceNamedObject - (appendName "tipBlockParentHash" tr) - (meta, LogMessage tipBlockParentHash) - - traceNamedObject - (appendName "tipBlockIssuerVerificationKeyHash" tr) - (meta, LogMessage tipBlockIssuerVkHashText) - -traceD :: Trace IO a -> LOMeta -> Text -> Double -> IO () -traceD tr meta msg d = traceNamedObject tr (meta, LogValue msg (PureD d)) - -traceI :: Integral i => Trace IO a -> LOMeta -> Text -> i -> IO () -traceI tr meta msg i = traceNamedObject tr (meta, LogValue msg (PureI (fromIntegral i))) - -sendEKGDirectCounter :: EKGDirect -> Text -> IO () -sendEKGDirectCounter ekgDirect name = do - modifyMVar_ (ekgCounters ekgDirect) $ \registeredMap -> do - case Map.lookup name registeredMap of - Just counter -> do - Counter.inc counter - pure registeredMap - Nothing -> do - counter <- EKG.getCounter name (ekgServer ekgDirect) - Counter.inc counter - pure $ Map.insert name counter registeredMap - -sendEKGDirectInt :: Integral a => EKGDirect -> Text -> a -> IO () -sendEKGDirectInt ekgDirect name val = do - modifyMVar_ (ekgGauges ekgDirect) $ \registeredMap -> do - case Map.lookup name registeredMap of - Just gauge -> do - Gauge.set gauge (fromIntegral val) - pure registeredMap - Nothing -> do - gauge <- EKG.getGauge name (ekgServer ekgDirect) - Gauge.set gauge (fromIntegral val) - pure $ Map.insert name gauge registeredMap - -sendEKGDirectDouble :: EKGDirect -> Text -> Double -> IO () -sendEKGDirectDouble ekgDirect name val = do - modifyMVar_ (ekgLabels ekgDirect) $ \registeredMap -> do - case Map.lookup name registeredMap of - Just label -> do - Label.set label (Text.pack (show val)) - pure registeredMap - Nothing -> do - label <- EKG.getLabel name (ekgServer ekgDirect) - Label.set label (Text.pack (show val)) - pure $ Map.insert name label registeredMap - -sendEKGDirectPrometheusLabel :: EKGDirect -> Text -> [(Text,Text)] -> IO () -sendEKGDirectPrometheusLabel ekgDirect name labels = do - modifyMVar_ (ekgLabels ekgDirect) $ \registeredMap -> do - case Map.lookup name registeredMap of - Just label -> do - Label.set label (presentPrometheusM labels) - pure registeredMap - Nothing -> do - label <- EKG.getLabel name (ekgServer ekgDirect) - Label.set label (presentPrometheusM labels) - pure $ Map.insert name label registeredMap - where - presentPrometheusM :: [(Text, Text)] -> Text - presentPrometheusM = - label . map pair - where - label pairs = "{" <> Text.intercalate "," pairs <> "}" - pair (k, v) = k <> "=\"" <> v <> "\"" - --------------------------------------------------------------------------------- --- Consensus Tracers --------------------------------------------------------------------------------- - -isRollForward :: TraceChainSyncServerEvent blk -> Bool -isRollForward (TraceChainSyncServerUpdate _tip (AddBlock _pt) _blocking FallingEdge) = True -isRollForward _ = False - -mkConsensusTracers - :: forall blk peer localPeer. - ( Show peer - , Eq peer - , ToObject peer - , ToJSON peer - , LedgerQueries blk - , ToJSON (GenTxId blk) - , ToJSON (HeaderHash blk) - , ToObject (ApplyTxErr blk) - , ToObject (CannotForge blk) - , ToObject (GenTx blk) - , ToObject (LedgerErr (LedgerState blk)) - , ToObject (OtherHeaderEnvelopeError blk) - , ToObject (ValidationErr (BlockProtocol blk)) - , ToObject (ForgeStateUpdateError blk) - , Consensus.RunNode blk - , HasKESMetricsData blk - , HasKESInfo blk - ) - => Maybe EKGDirect - -> TraceSelection - -> TracingVerbosity - -> Trace IO Text - -> NodeKernelData blk - -> ForgingStats - -> IO (Consensus.Tracers' peer localPeer blk (Tracer IO)) -mkConsensusTracers mbEKGDirect trSel verb tr nodeKern fStats = do - let trmet = appendName "metrics" tr - - elidedFetchDecision <- newstate -- for eliding messages in FetchDecision tr - forgeTracers <- mkForgeTracers - meta <- mkLOMeta Critical Public - - tBlocksServed <- STM.newTVarIO 0 - tLocalUp <- STM.newTVarIO 0 - tMaxSlotNo <- STM.newTVarIO $ SlotNo 0 - tSubmissionsCollected <- STM.newTVarIO [] - tSubmissionsAccepted <- STM.newTVarIO 0 - tSubmissionsRejected <- STM.newTVarIO 0 - tBlockDelayM <- STM.newTVarIO Pq.empty - tBlockDelayCDF1s <- STM.newTVarIO $ CdfCounter 0 - tBlockDelayCDF3s <- STM.newTVarIO $ CdfCounter 0 - tBlockDelayCDF5s <- STM.newTVarIO $ CdfCounter 0 - pure Consensus.Tracers - { Consensus.chainSyncClientTracer = tracerOnOff (traceChainSyncClient trSel) verb "ChainSyncClient" tr - , Consensus.chainSyncServerHeaderTracer = - tracerOnOff' (traceChainSyncHeaderServer trSel) - (annotateSeverity . toLogObject' verb $ appendName "ChainSyncHeaderServer" tr) - <> (\(TraceLabelPeer _ ev) -> ev) `contramap` Tracer (traceServedCount mbEKGDirect) - , Consensus.chainSyncServerBlockTracer = tracerOnOff (traceChainSyncBlockServer trSel) verb "ChainSyncBlockServer" tr - , Consensus.consensusSanityCheckTracer = tracerOnOff (traceSanityCheckIssue trSel) verb "ConsensusSanityCheck" tr - , Consensus.blockFetchDecisionTracer = tracerOnOff' (traceBlockFetchDecisions trSel) $ - annotateSeverity $ teeTraceBlockFetchDecision verb elidedFetchDecision tr - , Consensus.blockFetchClientTracer = traceBlockFetchClientMetrics mbEKGDirect tBlockDelayM - tBlockDelayCDF1s tBlockDelayCDF3s tBlockDelayCDF5s $ - tracerOnOff (traceBlockFetchClient trSel) verb "BlockFetchClient" tr - , Consensus.blockFetchServerTracer = traceBlockFetchServerMetrics trmet meta tBlocksServed - tLocalUp tMaxSlotNo $ tracerOnOff (traceBlockFetchServer trSel) verb "BlockFetchServer" tr - , Consensus.gddTracer = tracerOnOff (traceGDD trSel) verb "GDD" tr - , Consensus.keepAliveClientTracer = tracerOnOff (traceKeepAliveClient trSel) verb "KeepAliveClient" tr - , Consensus.forgeStateInfoTracer = tracerOnOff' (traceForgeStateInfo trSel) $ - forgeStateInfoTracer (Proxy @blk) trSel tr - , Consensus.txInboundTracer = tracerOnOff' (traceTxInbound trSel) $ - Tracer $ \ev -> do - traceWith (annotateSeverity . toLogObject' verb $ appendName "TxInbound" tr) ev - case ev of - TraceLabelPeer _ (TraceTxSubmissionCollected collected) -> - traceI trmet meta "submissions.submitted.count" . length =<< - STM.modifyReadTVarIO tSubmissionsCollected (<> collected) - - TraceLabelPeer _ (TraceTxSubmissionProcessed processed) -> do - traceI trmet meta "submissions.accepted.count" =<< - STM.modifyReadTVarIO tSubmissionsAccepted (+ ptxcAccepted processed) - traceI trmet meta "submissions.rejected.count" =<< - STM.modifyReadTVarIO tSubmissionsRejected (+ ptxcRejected processed) - - TraceLabelPeer _ TraceTxInboundTerminated -> return () - TraceLabelPeer _ (TraceTxInboundCanRequestMoreTxs _) -> return () - TraceLabelPeer _ (TraceTxInboundCannotRequestMoreTxs _) -> return () - TraceLabelPeer _ (TraceTxInboundAddedToMempool _ _) -> return () - TraceLabelPeer _ (TraceTxInboundRejectedFromMempool _ _) -> return () - TraceLabelPeer _ (TraceTxInboundError _) -> return () - TraceLabelPeer _ (TraceTxInboundDecision _) -> return () - - , Consensus.txOutboundTracer = tracerOnOff (traceTxOutbound trSel) verb "TxOutbound" tr - , Consensus.localTxSubmissionServerTracer = tracerOnOff (traceLocalTxSubmissionServer trSel) verb "LocalTxSubmissionServer" tr - , Consensus.mempoolTracer = mempoolTracer mbEKGDirect trSel tr fStats - , Consensus.forgeTracer = tracerOnOff' (traceForge trSel) $ - Tracer $ \tlcev@Consensus.TraceLabelCreds{} -> do - traceWith (annotateSeverity - $ traceLeadershipChecks forgeTracers nodeKern verb tr) tlcev - traceWith (forgeTracer verb tr forgeTracers fStats) tlcev - - , Consensus.blockchainTimeTracer = tracerOnOff' (traceBlockchainTime trSel) $ - Tracer $ \ev -> - traceWith (toLogObject tr) (readableTraceBlockchainTimeEvent ev) - , Consensus.consensusErrorTracer = - Tracer $ \err -> traceWith (toLogObject tr) (ConsensusStartupException err) - , Consensus.gsmTracer = tracerOnOff (traceGsm trSel) verb "GSM" tr - , Consensus.csjTracer = tracerOnOff (traceCsj trSel) verb "CSJ" tr - , Consensus.dbfTracer = tracerOnOff (traceDevotedBlockFetch trSel) verb "DevotedBlockFetch" tr - , Consensus.kesAgentTracer = tracerOnOff (traceKesAgent trSel) verb "kesAgent" tr - , Consensus.txLogicTracer = tracerOnOff (traceTxLogic trSel) verb "txLogic" tr - , Consensus.txCountersTracer = tracerOnOff (traceTxCounters trSel) verb "txCounters" tr - } - where - mkForgeTracers :: IO ForgeTracers - mkForgeTracers = do - -- We probably don't want to pay the extra IO cost per-counter-increment. -- sk - metaCritical <- mkLOMeta Critical Confidential - metaInfo <- mkLOMeta Info Public - metaError <- mkLOMeta Error Public - let name :: LoggerName = "metrics.Forge" - ForgeTracers - <$> counting (liftCounting metaInfo name "forged" tr) - <*> counting (liftCounting metaInfo name "forge-about-to-lead" tr) - <*> counting (liftCounting metaError name "could-not-forge" tr) - <*> counting (liftCounting metaInfo name "adopted" tr) - <*> counting (liftCounting metaError name "didnt-adopt" tr) - <*> counting (liftCounting metaError name "forged-invalid" tr) - <*> counting (liftCounting metaInfo name "node-not-leader" tr) - <*> counting (liftCounting metaError name "cannot-forge" tr) - <*> counting (liftCounting metaCritical name "forge-state-update-error" tr) - <*> counting (liftCounting metaError name "block-from-future" tr) - <*> counting (liftCounting metaError name "slot-is-immutable" tr) - <*> counting (liftCounting metaInfo name "node-is-leader" tr) - <*> counting (liftCounting metaError name "adoption-thread-died" tr) - - traceServedCount :: Maybe EKGDirect -> TraceChainSyncServerEvent blk -> IO () - traceServedCount Nothing _ = pure () - traceServedCount (Just ekgDirect) ev = - when (isRollForward ev) $ - sendEKGDirectCounter ekgDirect - "cardano.node.metrics.served.header.counter.int" - - -traceBlockFetchServerMetrics - :: forall blk peer. () - => Tracer IO (LoggerName, LogObject Text) - -> LOMeta - -> STM.TVar Int64 - -> STM.TVar Int64 - -> STM.TVar SlotNo - -> Tracer IO (TraceLabelPeer peer (TraceBlockFetchServerEvent blk)) - -> Tracer IO (TraceLabelPeer peer (TraceBlockFetchServerEvent blk)) -traceBlockFetchServerMetrics trMeta meta tBlocksServed tLocalUp tMaxSlotNo tracer = Tracer bfsTracer - - where - bfsTracer :: TraceLabelPeer peer (TraceBlockFetchServerEvent blk) -> IO () - bfsTracer e@(TraceLabelPeer _p (TraceBlockFetchServerSendBlock p)) = do - traceWith tracer e - - (served, mbLocalUpstreamyness) <- atomically $ do - served <- STM.modifyReadTVar' tBlocksServed (+1) - maxSlotNo <- STM.readTVar tMaxSlotNo - case pointSlot p of - Origin -> return (served, Nothing) - At slotNo -> - case compare maxSlotNo slotNo of - LT -> do - STM.writeTVar tMaxSlotNo slotNo - lu <- STM.modifyReadTVar' tLocalUp (+1) - return (served, Just lu) - GT -> do - return (served, Nothing) - EQ -> do - lu <- STM.modifyReadTVar' tLocalUp (+1) - return (served, Just lu) - - traceI trMeta meta "served.block.count" served - forM_ mbLocalUpstreamyness $ \localUpstreamyness -> - traceI trMeta meta "served.block.latest.count" localUpstreamyness - - --- | CdfCounter tracks the number of time a value below 'limit' has been seen. -newtype CdfCounter (limit :: Nat) = CdfCounter Int64 - --- | Estimates the CDF for a specific limit 'l' by counting the number of times --- a value 'v' is below the limit. -cdfCounter :: forall a l. - ( Num a, Ord a - , KnownNat l) - => a -> Int -> Int64 -> STM.TVar (CdfCounter l) -> STM Double -cdfCounter v !size !step tCdf= do - when (v < lim) $ - STM.modifyTVar' tCdf (\(CdfCounter c) -> CdfCounter $ c + step) - - (CdfCounter cdf) <- STM.readTVar tCdf - return $! (fromIntegral cdf / fromIntegral size) - - where - lim :: a - lim = fromInteger $ natVal (Proxy :: Proxy l) - - --- Add an observation to the CdfCounter. -incCdfCounter :: Ord a => Num a => KnownNat l => a -> Int -> STM.TVar (CdfCounter l) -> STM Double -incCdfCounter v size = cdfCounter v size 1 - --- Remove an observation from the CdfCounter. -decCdfCounter :: Ord a => Num a => KnownNat l => a -> Int -> STM.TVar (CdfCounter l) -> STM Double -decCdfCounter v size = cdfCounter v size (-1) - - --- Track the fraction of times forgeDelay was above 1s, 3s, and 5s. --- Only the first sample per slot number is counted. -cdf135Counters - :: Integral a - => STM.TVar (IntPSQ a NominalDiffTime) - -> STM.TVar (CdfCounter 1) - -> STM.TVar (CdfCounter 3) - -> STM.TVar (CdfCounter 5) - -> a - -> NominalDiffTime - -> STM (Bool, Double, Double, Double) -cdf135Counters slotMapVar cdf1sVar cdf3sVar cdf5sVar slotNo forgeDelay = do - slotMap <- STM.readTVar slotMapVar - if Pq.null slotMap && forgeDelay > 20 - then return (False, 0, 0, 0) -- During startup wait until we are in sync - else case Pq.lookup (fromIntegral slotNo) slotMap of - Nothing -> do - let slotMap' = Pq.insert (fromIntegral slotNo) slotNo forgeDelay slotMap - if Pq.size slotMap' > 1080 -- TODO k/2, should come from config file - then - case Pq.minView slotMap' of - Nothing -> return (False, 0, 0, 0) -- Err. We just inserted an element! - Just (_, minSlotNo, minDelay, slotMap'') -> - if minSlotNo == slotNo - then return (False, 0, 0, 0) -- Nothing to do - else do - decCdfs minDelay (Pq.size slotMap'') - (cdf1s, cdf3s, cdf5s) <- incCdfs forgeDelay (Pq.size slotMap'') - STM.writeTVar slotMapVar slotMap'' - return (True, cdf1s, cdf3s, cdf5s) - else do - (cdf1s, cdf3s, cdf5s) <- incCdfs forgeDelay (Pq.size slotMap') - STM.writeTVar slotMapVar slotMap' - -- Wait until we have at least 45 samples before we start providing - -- cdf estimates. - if Pq.size slotMap >= 45 - then return (True, cdf1s, cdf3s, cdf5s) - else return (True, -1, -1, -1) - - Just _ -> return (False, 0, 0, 0) -- dupe, we only track the first - - where - incCdfs :: NominalDiffTime -> Int -> STM (Double, Double, Double) - incCdfs delay size = do - cdf1s <- incCdfCounter delay size cdf1sVar - cdf3s <- incCdfCounter delay size cdf3sVar - cdf5s <- incCdfCounter delay size cdf5sVar - return (cdf1s, cdf3s, cdf5s) - - decCdfs :: NominalDiffTime -> Int -> STM () - decCdfs delay size = - decCdfCounter delay size cdf1sVar - >> decCdfCounter delay size cdf3sVar - >> decCdfCounter delay size cdf5sVar - >> return () - -traceBlockFetchClientMetrics - :: forall blk remotePeer. - ( ) - => Maybe EKGDirect - -> STM.TVar (IntPSQ Word64 NominalDiffTime) - -> STM.TVar (CdfCounter 1) - -> STM.TVar (CdfCounter 3) - -> STM.TVar (CdfCounter 5) - -> Tracer IO (TraceLabelPeer remotePeer (TraceFetchClientState (Header blk))) - -> Tracer IO (TraceLabelPeer remotePeer (TraceFetchClientState (Header blk))) -traceBlockFetchClientMetrics Nothing _ _ _ _ tracer = tracer -traceBlockFetchClientMetrics (Just ekgDirect) slotMapVar cdf1sVar cdf3sVar cdf5sVar tracer = Tracer bfTracer - - where - bfTracer :: TraceLabelPeer remotePeer (TraceFetchClientState (Header blk)) -> IO () - bfTracer e@(TraceLabelPeer _ (CompletedBlockFetch p _ _ _ delay blockSize)) = do - traceWith tracer e - case pointSlot p of - Origin -> return () -- Nothing to do. - At slotNo -> do - (fresh, cdf1s, cdf3s, cdf5s) <- atomically $ - cdf135Counters slotMapVar cdf1sVar cdf3sVar cdf5sVar (slotMapKey slotNo) delay - - when fresh $ do - -- TODO: Revisit ekg counter access once there is a faster way. - sendEKGDirectDouble ekgDirect "cardano.node.metrics.blockfetchclient.blockdelay.s" - $ realToFrac delay - sendEKGDirectInt ekgDirect "cardano.node.metrics.blockfetchclient.blocksize" - blockSize - when (cdf1s >= 0) $ - sendEKGDirectDouble ekgDirect - "cardano.node.metrics.blockfetchclient.blockdelay.cdfOne" - cdf1s - - when (cdf3s >= 0) $ - sendEKGDirectDouble ekgDirect - "cardano.node.metrics.blockfetchclient.blockdelay.cdfThree" - cdf3s - - when (cdf5s >= 0) $ - sendEKGDirectDouble ekgDirect - "cardano.node.metrics.blockfetchclient.blockdelay.cdfFive" - cdf5s - when (delay > 5) $ - sendEKGDirectCounter ekgDirect "cardano.node.metrics.blockfetchclient.lateblocks" - - bfTracer e = - traceWith tracer e - - slotMapKey :: SlotNo -> Word64 - slotMapKey (SlotNo s) = s - - -traceLeadershipChecks :: - forall blk - . ( Consensus.RunNode blk - , LedgerQueries blk - ) - => ForgeTracers - -> NodeKernelData blk - -> TracingVerbosity - -> Trace IO Text - -> Tracer IO (WithSeverity (Consensus.TraceLabelCreds (Consensus.TraceForgeEvent blk))) -traceLeadershipChecks _ft nodeKern _tverb tr = Tracer $ - \(WithSeverity sev (Consensus.TraceLabelCreds creds event)) -> - case event of - Consensus.TraceStartLeadershipCheck slot -> do - !query <- mapNodeKernelDataIO - (\nk -> - (,,) - <$> ChainDB.getStatistics (getChainDB nk) - <*> nkQueryLedger (ledgerDelegMapSize . ledgerState) nk - <*> nkQueryChain fragmentChainDensity nk) - nodeKern - meta <- mkLOMeta sev Public - fromSMaybe (pure ()) $ - query <&> - \(ledgerStatistics, delegMapSize, _) -> do - traceCounter "utxoSize" tr (LedgerDB.ledgerTableSize ledgerStatistics) - traceCounter "delegMapSize" tr delegMapSize - traceNamedObject (appendName "LeadershipCheck" tr) - ( meta - , LogStructured $ KeyMap.fromList $ - [("kind", String "TraceStartLeadershipCheck") - ,("credentials", String creds) - ,("slot", toJSON $ unSlotNo slot)] - ++ fromSMaybe [] - (query <&> - \(ledgerStatistics, delegMapSize, chainDensity) -> - [ ("utxoSize", toJSON (LedgerDB.ledgerTableSize ledgerStatistics)) - , ("delegMapSize", toJSON delegMapSize) - , ("chainDensity", toJSON (fromRational chainDensity :: Float)) - ]) - ) - _ -> pure () - -teeForge :: - forall blk - . ( Consensus.RunNode blk - , ToObject (CannotForge blk) - , ToObject (LedgerErr (LedgerState blk)) - , ToObject (OtherHeaderEnvelopeError blk) - , ToObject (ValidationErr (BlockProtocol blk)) - , ToObject (ForgeStateUpdateError blk) - ) - => ForgeTracers - -> TracingVerbosity - -> Trace IO Text - -> Tracer IO (WithSeverity (Consensus.TraceLabelCreds (Consensus.TraceForgeEvent blk))) -teeForge ft tverb tr = Tracer $ - \ev@(WithSeverity sev (Consensus.TraceLabelCreds _creds event)) -> do - flip traceWith (WithSeverity sev event) $ fanning $ \(WithSeverity _ e) -> - case e of - Consensus.TraceStartLeadershipCheck{} -> teeForge' (ftForgeAboutToLead ft) - Consensus.TraceSlotIsImmutable{} -> teeForge' (ftTraceSlotIsImmutable ft) - Consensus.TraceBlockFromFuture{} -> teeForge' (ftTraceBlockFromFuture ft) - Consensus.TraceBlockContext{} -> nullTracer - Consensus.TraceNoLedgerState{} -> teeForge' (ftCouldNotForge ft) - Consensus.TraceLedgerState{} -> nullTracer - Consensus.TraceNoLedgerView{} -> teeForge' (ftCouldNotForge ft) - Consensus.TraceLedgerView{} -> nullTracer - Consensus.TraceForgeStateUpdateError{} -> teeForge' (ftTraceForgeStateUpdateError ft) - Consensus.TraceNodeCannotForge {} -> teeForge' (ftTraceNodeCannotForge ft) - Consensus.TraceNodeNotLeader{} -> teeForge' (ftTraceNodeNotLeader ft) - Consensus.TraceNodeIsLeader{} -> teeForge' (ftTraceNodeIsLeader ft) - Consensus.TraceForgeTickedLedgerState{} -> nullTracer - Consensus.TraceForgingMempoolSnapshot{} -> nullTracer - Consensus.TraceForgedBlock{} -> teeForge' (ftForged ft) - Consensus.TraceDidntAdoptBlock{} -> teeForge' (ftDidntAdoptBlock ft) - Consensus.TraceForgedInvalidBlock{} -> teeForge' (ftForgedInvalid ft) - Consensus.TraceAdoptedBlock{} -> teeForge' (ftAdopted ft) - Consensus.TraceAdoptionThreadDied{} -> teeForge' (ftTraceAdoptionThreadDied ft) - case event of - Consensus.TraceStartLeadershipCheck _slot -> pure () - _ -> traceWith (toLogObject' tverb tr) ev - -teeForge' - :: Trace IO Text - -> Tracer IO (WithSeverity (Consensus.TraceForgeEvent blk)) -teeForge' tr = - Tracer $ \(WithSeverity _ ev) -> do - meta <- mkLOMeta Critical Confidential - traceNamedObject (appendName "metrics" tr) . (meta,) $ - case ev of - Consensus.TraceStartLeadershipCheck slot -> - LogValue "aboutToLeadSlotLast" $ PureI $ fromIntegral $ unSlotNo slot - Consensus.TraceSlotIsImmutable slot _tipPoint _tipBlkNo -> - LogValue "slotIsImmutable" $ PureI $ fromIntegral $ unSlotNo slot - Consensus.TraceBlockFromFuture slot _slotNo -> - LogValue "blockFromFuture" $ PureI $ fromIntegral $ unSlotNo slot - Consensus.TraceBlockContext slot _tipBlkNo _tipPoint -> - LogValue "blockContext" $ PureI $ fromIntegral $ unSlotNo slot - Consensus.TraceNoLedgerState slot _ -> - LogValue "couldNotForgeSlotLast" $ PureI $ fromIntegral $ unSlotNo slot - Consensus.TraceLedgerState slot _ -> - LogValue "ledgerState" $ PureI $ fromIntegral $ unSlotNo slot - Consensus.TraceNoLedgerView slot _ -> - LogValue "couldNotForgeSlotLast" $ PureI $ fromIntegral $ unSlotNo slot - Consensus.TraceLedgerView slot -> - LogValue "ledgerView" $ PureI $ fromIntegral $ unSlotNo slot - Consensus.TraceForgeStateUpdateError slot _reason -> - LogValue "forgeStateUpdateError" $ PureI $ fromIntegral $ unSlotNo slot - Consensus.TraceNodeCannotForge slot _reason -> - LogValue "nodeCannotForge" $ PureI $ fromIntegral $ unSlotNo slot - Consensus.TraceNodeNotLeader slot -> - LogValue "nodeNotLeader" $ PureI $ fromIntegral $ unSlotNo slot - Consensus.TraceNodeIsLeader slot -> - LogValue "nodeIsLeader" $ PureI $ fromIntegral $ unSlotNo slot - Consensus.TraceForgeTickedLedgerState slot _prevPt -> - LogValue "forgeTickedLedgerState" $ PureI $ fromIntegral $ unSlotNo slot - Consensus.TraceForgingMempoolSnapshot slot _prevPt _mpHash _mpSlotNo -> - LogValue "forgingMempoolSnapshot" $ PureI $ fromIntegral $ unSlotNo slot - Consensus.TraceForgedBlock slot _ _ _ _ -> - LogValue "forgedSlotLast" $ PureI $ fromIntegral $ unSlotNo slot - Consensus.TraceDidntAdoptBlock slot _ -> - LogValue "notAdoptedSlotLast" $ PureI $ fromIntegral $ unSlotNo slot - Consensus.TraceForgedInvalidBlock slot _ _ -> - LogValue "forgedInvalidSlotLast" $ PureI $ fromIntegral $ unSlotNo slot - Consensus.TraceAdoptedBlock slot _ _ -> - LogValue "adoptedSlotLast" $ PureI $ fromIntegral $ unSlotNo slot - Consensus.TraceAdoptionThreadDied slot _ -> - LogValue "adoptionThreadDied" $ PureI $ fromIntegral $ unSlotNo slot - -forgeTracer - :: forall blk. - ( Consensus.RunNode blk - , ToObject (CannotForge blk) - , ToObject (LedgerErr (LedgerState blk)) - , ToObject (OtherHeaderEnvelopeError blk) - , ToObject (ValidationErr (BlockProtocol blk)) - , ToObject (ForgeStateUpdateError blk) - , HasKESInfo blk - ) - => TracingVerbosity - -> Trace IO Text - -> ForgeTracers - -> ForgingStats - -> Tracer IO (Consensus.TraceLabelCreds (Consensus.TraceForgeEvent blk)) -forgeTracer verb tr forgeTracers fStats = - Tracer $ \tlcev@(Consensus.TraceLabelCreds _ ev) -> do - -- Ignoring the credentials label for measurement and counters: - traceWith (notifyBlockForging fStats tr) ev - -- Consensus tracer -- here we track the label: - traceWith (annotateSeverity - $ teeForge forgeTracers verb - $ appendName "Forge" tr) tlcev - traceKESInfoIfKESExpired ev - where - traceKESInfoIfKESExpired ev = - case ev of - Consensus.TraceForgeStateUpdateError _ reason -> - -- KES-key cannot be evolved, but anyway trace KES-values. - case getKESInfo (Proxy @blk) reason of - Nothing -> pure () - Just kesInfo -> do - let logValues :: [LOContent a] - logValues = - [ LogValue "operationalCertificateStartKESPeriod" - $ PureI . fromIntegral . unKESPeriod . HotKey.kesStartPeriod $ kesInfo - , LogValue "operationalCertificateExpiryKESPeriod" - $ PureI . fromIntegral . unKESPeriod . HotKey.kesEndPeriod $ kesInfo - , LogValue "currentKESPeriod" - $ PureI 0 - , LogValue "remainingKESPeriods" - $ PureI 0 - ] - meta <- mkLOMeta Critical Confidential - mapM_ (traceNamedObject (appendName "metrics" tr) . (meta,)) logValues - _ -> pure () - -notifyBlockForging - :: ForgingStats - -> Trace IO Text - -> Tracer IO (Consensus.TraceForgeEvent blk) -notifyBlockForging fStats tr = Tracer $ \case - Consensus.TraceNodeCannotForge {} -> - traceCounter "nodeCannotForge" tr - =<< mapForgingCurrentThreadStats fStats - (\fts -> (fts { ftsNodeCannotForgeNum = ftsNodeCannotForgeNum fts + 1 }, - ftsNodeCannotForgeNum fts + 1)) - (Consensus.TraceNodeIsLeader (SlotNo slot')) -> do - let slot = fromIntegral slot' - traceCounter "nodeIsLeaderNum" tr - =<< mapForgingCurrentThreadStats fStats - (\fts -> (fts { ftsNodeIsLeaderNum = ftsNodeIsLeaderNum fts + 1 - , ftsLastSlot = slot }, - ftsNodeIsLeaderNum fts + 1)) - Consensus.TraceForgedBlock {} -> do - traceCounter "blocksForgedNum" tr - =<< mapForgingCurrentThreadStats fStats - (\fts -> (fts { ftsBlocksForgedNum = ftsBlocksForgedNum fts + 1 }, - ftsBlocksForgedNum fts + 1)) - - Consensus.TraceNodeNotLeader (SlotNo slot') -> do - -- Not is not a leader again, so now the number of blocks forged by this node - -- should be equal to the number of slots when this node was a leader. - let slot = fromIntegral slot' - hasMissed <- - mapForgingCurrentThreadStats fStats - (\fts -> - if ftsLastSlot fts == 0 || succ (ftsLastSlot fts) == slot then - (fts { ftsLastSlot = slot }, False) - else - let missed = ftsSlotsMissedNum fts + (slot - ftsLastSlot fts) - in (fts { ftsLastSlot = slot, ftsSlotsMissedNum = missed }, True)) - when hasMissed $ do - x <- sum <$> threadStatsProjection fStats ftsSlotsMissedNum - traceCounter "slotsMissedNum" tr x - _ -> pure () - - --------------------------------------------------------------------------------- --- Mempool Tracers --------------------------------------------------------------------------------- - -notifyTxsMempoolTimeoutSoft :: - Maybe EKGDirect - -> Tracer IO (TraceEventMempool blk) -notifyTxsMempoolTimeoutSoft mbEKGDirect = case mbEKGDirect of - Nothing -> nullTracer - Just ekgDirect -> Tracer $ \ev -> do - when (ConsensusTracers.impliesMempoolTimeoutSoft ev) $ do - sendEKGDirectCounter ekgDirect $ "cardano.node.metrics." <> ConsensusTracers.txsMempoolTimeoutSoftCounterName - -notifyTxsProcessed :: ForgingStats -> Trace IO Text -> Tracer IO (TraceEventMempool blk) -notifyTxsProcessed fStats tr = Tracer $ \case - TraceMempoolRemoveTxs [] _ -> return () - TraceMempoolRemoveTxs txs _ -> do - -- TraceMempoolRemoveTxs are previously valid transactions that are no longer valid because of - -- changes in the ledger state. These transactions are already removed from the mempool, - -- so we can treat them as completely processed. - updatedTxProcessed <- mapForgingStatsTxsProcessed fStats (+ (length txs)) - traceCounter "txsProcessedNum" tr (fromIntegral updatedTxProcessed) - TraceMempoolSynced (FallingEdgeWith duration) -> do - let durationMs = round $ 1000 * duration :: Int - cumulativeSyncMs <- mapForgingStatsTxsSyncDuration fStats (+ durationMs) - traceCounter "txsSyncDuration" tr durationMs - traceCounter ConsensusTracers.txsSyncDurationTotalCounterName tr cumulativeSyncMs - - -- The rest of the constructors. - _ -> return () - - -mempoolMetricsTraceTransformer :: Trace IO a -> Tracer IO (TraceEventMempool blk) -mempoolMetricsTraceTransformer tr = Tracer $ \mempoolEvent -> do - let tr' = appendName "metrics" tr - (_n, tot_m) = case mempoolEvent of - TraceMempoolAddedTx _tx0 _ tot0 -> (1, Just tot0) - TraceMempoolRejectedTx _tx0 _ _ tot0 -> (1, Just tot0) - TraceMempoolRemoveTxs txs0 tot0 -> (length txs0, Just tot0) - TraceMempoolManuallyRemovedTxs txs0 txs1 tot0 -> ( length txs0 + length txs1, Just tot0) - TraceMempoolSynced _ -> (0, Nothing) - _ -> (0, Nothing) - case tot_m of - Just tot -> do - let logValue1 :: LOContent a - logValue1 = LogValue "txsInMempool" $ PureI $ fromIntegral (msNumTxs tot) - logValue2 :: LOContent a - logValue2 = LogValue "mempoolBytes" . PureI . fromIntegral . unByteSize32 . msNumBytes $ tot - meta <- mkLOMeta Critical Confidential - traceNamedObject tr' (meta, logValue1) - traceNamedObject tr' (meta, logValue2) - Nothing -> return () - -mempoolTracer - :: ( ToJSON (GenTxId blk) - , ToObject (ApplyTxErr blk) - , ToObject (GenTx blk) - , ToJSON (HeaderHash blk) - , LedgerSupportsMempool blk - , ConvertRawHash blk - ) - => Maybe EKGDirect - -> TraceSelection - -> Trace IO Text - -> ForgingStats - -> Tracer IO (TraceEventMempool blk) -mempoolTracer mbEKGDirect tc tracer fStats = Tracer $ \ev -> do - -- Update the EKG metric even when this tracer is turned off. - traceWith (notifyTxsMempoolTimeoutSoft mbEKGDirect) ev - whenOn (traceMempool tc) $ do - traceWith (mempoolMetricsTraceTransformer tracer) ev - traceWith (notifyTxsProcessed fStats tracer) ev - let tr = appendName "Mempool" tracer - traceWith (mpTracer tc tr) ev - -mpTracer :: ( ToJSON (GenTxId blk) - , ToObject (ApplyTxErr blk) - , ToObject (GenTx blk) - , ToJSON (HeaderHash blk) - , ConvertRawHash blk - , LedgerSupportsMempool blk - ) - => TraceSelection -> Trace IO Text -> Tracer IO (TraceEventMempool blk) -mpTracer tc tr = annotateSeverity $ toLogObject' (traceVerbosity tc) tr - --------------------------------------------------------------------------------- --- ForgeStateInfo Tracers --------------------------------------------------------------------------------- - -forgeStateInfoMetricsTraceTransformer - :: forall a blk. HasKESMetricsData blk - => Proxy blk - -> Trace IO a - -> Tracer IO (Consensus.TraceLabelCreds (ForgeStateInfo blk)) -forgeStateInfoMetricsTraceTransformer p tr = Tracer $ - \(Consensus.TraceLabelCreds _ forgeStateInfo) -> do - case getKESMetricsData p forgeStateInfo of - NoKESMetricsData -> pure () - TPraosKESMetricsData kesPeriodOfKey - (MaxKESEvolutions maxKesEvos) - (OperationalCertStartKESPeriod oCertStartKesPeriod) -> do - let metricsTr = appendName "metrics" tr - - -- The KES period of the hot key is relative to the start KES - -- period of the operational certificate. - currentKesPeriod = oCertStartKesPeriod + kesPeriodOfKey - - oCertExpiryKesPeriod = oCertStartKesPeriod + fromIntegral maxKesEvos - - kesPeriodsUntilExpiry = - max 0 (oCertExpiryKesPeriod - currentKesPeriod) - - logValues :: [LOContent a] - logValues = - [ LogValue "operationalCertificateStartKESPeriod" - $ PureI - $ fromIntegral oCertStartKesPeriod - , LogValue "operationalCertificateExpiryKESPeriod" - $ PureI - $ fromIntegral oCertExpiryKesPeriod - , LogValue "currentKESPeriod" - $ PureI - $ fromIntegral currentKesPeriod - , LogValue "remainingKESPeriods" - $ PureI - $ fromIntegral kesPeriodsUntilExpiry - ] - - metaInfo <- mkLOMeta Info Public - mapM_ (traceNamedObject metricsTr . (metaInfo,)) logValues - - -- Trace warning messages on the last 7 KES periods and, in the - -- final and subsequent KES periods, trace alert messages. - metaWarning <- mkLOMeta Warning Public - metaAlert <- mkLOMeta Alert Public - traceWith tr - ( mempty - , LogObject - mempty - (if kesPeriodsUntilExpiry > 7 - then metaInfo - else if kesPeriodsUntilExpiry > 1 - then metaWarning - else metaAlert - ) - (LogStructuredText mempty (expiryLogMessage kesPeriodsUntilExpiry)) - ) - where - expiryLogMessage :: Word -> Text - expiryLogMessage kesPeriodsUntilExpiry = - "Operational key will expire in " - <> (Text.pack . show) kesPeriodsUntilExpiry - <> " KES periods." - -forgeStateInfoTracer - :: forall blk. - ( HasKESMetricsData blk - , Show (ForgeStateInfo blk) - ) - => Proxy blk - -> TraceSelection - -> Trace IO Text - -> Tracer IO (Consensus.TraceLabelCreds (ForgeStateInfo blk)) -forgeStateInfoTracer p _ts tracer = Tracer $ \ev -> do - let tr = appendName "Forge" tracer - traceWith (forgeStateInfoMetricsTraceTransformer p tracer) ev - traceWith (fsTracer tr) ev - where - fsTracer :: Trace IO Text -> Tracer IO (Consensus.TraceLabelCreds (ForgeStateInfo blk)) - fsTracer tr = showTracing $ contramap Text.pack $ toLogObject tr - --------------------------------------------------------------------------------- --- NodeToClient Tracers --------------------------------------------------------------------------------- - -nodeToClientTracers' - :: forall blk localPeer. - ( HasPrivacyAnnotation (Stateful.TraceSendRecv (LocalStateQuery blk (Point blk) (Query blk)) LocalStateQuery.State) - , HasSeverityAnnotation (Stateful.TraceSendRecv (LocalStateQuery blk (Point blk) (Query blk)) LocalStateQuery.State) - , ToObject (Stateful.TraceSendRecv (LocalStateQuery blk (Point blk) (Query blk)) LocalStateQuery.State) - , forall fp. ShowQuery (BlockQuery blk fp) - , ToObject localPeer - ) - => TraceSelection - -> TracingVerbosity - -> Trace IO Text - -> NodeToClient.Tracers' localPeer blk DeserialiseFailure (Tracer IO) -nodeToClientTracers' trSel verb tr = - NodeToClient.Tracers - { NodeToClient.tChainSyncTracer = - tracerOnOff (traceLocalChainSyncProtocol trSel) - verb "LocalChainSyncProtocol" tr - , NodeToClient.tTxMonitorTracer = - tracerOnOff (traceLocalTxMonitorProtocol trSel) - verb "LocalTxMonitorProtocol" tr - , NodeToClient.tTxSubmissionTracer = - tracerOnOff (traceLocalTxSubmissionProtocol trSel) - verb "LocalTxSubmissionProtocol" tr - , NodeToClient.tStateQueryTracer = - tracerOnOff (traceLocalStateQueryProtocol trSel) - verb "LocalStateQueryProtocol" tr - } - --------------------------------------------------------------------------------- --- NodeToNode Tracers --------------------------------------------------------------------------------- - -nodeToNodeTracers' - :: ( Consensus.RunNode blk - , ConvertTxId blk - , HasTxs blk - , Show addr - , ToObject (ConnectionId addr) - , ToJSON addr - ) - => TraceSelection - -> TracingVerbosity - -> Trace IO Text - -> NodeToNode.Tracers IO addr blk DeserialiseFailure -nodeToNodeTracers' trSel verb tr = - NodeToNode.Tracers - { NodeToNode.tChainSyncTracer = - tracerOnOff (traceChainSyncProtocol trSel) - verb "ChainSyncProtocol" tr - , NodeToNode.tChainSyncSerialisedTracer = - showOnOff (traceChainSyncProtocol trSel) - "ChainSyncProtocolSerialised" tr - , NodeToNode.tBlockFetchTracer = - tracerOnOff (traceBlockFetchProtocol trSel) - verb "BlockFetchProtocol" tr - , NodeToNode.tBlockFetchSerialisedTracer = - showOnOff (traceBlockFetchProtocolSerialised trSel) - "BlockFetchProtocolSerialised" tr - , NodeToNode.tTxSubmission2Tracer = - tracerOnOff (traceTxSubmissionProtocol trSel) - verb "TxSubmissionProtocol" tr - , NodeToNode.tKeepAliveTracer = - tracerOnOff (traceKeepAliveProtocol trSel) - verb "KeepAliveProtocol" tr - , NodeToNode.tPeerSharingTracer = - tracerOnOff (tracePeerSharingProtocol trSel) - verb "PeerSharingPrototocol" tr - , NodeToNode.tTxLogicTracer = - tracerOnOff (traceTxLogic trSel) - verb "TxLogicTracer" tr - } - --- TODO @ouroboros-network -teeTraceBlockFetchDecision - :: ( Eq peer - , Show peer - , ToJSON peer - , ToJSON (HeaderHash blk) - , HasHeader blk - , ConvertRawHash blk - ) - => TracingVerbosity - -> MVar (Maybe (WithSeverity [TraceLabelPeer peer (FetchDecision [Point (Header blk)])]),Integer) - -> Trace IO Text - -> Tracer IO (WithSeverity (TraceDecisionEvent peer (Header blk))) -teeTraceBlockFetchDecision verb eliding tr = - Tracer $ \(WithSeverity s ev) -> case ev of - PeerStarvedUs {} -> do - traceWith (toLogObject' verb meTr) ev - PeersFetch ev' -> do - traceWith (teeTraceBlockFetchDecisionElide verb eliding bfdTr) (WithSeverity s ev') - where - meTr = appendName "metrics" tr - bfdTr = appendName "BlockFetchDecision" tr - -teeTraceBlockFetchDecisionElide - :: ( Eq peer - , Show peer - , ToJSON peer - , ToJSON (HeaderHash blk) - , HasHeader blk - , ConvertRawHash blk - ) - => TracingVerbosity - -> MVar (Maybe (WithSeverity [TraceLabelPeer peer (FetchDecision [Point (Header blk)])]),Integer) - -> Trace IO Text - -> Tracer IO (WithSeverity [TraceLabelPeer peer (FetchDecision [Point (Header blk)])]) -teeTraceBlockFetchDecisionElide = elideToLogObject - --------------------------------------------------------------------------------- --- PeerSelection Tracers --------------------------------------------------------------------------------- - -traceConnectionManagerTraceMetrics - :: OnOff TraceConnectionManagerCounters - -> Maybe EKGDirect - -> Tracer IO (ConnectionManager.Trace peerAddr handlerTrace) -traceConnectionManagerTraceMetrics _ Nothing = nullTracer -traceConnectionManagerTraceMetrics (OnOff False) _ = nullTracer -traceConnectionManagerTraceMetrics (OnOff True) (Just ekgDirect) = cmtTracer - where - cmtTracer :: Tracer IO (ConnectionManager.Trace peerAddr handlerTrace) - cmtTracer = Tracer $ \case - ConnectionManager.TrConnectionManagerCounters - ConnectionManagerCounters { - fullDuplexConns, - duplexConns, - unidirectionalConns, - inboundConns, - outboundConns - } -> do - sendEKGDirectInt ekgDirect - "cardano.node.metrics.connectionManager.fullDuplexConns" - fullDuplexConns - sendEKGDirectInt ekgDirect - "cardano.node.metrics.connectionManager.duplexConns" - duplexConns - sendEKGDirectInt ekgDirect - "cardano.node.metrics.connectionManager.unidirectionalConns" - unidirectionalConns - sendEKGDirectInt ekgDirect - "cardano.node.metrics.connectionManager.incomingConns" - inboundConns - sendEKGDirectInt ekgDirect - "cardano.node.metrics.connectionManager.outgoingConns" - outboundConns - _ -> return () - -tracePeerSelectionTracerMetrics - :: forall extraDebugState extraFlags extraPeers peeraddr. - OnOff TracePeerSelection - -> Maybe EKGDirect - -> Tracer IO (Governor.TracePeerSelection extraDebugState extraFlags extraPeers peeraddr) -tracePeerSelectionTracerMetrics _ Nothing = nullTracer -tracePeerSelectionTracerMetrics (OnOff False) _ = nullTracer -tracePeerSelectionTracerMetrics (OnOff True) (Just ekgDirect) = pstTracer - where - pstTracer :: Tracer IO (Governor.TracePeerSelection extraDebugState extraFlags extraPeers peeraddr) - pstTracer = Tracer $ \a -> do - case a of - Governor.TraceChurnAction duration action _ -> - sendEKGDirectDouble - ekgDirect - ("cardano.node.metrics.peerSelection.churn." <> Text.pack (show action) <> ".duration") - (realToFrac duration) - _ -> pure () - -tracePeerSelectionCountersMetrics - :: OnOff TracePeerSelectionCounters - -> Maybe EKGDirect - -> Tracer IO CardanoPeerSelectionCounters -tracePeerSelectionCountersMetrics _ Nothing = nullTracer -tracePeerSelectionCountersMetrics (OnOff False) _ = nullTracer -tracePeerSelectionCountersMetrics (OnOff True) (Just ekgDirect) = pscTracer - where - pscTracer :: Tracer IO CardanoPeerSelectionCounters - pscTracer = Tracer $ \psc -> do - let Governor.PeerSelectionCountersHWC {..} = psc - -- Deprecated counters; they will be removed in a future version - sendEKGDirectInt ekgDirect "cardano.node.metrics.peerSelection.cold" numberOfColdPeers - sendEKGDirectInt ekgDirect "cardano.node.metrics.peerSelection.warm" numberOfWarmPeers - sendEKGDirectInt ekgDirect "cardano.node.metrics.peerSelection.hot" numberOfHotPeers - sendEKGDirectInt ekgDirect "cardano.node.metrics.peerSelection.coldBigLedgerPeers" numberOfColdBigLedgerPeers - sendEKGDirectInt ekgDirect "cardano.node.metrics.peerSelection.warmBigLedgerPeers" numberOfWarmBigLedgerPeers - sendEKGDirectInt ekgDirect "cardano.node.metrics.peerSelection.hotBigLedgerPeers" numberOfHotBigLedgerPeers - - let PeerSelectionCounters {..} = psc - sendEKGDirectInt ekgDirect "cardano.node.metrics.peerSelection.RootPeers" numberOfRootPeers - - sendEKGDirectInt ekgDirect "cardano.node.metrics.peerSelection.KnownPeers" numberOfKnownPeers - sendEKGDirectInt ekgDirect "cardano.node.metrics.peerSelection.ColdPeersPromotions" numberOfColdPeersPromotions - sendEKGDirectInt ekgDirect "cardano.node.metrics.peerSelection.EstablishedPeers" numberOfEstablishedPeers - sendEKGDirectInt ekgDirect "cardano.node.metrics.peerSelection.WarmPeersDemotions" numberOfWarmPeersDemotions - sendEKGDirectInt ekgDirect "cardano.node.metrics.peerSelection.WarmPeersPromotions" numberOfWarmPeersPromotions - sendEKGDirectInt ekgDirect "cardano.node.metrics.peerSelection.ActivePeers" numberOfActivePeers - sendEKGDirectInt ekgDirect "cardano.node.metrics.peerSelection.ActivePeersDemotions" numberOfActivePeersDemotions - - - sendEKGDirectInt ekgDirect "cardano.node.metrics.peerSelection.KnownBigLedgerPeers" numberOfKnownBigLedgerPeers - sendEKGDirectInt ekgDirect "cardano.node.metrics.peerSelection.ColdBigLedgerPeersPromotions" numberOfColdBigLedgerPeersPromotions - sendEKGDirectInt ekgDirect "cardano.node.metrics.peerSelection.EstablishedBigLedgerPeers" numberOfEstablishedBigLedgerPeers - sendEKGDirectInt ekgDirect "cardano.node.metrics.peerSelection.WarmBigLedgerPeersDemotions" numberOfWarmBigLedgerPeersDemotions - sendEKGDirectInt ekgDirect "cardano.node.metrics.peerSelection.WarmBigLedgerPeersPromotions" numberOfWarmBigLedgerPeersPromotions - sendEKGDirectInt ekgDirect "cardano.node.metrics.peerSelection.ActiveBigLedgerPeers" numberOfActiveBigLedgerPeers - sendEKGDirectInt ekgDirect "cardano.node.metrics.peerSelection.ActiveBigLedgerPeersDemotions" numberOfActiveBigLedgerPeersDemotions - - sendEKGDirectInt ekgDirect "cardano.node.metrics.peerSelection.KnownLocalRootPeers" numberOfKnownLocalRootPeers - sendEKGDirectInt ekgDirect "cardano.node.metrics.peerSelection.EstablishedLocalRootPeers" numberOfEstablishedLocalRootPeers - sendEKGDirectInt ekgDirect "cardano.node.metrics.peerSelection.WarmLocalRootPeersPromotions" numberOfWarmLocalRootPeersPromotions - sendEKGDirectInt ekgDirect "cardano.node.metrics.peerSelection.ActiveLocalRootPeers" numberOfActiveLocalRootPeers - sendEKGDirectInt ekgDirect "cardano.node.metrics.peerSelection.ActiveLocalRootPeersDemotions" numberOfActiveLocalRootPeersDemotions - - sendEKGDirectInt ekgDirect "cardano.node.metrics.peerSelection.KnownNonRootPeers" numberOfKnownNonRootPeers - sendEKGDirectInt ekgDirect "cardano.node.metrics.peerSelection.ColdNonRootPeersPromotions" numberOfColdNonRootPeersPromotions - sendEKGDirectInt ekgDirect "cardano.node.metrics.peerSelection.EstablishedNonRootPeers" numberOfEstablishedNonRootPeers - sendEKGDirectInt ekgDirect "cardano.node.metrics.peerSelection.WarmNonRootPeersDemotions" numberOfWarmNonRootPeersDemotions - sendEKGDirectInt ekgDirect "cardano.node.metrics.peerSelection.WarmNonRootPeersPromotions" numberOfWarmNonRootPeersPromotions - sendEKGDirectInt ekgDirect "cardano.node.metrics.peerSelection.ActiveNonRootPeers" numberOfActiveNonRootPeers - sendEKGDirectInt ekgDirect "cardano.node.metrics.peerSelection.ActiveNonRootPeersDemotions" numberOfActiveNonRootPeersDemotions - - sendEKGDirectInt ekgDirect "cardano.node.metrics.peerSelection.KnownBootstrapPeers" (snd $ Cardano.viewKnownBootstrapPeers extraCounters) - sendEKGDirectInt ekgDirect "cardano.node.metrics.peerSelection.ColdBootstrapPeersPromotions" (snd $ Cardano.viewColdBootstrapPeersPromotions extraCounters) - sendEKGDirectInt ekgDirect "cardano.node.metrics.peerSelection.EstablishedBootstrapPeers" (snd $ Cardano.viewEstablishedBootstrapPeers extraCounters) - sendEKGDirectInt ekgDirect "cardano.node.metrics.peerSelection.WarmBootstrapPeersDemotions" (snd $ Cardano.viewWarmBootstrapPeersDemotions extraCounters) - sendEKGDirectInt ekgDirect "cardano.node.metrics.peerSelection.WarmBootstrapPeersPromotions" (snd $ Cardano.viewWarmBootstrapPeersPromotions extraCounters) - sendEKGDirectInt ekgDirect "cardano.node.metrics.peerSelection.ActiveBootstrapPeers" (snd $ Cardano.viewActiveBootstrapPeers extraCounters) - sendEKGDirectInt ekgDirect "cardano.node.metrics.peerSelection.ActiveBootstrapPeersDemotions" (snd $ Cardano.viewActiveBootstrapPeersDemotions extraCounters) - -traceInboundGovernorCountersMetrics - :: forall addr. - OnOff TraceInboundGovernorCounters - -> Maybe EKGDirect - -> Tracer IO (InboundGovernor.Trace addr) -traceInboundGovernorCountersMetrics _ Nothing = nullTracer -traceInboundGovernorCountersMetrics (OnOff False) _ = nullTracer -traceInboundGovernorCountersMetrics (OnOff True) (Just ekgDirect) = ipgcTracer - where - ipgcTracer :: Tracer IO (InboundGovernor.Trace addr) - ipgcTracer = Tracer $ \case - (InboundGovernor.TrInboundGovernorCounters InboundGovernor.Counters { - idlePeersRemote, - coldPeersRemote, - warmPeersRemote, - hotPeersRemote - }) -> do - sendEKGDirectInt ekgDirect "cardano.node.metrics.inboundGovernor.idle" - idlePeersRemote - sendEKGDirectInt ekgDirect "cardano.node.metrics.inboundGovernor.cold" - coldPeersRemote - sendEKGDirectInt ekgDirect "cardano.node.metrics.inboundGovernor.warm" - warmPeersRemote - sendEKGDirectInt ekgDirect "cardano.node.metrics.inboundGovernor.hot" - hotPeersRemote - _ -> return () - - --- | get information about a chain fragment - -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. - , fork :: Bool - -- ^ Was this a fork. - , tipBlockHash :: Text - -- ^ Hash of the last adopted block. - , tipBlockParentHash :: Text - -- ^ Hash of the parent block of the last adopted block. - , tipBlockIssuerVerificationKeyHash :: BlockIssuerVerificationKeyHash - -- ^ Hash of the last adopted block issuer's verification key. - } - -chainInformation - :: forall blk. () - => HasHeader (Header blk) - => HasIssuer blk - => ConvertRawHash blk - => ChainDB.SelectionChangedInfo blk - -> Bool - -> AF.AnchoredFragment (Header blk) -- ^ Old fragment. - -> AF.AnchoredFragment (Header blk) -- ^ New fragment. - -> Int64 - -> ChainInformation -chainInformation selChangedInfo fork oldFrag frag blocksUncoupledDelta = ChainInformation - { slots = unSlotNo $ fromWithOrigin 0 (AF.headSlot frag) - , blocks = unBlockNo $ fromWithOrigin (BlockNo 1) (AF.headBlockNo frag) - , density = fragmentChainDensity frag - , epoch = ChainDB.newTipEpoch selChangedInfo - , slotInEpoch = ChainDB.newTipSlotInEpoch selChangedInfo - , blocksUncoupledDelta = blocksUncoupledDelta - , fork = fork - , tipBlockHash = renderHeaderHash (Proxy @blk) $ realPointHash (ChainDB.newTipPoint selChangedInfo) - , tipBlockParentHash = renderChainHash (Text.decodeLatin1 . B16.encode . toRawHash (Proxy @blk)) $ AF.headHash oldFrag - , tipBlockIssuerVerificationKeyHash = tipIssuerVkHash - } - where - tipIssuerVkHash :: BlockIssuerVerificationKeyHash - tipIssuerVkHash = - case AF.head frag of - Left AF.AnchorGenesis -> - NoBlockIssuer - Left (AF.Anchor _s _h _b) -> - NoBlockIssuer - Right blk -> getIssuerVerificationKeyHash blk - -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 - - --------------------------------------------------------------------------------- --- Trace Helpers --------------------------------------------------------------------------------- - -readableTraceBlockchainTimeEvent :: TraceBlockchainTimeEvent UTCTime -> Text -readableTraceBlockchainTimeEvent ev = case ev of - TraceStartTimeInTheFuture (SystemStart start) toWait -> - "Waiting " <> (Text.pack . show) toWait <> " until genesis start time at " <> (Text.pack . show) start - TraceCurrentSlotUnknown time _ -> - "Too far from the chain tip to determine the current slot number for the time " - <> (Text.pack . show) time - 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 - -tracerOnOff :: Transformable Text IO a - => OnOff b - -> TracingVerbosity - -> LoggerName - -> Trace IO Text - -> Tracer IO a -tracerOnOff (OnOff False) _ _ _ = nullTracer -tracerOnOff (OnOff True) verb name trcer = annotateSeverity - $ toLogObject' verb - $ appendName name trcer - -tracerOnOff' - :: OnOff b -> Tracer IO a -> Tracer IO a -tracerOnOff' (OnOff False) _ = nullTracer -tracerOnOff' (OnOff True) tr = tr - -whenOn :: Monad m => OnOff b -> m () -> m () -whenOn (OnOff b) = when b - -instance Show a => Show (WithSeverity a) where - show (WithSeverity _sev a) = show a - -showOnOff - :: (Show a, HasSeverityAnnotation a) - => OnOff b -> LoggerName -> Trace IO Text -> Tracer IO a -showOnOff (OnOff False) _ _ = nullTracer -showOnOff (OnOff True) name trcer = annotateSeverity - $ showTracing - $ withName name trcer - -withName :: Text -> Trace IO Text -> Tracer IO String -withName name tr = contramap Text.pack $ toLogObject $ appendName name tr diff --git a/cardano-node/test/Test/Cardano/Node/POM.hs b/cardano-node/test/Test/Cardano/Node/POM.hs index ab86a6c0300..2d131f83235 100644 --- a/cardano-node/test/Test/Cardano/Node/POM.hs +++ b/cardano-node/test/Test/Cardano/Node/POM.hs @@ -19,8 +19,6 @@ import Cardano.Node.Configuration.Socket import Cardano.Node.Handlers.Shutdown import Cardano.Node.Types import Cardano.Rpc.Server.Config (makeRpcConfig) -import Cardano.Tracing.Config (PartialTraceOptions (..), defaultPartialTraceConfiguration, - partialTraceSelectionToEither) import Ouroboros.Consensus.Node (NodeDatabasePaths (..)) import Ouroboros.Consensus.Node.Genesis (disableGenesisConfig) import Ouroboros.Consensus.Storage.LedgerDB.Args @@ -141,9 +139,6 @@ testPartialYamlConfig = , pncExperimentalProtocolsEnabled = Last Nothing , pncMaxConcurrencyBulkSync = Last Nothing , pncMaxConcurrencyDeadline = Last Nothing - , pncLoggingSwitch = Last $ Just True - , pncLogMetrics = Last $ Just True - , pncTraceConfig = Last (Just $ PartialTracingOnLegacy defaultPartialTraceConfiguration) , pncTraceForwardSocket = Last Nothing , pncConfigFile = mempty , pncTopologyFile = mempty @@ -202,9 +197,6 @@ testPartialCliConfig = , pncProtocolConfig = mempty , pncMaxConcurrencyBulkSync = mempty , pncMaxConcurrencyDeadline = mempty - , pncLoggingSwitch = mempty - , pncLogMetrics = mempty - , pncTraceConfig = Last (Just $ PartialTracingOnLegacy defaultPartialTraceConfiguration) , pncTraceForwardSocket = mempty , pncMaybeMempoolCapacityOverride = mempty , pncProtocolIdleTimeout = mempty @@ -243,8 +235,6 @@ testPartialCliConfig = -- | Expected final NodeConfiguration eExpectedConfig :: Either Text NodeConfiguration eExpectedConfig = do - traceOptions <- partialTraceSelectionToEither - (return $ PartialTracingOnLegacy defaultPartialTraceConfiguration) ncRpcConfig <- first fromString $ makeRpcConfig mempty return $ NodeConfiguration { ncSocketConfig = SocketConfig mempty mempty mempty mempty @@ -261,9 +251,6 @@ eExpectedConfig = do , ncEgressPollInterval = 0 , ncMaxConcurrencyBulkSync = Nothing , ncMaxConcurrencyDeadline = Nothing - , ncLoggingSwitch = True - , ncLogMetrics = True - , ncTraceConfig = traceOptions , ncTraceForwardSocket = Nothing , ncMaybeMempoolCapacityOverride = Nothing , ncProtocolIdleTimeout = 5 diff --git a/cardano-node/test/Test/Cardano/Tracing/OrphanInstances/HardFork.hs b/cardano-node/test/Test/Cardano/Tracing/OrphanInstances/HardFork.hs deleted file mode 100644 index 73f0b4fbb7a..00000000000 --- a/cardano-node/test/Test/Cardano/Tracing/OrphanInstances/HardFork.hs +++ /dev/null @@ -1,145 +0,0 @@ --- | Test the JSON encoding of instances in Cardano.Tracing.OrphanInstances.HardFork --- --- The golden files are stored in the path given by 'addPrefix'. --- --- If a new test is added and no golden file exists for it it will be created. --- This new file needs to be committed. --- --- For now we added a couple of representative examples, however the tests are --- not exhaustive. --- --- The examples can be best viewed using a tool like 'jq'. -module Test.Cardano.Tracing.OrphanInstances.HardFork (tests) where - -import Cardano.Protocol.Crypto (StandardCrypto) -import Cardano.Tracing.OrphanInstances.Byron () -import Cardano.Tracing.OrphanInstances.HardFork () -import Cardano.Tracing.OrphanInstances.Shelley () -import Ouroboros.Consensus.Byron.Ledger.NetworkProtocolVersion as Consensus.Cardano -import qualified Ouroboros.Consensus.Cardano.Block as Consensus.Cardano -import qualified Ouroboros.Consensus.HardFork.Combinator.Serialisation.Common as Consensus -import Ouroboros.Consensus.Shelley.Ledger.NetworkProtocolVersion as Consensus.Cardano - -import qualified Data.Aeson as Aeson -import Data.ByteString.Lazy.Char8 (unpack) -import Data.SOP.Strict (NP (Nil, (:*))) - -import Hedgehog (Property) -import qualified Hedgehog as H -import qualified Hedgehog.Extras.Test.Base as H.Base -import qualified Hedgehog.Extras.Test.Golden as H.Golden -import Hedgehog.Internal.Property (PropertyName (PropertyName)) - -tests :: IO Bool -tests = H.checkSequential - $ H.Group "HardForkNodeToClientVersion JSON instances" - $ test - <$> [ ( ntcByronOnly - , "ntcByronOnly.json") - , ( ntc_HFV3_allDisabled - , "ntc_HFV3_allDisabled.json") - , ( ntc_HFV3_ByronV1 - , "ntc_HFV3_ByronV1.json") - , ( ntc_HFV3_ByronV1_ShelleyV8 - , "ntc_HFV3_ByronV1_ShelleyV8.json") - , ( ntc_HFV3_ByronV1_ShelleyV8_ConwayV2 - , "ntc_HFV3_ByronV1_ShelleyV8_ConwayV2.json") - ] - where - test (actualValue, goldenBaseName) = - (PropertyName goldenBaseName, goldenTestJSON actualValue goldenBaseName) - --------------------------------------------------------------------------------- --- Examples --------------------------------------------------------------------------------- - -ntcByronOnly :: - Consensus.HardForkNodeToClientVersion - (Consensus.Cardano.CardanoEras StandardCrypto) -ntcByronOnly = - Consensus.HardForkNodeToClientDisabled - Consensus.Cardano.ByronNodeToClientVersion1 - -ntc_HFV3_allDisabled :: - Consensus.HardForkNodeToClientVersion - (Consensus.Cardano.CardanoEras StandardCrypto) -ntc_HFV3_allDisabled = - Consensus.HardForkNodeToClientEnabled - Consensus.HardForkSpecificNodeToClientVersion3 - ( Consensus.EraNodeToClientDisabled -- Byron - :* Consensus.EraNodeToClientDisabled -- Shelley - :* Consensus.EraNodeToClientDisabled -- Allegra - :* Consensus.EraNodeToClientDisabled -- Mary - :* Consensus.EraNodeToClientDisabled -- Alonzo - :* Consensus.EraNodeToClientDisabled -- Babbage - :* Consensus.EraNodeToClientDisabled -- Conway - :* Consensus.EraNodeToClientDisabled -- Dijkstra - :* Nil - ) - -ntc_HFV3_ByronV1 :: - Consensus.HardForkNodeToClientVersion - (Consensus.Cardano.CardanoEras StandardCrypto) -ntc_HFV3_ByronV1 = - Consensus.HardForkNodeToClientEnabled - Consensus.HardForkSpecificNodeToClientVersion3 - ( Consensus.EraNodeToClientEnabled Consensus.Cardano.ByronNodeToClientVersion1 -- Byron - :* Consensus.EraNodeToClientDisabled -- Shelley - :* Consensus.EraNodeToClientDisabled -- Allegra - :* Consensus.EraNodeToClientDisabled -- Mary - :* Consensus.EraNodeToClientDisabled -- Alonzo - :* Consensus.EraNodeToClientDisabled -- Babbage - :* Consensus.EraNodeToClientDisabled -- Conway - :* Consensus.EraNodeToClientDisabled -- Dijkstra - :* Nil - ) - -ntc_HFV3_ByronV1_ShelleyV8 :: - Consensus.HardForkNodeToClientVersion - (Consensus.Cardano.CardanoEras StandardCrypto) -ntc_HFV3_ByronV1_ShelleyV8 = - Consensus.HardForkNodeToClientEnabled - Consensus.HardForkSpecificNodeToClientVersion3 - ( Consensus.EraNodeToClientEnabled Consensus.Cardano.ByronNodeToClientVersion1 -- Byron - :* Consensus.EraNodeToClientEnabled Consensus.Cardano.ShelleyNodeToClientVersion8 -- Shelley - :* Consensus.EraNodeToClientDisabled -- Allegra - :* Consensus.EraNodeToClientDisabled -- Mary - :* Consensus.EraNodeToClientDisabled -- Alonzo - :* Consensus.EraNodeToClientDisabled -- Babbage - :* Consensus.EraNodeToClientDisabled -- Conway - :* Consensus.EraNodeToClientDisabled -- Dijkstra - :* Nil - ) - -ntc_HFV3_ByronV1_ShelleyV8_ConwayV2 :: - Consensus.HardForkNodeToClientVersion - (Consensus.Cardano.CardanoEras StandardCrypto) -ntc_HFV3_ByronV1_ShelleyV8_ConwayV2 = - Consensus.HardForkNodeToClientEnabled - Consensus.HardForkSpecificNodeToClientVersion3 - ( Consensus.EraNodeToClientEnabled Consensus.Cardano.ByronNodeToClientVersion1 -- Byron - :* Consensus.EraNodeToClientEnabled Consensus.Cardano.ShelleyNodeToClientVersion8 -- Shelley - :* Consensus.EraNodeToClientDisabled -- Allegra - :* Consensus.EraNodeToClientDisabled -- Mary - :* Consensus.EraNodeToClientDisabled -- Alonzo - :* Consensus.EraNodeToClientDisabled -- Babbage - :* Consensus.EraNodeToClientEnabled Consensus.Cardano.ShelleyNodeToClientVersion8 -- Conway - :* Consensus.EraNodeToClientEnabled Consensus.Cardano.ShelleyNodeToClientVersion8 -- Dijkstra - :* Nil - ) - --------------------------------------------------------------------------------- --- Helper functions --------------------------------------------------------------------------------- - -goldenTestJSON :: Aeson.ToJSON a => a -> FilePath -> Property -goldenTestJSON valueToEncode goldenFileBaseName = - H.withTests 1 $ H.withShrinks 0 $ H.property $ do - goldenFp <- H.Base.note $ addPrefix goldenFileBaseName - let actualValue = unpack $ Aeson.encode valueToEncode - H.Golden.diffVsGoldenFile actualValue goldenFp - --- | NB: this function is only used in 'goldenTestJSON' but it is defined at the --- top level so that we can refer to it in the documentation of this module. -addPrefix :: FilePath -> FilePath -addPrefix fname = "test/Test/Cardano/Tracing/OrphanInstances/data/" <> fname diff --git a/cardano-node/test/cardano-node-test.hs b/cardano-node/test/cardano-node-test.hs index 330681215f5..c1f0c3bc943 100644 --- a/cardano-node/test/cardano-node-test.hs +++ b/cardano-node/test/cardano-node-test.hs @@ -13,7 +13,6 @@ import qualified Test.Cardano.Node.FilePermissions #endif import qualified Test.Cardano.Node.Json import qualified Test.Cardano.Node.POM -import qualified Test.Cardano.Tracing.OrphanInstances.HardFork import qualified Test.Cardano.Tracing.NewTracing.Consistency import qualified Cardano.Crypto.Init as Crypto @@ -34,6 +33,5 @@ main = do [ Test.Cardano.Config.Mainnet.tests , Test.Cardano.Node.Json.tests , Test.Cardano.Node.POM.tests - , Test.Cardano.Tracing.OrphanInstances.HardFork.tests , Test.Cardano.Tracing.NewTracing.Consistency.tests ] diff --git a/cardano-testnet/changelog.d/20260527_144649_juergen_remove_iohk_monitoring_tracers.md b/cardano-testnet/changelog.d/20260527_144649_juergen_remove_iohk_monitoring_tracers.md new file mode 100644 index 00000000000..e05586f9264 --- /dev/null +++ b/cardano-testnet/changelog.d/20260527_144649_juergen_remove_iohk_monitoring_tracers.md @@ -0,0 +1,3 @@ +### Maintenance + +- Removed legacy `iohk-monitoring` tracer configuration keys (`TraceBlockFetchClient`, `TraceForge`, etc.) from `defaultYamlHardforkViaConfig`. These keys were only used by the old tracing backend which has been removed. diff --git a/cardano-testnet/src/Testnet/Defaults.hs b/cardano-testnet/src/Testnet/Defaults.hs index a88ddae2d58..ede8071ec5d 100644 --- a/cardano-testnet/src/Testnet/Defaults.hs +++ b/cardano-testnet/src/Testnet/Defaults.hs @@ -67,7 +67,6 @@ import Cardano.Network.Diffusion.Topology (CardanoNetworkTopology) import Cardano.Network.NodeToNode (DiffusionMode (..)) import Cardano.Network.PeerSelection.Bootstrap (UseBootstrapPeers (..)) import Cardano.Network.PeerSelection.PeerTrustable (PeerTrustable (..)) -import Cardano.Tracing.Config import Ouroboros.Network.ConnectionManager.Types (Provenance (..)) import Ouroboros.Network.Diffusion.Topology (LocalRootPeersGroup (..), LocalRootPeersGroups (..), LocalRoots (..), NetworkTopology (..), @@ -83,11 +82,8 @@ import Control.Exception (Exception (..)) import Control.Monad.Identity (Identity) import Data.Aeson (ToJSON (..), Value, (.=)) import qualified Data.Aeson as Aeson -import qualified Data.Aeson.Key as Aeson import qualified Data.Aeson.KeyMap as Aeson -import Data.Bifunctor (bimap) import qualified Data.Default.Class as DefaultClass -import Data.Proxy import Data.Ratio import Data.Scientific import Data.Text (Text) @@ -189,7 +185,6 @@ defaultEra = ShelleyBasedEraConway defaultYamlHardforkViaConfig :: ShelleyBasedEra era -> Aeson.KeyMap Aeson.Value defaultYamlHardforkViaConfig sbe = defaultYamlConfig - <> tracers <> [("TraceOptions", traceOptions)] <> protocolVersions sbe <> hardforkViaConfig sbe @@ -263,46 +258,6 @@ defaultYamlHardforkViaConfig sbe = , ("TestDijkstraHardForkAtEpoch", Aeson.Number 0) ] ) - -- | Various tracers we can turn on or off - tracers :: Aeson.KeyMap Aeson.Value - tracers = Aeson.fromList $ map (bimap Aeson.fromText Aeson.Bool) - [ (proxyName (Proxy @TraceBlockFetchClient), False) - , (proxyName (Proxy @TraceBlockFetchDecisions), False) - , (proxyName (Proxy @TraceBlockFetchProtocol), False) - , (proxyName (Proxy @TraceBlockFetchProtocolSerialised), False) - , (proxyName (Proxy @TraceBlockFetchServer), False) - , (proxyName (Proxy @TraceBlockchainTime), True) - , (proxyName (Proxy @TraceChainDB), True) - , (proxyName (Proxy @TraceChainSyncClient), False) - , (proxyName (Proxy @TraceChainSyncBlockServer), False) - , (proxyName (Proxy @TraceChainSyncHeaderServer), False) - , (proxyName (Proxy @TraceChainSyncProtocol), False) - , (proxyName (Proxy @TraceDnsResolver), True) - , (proxyName (Proxy @TraceDnsSubscription), True) - , (proxyName (Proxy @TraceErrorPolicy), True) - , (proxyName (Proxy @TraceLocalErrorPolicy), True) - , (proxyName (Proxy @TraceForge), True) - , (proxyName (Proxy @TraceHandshake), False) - , (proxyName (Proxy @TraceIpSubscription), True) - , (proxyName (Proxy @TraceLocalRootPeers), True) - , (proxyName (Proxy @TracePublicRootPeers), True) - , (proxyName (Proxy @TracePeerSelection), True) - , (proxyName (Proxy @TracePeerSelectionActions), True) - , (proxyName (Proxy @TraceConnectionManager), True) - , (proxyName (Proxy @TraceServer), True) - , (proxyName (Proxy @TraceLocalConnectionManager), False) - , (proxyName (Proxy @TraceLocalServer), False) - , (proxyName (Proxy @TraceLocalChainSyncProtocol), False) - , (proxyName (Proxy @TraceLocalHandshake), False) - , (proxyName (Proxy @TraceLocalTxSubmissionProtocol), False) - , (proxyName (Proxy @TraceLocalTxSubmissionServer), False) - , (proxyName (Proxy @TraceMempool), True) - , (proxyName (Proxy @TraceMux), False) - , (proxyName (Proxy @TraceTxInbound), False) - , (proxyName (Proxy @TraceTxOutbound), False) - , (proxyName (Proxy @TraceTxSubmissionProtocol), False) - ] - traceOptions = Aeson.Object mempty -- Uncomment this to enable prometheus endpoint on a cardano-testnet. -- N.B. Every testnet node will start trying to listen on PrometheusSimple endpoint diff --git a/cardano-testnet/src/Testnet/Start/Cardano.hs b/cardano-testnet/src/Testnet/Start/Cardano.hs index d6f656cca53..0161e812eb5 100644 --- a/cardano-testnet/src/Testnet/Start/Cardano.hs +++ b/cardano-testnet/src/Testnet/Start/Cardano.hs @@ -41,6 +41,7 @@ import qualified Cardano.Api.Byron as Byron import Cardano.Network.Diffusion.Topology (CardanoNetworkTopology) import Cardano.Node.Configuration.NodeAddress (PortNumber) +import Cardano.Node.Configuration.TopologyP2P () import Cardano.Prelude (NonEmpty ((:|)), canonicalEncodePretty, readMaybe) import Ouroboros.Network.PeerSelection.RelayAccessPoint (RelayAccessPoint (..)) diff --git a/nix/nixos/cardano-node-service.nix b/nix/nixos/cardano-node-service.nix index 86843a617b0..67c8a0f3058 100644 --- a/nix/nixos/cardano-node-service.nix +++ b/nix/nixos/cardano-node-service.nix @@ -96,27 +96,14 @@ let ) cfg.extraNodeConfig; baseInstanceConfig = i: - ( if !cfg.useLegacyTracing - then baseConfig // - { ## XXX: remove once legacy tracing is dropped - minSeverity = "Critical"; - setupScribes = []; - setupBackends = []; - defaultScribes = []; - defaultBackends = []; - options = {}; - } - else baseConfig // - { - UseTraceDispatcher = false; - } // - (optionalAttrs (baseConfig ? hasEKG) { - hasEKG = baseConfig.hasEKG + i; - }) // - (optionalAttrs (baseConfig ? hasPrometheus) { - hasPrometheus = map (n: if isInt n then n + i else n) baseConfig.hasPrometheus; - }) - ) + (baseConfig // + { minSeverity = "Critical"; + setupScribes = []; + setupBackends = []; + defaultScribes = []; + defaultBackends = []; + options = {}; + }) // optionalAttrs (cfg.withUtxoHdLsmt i){ LedgerDB = { Backend = "V2LSM"; @@ -684,7 +671,8 @@ in { type = bool; default = false; description = '' - Use the legacy tracing, based on iohk-monitoring-framework. + Deprecated compatibility option. Legacy tracing has been removed; this + option is still accepted, but has no effect. ''; }; diff --git a/nix/workbench/run.sh b/nix/workbench/run.sh index 9d3935ba1cb..8dbf8324956 100644 --- a/nix/workbench/run.sh +++ b/nix/workbench/run.sh @@ -293,11 +293,7 @@ EOF jq ' .meta.profile_content | .analysis.filters += ["model"] - | .node.tracing_backend = - (if .node.withNewTracing - then "trace-dispatcher" - else "iohk-monitoring" - end) + | .node.tracing_backend = "trace-dispatcher" ' "$dir"/meta.json > "$dir"/profile.json;; compute-path ) diff --git a/nix/workbench/service/tracing.nix b/nix/workbench/service/tracing.nix index 64b60f26b3e..13b2efe23fe 100644 --- a/nix/workbench/service/tracing.nix +++ b/nix/workbench/service/tracing.nix @@ -7,6 +7,11 @@ cfg: with lib; let + selectedTracingBackend = + if tracing_backend == "iohk-monitoring" + then "trace-dispatcher" + else tracing_backend; + trace-dispatcher = recursiveUpdate (removeAttrs (removeLegacyTracingOptions cfg) ["TraceOptionForwarder"]) @@ -115,39 +120,6 @@ let - iohk-monitoring = - recursiveUpdate - (removeAttrs cfg - [ "setupScribes" ]) - { - defaultScribes = [ - [ "StdoutSK" "stdout" ] - ]; - setupScribes = - [{ - scKind = "StdoutSK"; - scName = "stdout"; - scFormat = "ScJson"; - }]; - minSeverity = "Debug"; - TraceMempool = true; - TraceTxInbound = true; - TraceBlockFetchClient = true; - TraceBlockFetchServer = true; - TraceChainSyncHeaderServer = true; - TraceChainSyncClient = true; - TraceGsm = true; - - ## needs to be explicit when new tracing is the node's default - UseTraceDispatcher = false; - - options = { - mapBackends = { - "cardano.node.resources" = [ "KatipBK" ]; - }; - }; - }; - ## ## removeLegacyTracingOptions :: NodeConfig -> NodeConfig ## @@ -220,5 +192,5 @@ let ]; in { - inherit trace-dispatcher iohk-monitoring; -}.${tracing_backend} + inherit trace-dispatcher; +}.${selectedTracingBackend}