From ec27fc83a720c7df3bdf7caba8166597f5cec1a3 Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Fri, 4 Feb 2022 13:03:45 -0400 Subject: [PATCH 1/4] Update proposal comment fix --- cardano-api/src/Cardano/Api/TxBody.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/cardano-api/src/Cardano/Api/TxBody.hs b/cardano-api/src/Cardano/Api/TxBody.hs index ab1eedb7e50..5b0a11d9c2b 100644 --- a/cardano-api/src/Cardano/Api/TxBody.hs +++ b/cardano-api/src/Cardano/Api/TxBody.hs @@ -1293,7 +1293,7 @@ deriving instance Show (TxCertificates build era) -- ---------------------------------------------------------------------------- --- Transaction metadata (era-dependent) +-- Transaction update proposal (era-dependent) -- data TxUpdateProposal era where From cbde4a4cede1e67ff5669bc100b299fb09e1036f Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Fri, 4 Feb 2022 13:04:22 -0400 Subject: [PATCH 2/4] Implement PartialTraceOptions and PartialTraceSelection so we can configure the tracers using the POM model Implement defaultPartialTraceConfiguration --- cardano-node/src/Cardano/Tracing/Config.hs | 643 +++++++++++++++------ cardano-node/test/Test/Cardano/Node/POM.hs | 6 +- 2 files changed, 472 insertions(+), 177 deletions(-) diff --git a/cardano-node/src/Cardano/Tracing/Config.hs b/cardano-node/src/Cardano/Tracing/Config.hs index d144e8c2a91..26e564a1c2a 100644 --- a/cardano-node/src/Cardano/Tracing/Config.hs +++ b/cardano-node/src/Cardano/Tracing/Config.hs @@ -1,14 +1,21 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeApplications #-} module Cardano.Tracing.Config ( TraceOptions (..) , TraceSelection (..) - , traceConfigParser , OnOff (..) + , PartialTraceOptions (..) + , PartialTraceSelection (..) + , partialTraceSelectionToEither + , defaultPartialTraceConfiguration + , lastToEither -- * Trace symbols , TraceConnectionManagerCounters @@ -17,10 +24,11 @@ module Cardano.Tracing.Config ) where import Cardano.Prelude +import Prelude (String) import Data.Aeson -import Data.Aeson.Types (Parser) -import Data.Text (pack) +import qualified Data.Text as Text +import Generic.Data (gmappend) import Cardano.BM.Tracing (TracingVerbosity (..)) import Cardano.Node.Orphans () @@ -32,6 +40,38 @@ data TraceOptions | 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 + (PartialTracingOff, PartialTracingOff) -> PartialTracingOff + + (PartialTracingOnLegacy ptsA, PartialTracingOnLegacy ptsB) -> + PartialTracingOnLegacy (ptsA <> ptsB) + + (PartialTraceDispatcher ptsA, PartialTraceDispatcher ptsB) -> + PartialTraceDispatcher (ptsA <> ptsB) + + (_ , PartialTracingOff) -> PartialTracingOff + + (PartialTracingOff, tracing) -> tracing + + (PartialTracingOnLegacy _, PartialTraceDispatcher pts) -> + PartialTraceDispatcher pts + + (PartialTraceDispatcher _, PartialTracingOnLegacy pts) -> + PartialTracingOnLegacy pts + type TraceAcceptPolicy = ("TraceAcceptPolicy" :: Symbol) type TraceBlockchainTime = ("TraceBlockchainTime" :: Symbol) type TraceBlockFetchClient = ("TraceBlockFetchClient" :: Symbol) @@ -92,8 +132,8 @@ instance FromJSON (OnOff a) where parseJSON (Data.Aeson.Bool b)= return $ OnOff b parseJSON _ = mzero -getName :: forall name. KnownSymbol name => OnOff name -> Text -getName _ = pack (symbolVal (Proxy @name)) +proxyName :: KnownSymbol name => Proxy name -> Text +proxyName p = Text.pack (symbolVal p) data TraceSelection = TraceSelection @@ -156,170 +196,425 @@ data TraceSelection } deriving (Eq, Show) -traceConfigParser :: Object -> (TraceSelection -> TraceOptions) -> Parser TraceOptions -traceConfigParser v ctor = - let acceptPolicy :: OnOff TraceAcceptPolicy - acceptPolicy = OnOff False - blockFetchClient :: OnOff TraceBlockFetchClient - blockFetchClient = OnOff False - blockFetchDecisions :: OnOff TraceBlockFetchDecisions - blockFetchDecisions = OnOff True - blockFetchProtocol :: OnOff TraceBlockFetchProtocol - blockFetchProtocol = OnOff False - blockFetchProtocolSerialised :: OnOff TraceBlockFetchProtocolSerialised - blockFetchProtocolSerialised = OnOff False - blockFetchServer :: OnOff TraceBlockFetchServer - blockFetchServer = OnOff False - blockchainTime :: OnOff TraceBlockchainTime - blockchainTime = OnOff False - chainDB :: OnOff TraceChainDB - chainDB = OnOff True - chainSyncBlockServer :: OnOff TraceChainSyncBlockServer - chainSyncBlockServer = OnOff False - chainSyncClient :: OnOff TraceChainSyncClient - chainSyncClient = OnOff True - chainSyncHeaderServer :: OnOff TraceChainSyncHeaderServer - chainSyncHeaderServer = OnOff False - chainSyncProtocol :: OnOff TraceChainSyncProtocol - chainSyncProtocol = OnOff False - connectionManager :: OnOff TraceConnectionManager - connectionManager = OnOff True - connectionManagerCounters :: OnOff TraceConnectionManagerCounters - connectionManagerCounters = OnOff True - connectionManagerTransitions :: OnOff TraceConnectionManagerTransitions - connectionManagerTransitions = OnOff False - debugPeerSelectionInitiator :: OnOff DebugPeerSelectionInitiator - debugPeerSelectionInitiator = OnOff False - debugPeerSelectionInitiatorResponder :: OnOff DebugPeerSelectionInitiatorResponder - debugPeerSelectionInitiatorResponder = OnOff False - diffusionInitialization :: OnOff TraceDiffusionInitialization - diffusionInitialization = OnOff False - dnsResolver :: OnOff TraceDnsResolver - dnsResolver = OnOff False - dnsSubscription :: OnOff TraceDnsSubscription - dnsSubscription = OnOff True - errorPolicy :: OnOff TraceErrorPolicy - errorPolicy = OnOff True - forge :: OnOff TraceForge - forge = OnOff True - forgeStateInfo :: OnOff TraceForgeStateInfo - forgeStateInfo = OnOff True - handshake :: OnOff TraceHandshake - handshake = OnOff False - inboundGovernor :: OnOff TraceInboundGovernor - inboundGovernor = OnOff True - inboundGovernorCounters :: OnOff TraceInboundGovernorCounters - inboundGovernorCounters = OnOff True - inboundGovernorTransitions :: OnOff TraceInboundGovernorTransitions - inboundGovernorTransitions = OnOff False - ipSubscription :: OnOff TraceIpSubscription - ipSubscription = OnOff True - keepAliveClient :: OnOff TraceKeepAliveClient - keepAliveClient = OnOff False - ledgerPeers :: OnOff TraceLedgerPeers - ledgerPeers = OnOff False - localChainSyncProtocol :: OnOff TraceLocalChainSyncProtocol - localChainSyncProtocol = OnOff False - localConnectionManager :: OnOff TraceLocalConnectionManager - localConnectionManager = OnOff False - localErrorPolicy :: OnOff TraceLocalErrorPolicy - localErrorPolicy = OnOff True - localHandshake :: OnOff TraceLocalHandshake - localHandshake = OnOff False - localInboundGovernor :: OnOff TraceLocalInboundGovernor - localInboundGovernor = OnOff False - localMux :: OnOff TraceLocalMux - localMux = OnOff False - localRootPeers :: OnOff TraceLocalRootPeers - localRootPeers = OnOff False - localServer :: OnOff TraceLocalServer - localServer = OnOff False - localStateQueryProtocol :: OnOff TraceLocalStateQueryProtocol - localStateQueryProtocol = OnOff False - localTxMonitorProtocol :: OnOff TraceLocalTxMonitorProtocol - localTxMonitorProtocol = OnOff False - localTxSubmissionProtocol :: OnOff TraceLocalTxSubmissionProtocol - localTxSubmissionProtocol = OnOff False - localTxSubmissionServer :: OnOff TraceLocalTxSubmissionServer - localTxSubmissionServer = OnOff False - mempool :: OnOff TraceMempool - mempool = OnOff True - mux :: OnOff TraceMux - mux = OnOff True - peerSelection :: OnOff TracePeerSelection - peerSelection = OnOff True - peerSelectionCounters :: OnOff TracePeerSelectionCounters - peerSelectionCounters = OnOff True - peerSelectionActions :: OnOff TracePeerSelectionActions - peerSelectionActions = OnOff True - publicRootPeers :: OnOff TracePublicRootPeers - publicRootPeers = OnOff False - server :: OnOff TraceServer - server = OnOff False - txInbound :: OnOff TraceTxInbound - txInbound = OnOff False - txOutbound :: OnOff TraceTxOutbound - txOutbound = OnOff False - txSubmissionProtocol :: OnOff TraceTxSubmissionProtocol - txSubmissionProtocol = OnOff False - txSubmission2Protocol :: OnOff TraceTxSubmission2Protocol - txSubmission2Protocol = OnOff False in - - ctor <$> (TraceSelection - <$> v .:? "TracingVerbosity" .!= NormalVerbosity + +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) + , 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) + , 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) + , pTraceMux :: Last (OnOff TraceMux) + , pTracePeerSelection :: Last (OnOff TracePeerSelection) + , pTracePeerSelectionCounters :: Last (OnOff TracePeerSelectionCounters) + , pTracePeerSelectionActions :: Last (OnOff TracePeerSelectionActions) + , pTracePublicRootPeers :: Last (OnOff TracePublicRootPeers) + , pTraceServer :: Last (OnOff TraceServer) + , pTraceTxInbound :: Last (OnOff TraceTxInbound) + , pTraceTxOutbound :: Last (OnOff TraceTxOutbound) + , pTraceTxSubmissionProtocol :: Last (OnOff TraceTxSubmissionProtocol) + , pTraceTxSubmission2Protocol :: Last (OnOff TraceTxSubmission2Protocol) + } deriving (Eq, Generic, Show) + + +instance Semigroup PartialTraceSelection where + (<>) = gmappend + +instance FromJSON PartialTraceSelection where + parseJSON = withObject "PartialTraceSelection" $ \v -> do + PartialTraceSelection + <$> Last <$> v .:? "TracingVerbosity" + -- Per-trace toggles, alpha-sorted. + <*> (Last <$> v .:? proxyName (Proxy @TraceAcceptPolicy)) + <*> (Last <$> v .:? proxyName (Proxy @TraceBlockchainTime)) + <*> (Last <$> v .:? proxyName (Proxy @TraceBlockFetchClient)) + <*> (Last <$> v .:? proxyName (Proxy @TraceBlockFetchDecisions)) + <*> (Last <$> v .:? proxyName (Proxy @TraceBlockFetchProtocol)) + <*> (Last <$> v .:? proxyName (Proxy @TraceBlockFetchProtocolSerialised)) + <*> (Last <$> v .:? proxyName (Proxy @TraceBlockFetchServer)) + <*> (Last <$> v .:? proxyName (Proxy @TraceChainDB)) + <*> (Last <$> v .:? proxyName (Proxy @TraceChainSyncBlockServer)) + <*> (Last <$> v .:? proxyName (Proxy @TraceChainSyncClient)) + <*> (Last <$> v .:? proxyName (Proxy @TraceChainSyncHeaderServer)) + <*> (Last <$> v .:? proxyName (Proxy @TraceChainSyncProtocol)) + <*> (Last <$> v .:? proxyName (Proxy @TraceConnectionManager)) + <*> (Last <$> v .:? proxyName (Proxy @TraceConnectionManagerCounters)) + <*> (Last <$> v .:? proxyName (Proxy @TraceConnectionManagerTransitions)) + <*> (Last <$> v .:? proxyName (Proxy @DebugPeerSelectionInitiator)) + <*> (Last <$> v .:? proxyName (Proxy @DebugPeerSelectionInitiatorResponder)) + <*> (Last <$> v .:? proxyName (Proxy @TraceDiffusionInitialization)) + <*> (Last <$> v .:? proxyName (Proxy @TraceDnsResolver)) + <*> (Last <$> v .:? proxyName (Proxy @TraceDnsSubscription)) + <*> (Last <$> v .:? proxyName (Proxy @TraceErrorPolicy)) + <*> (Last <$> v .:? proxyName (Proxy @TraceForge)) + <*> (Last <$> v .:? proxyName (Proxy @TraceForgeStateInfo)) + <*> (Last <$> v .:? proxyName (Proxy @TraceHandshake)) + <*> (Last <$> v .:? proxyName (Proxy @TraceIpSubscription)) + <*> (Last <$> v .:? proxyName (Proxy @TraceKeepAliveClient)) + <*> (Last <$> v .:? proxyName (Proxy @TraceInboundGovernorTransitions)) + <*> (Last <$> v .:? proxyName (Proxy @TraceLedgerPeers)) + <*> (Last <$> v .:? proxyName (Proxy @TraceLocalChainSyncProtocol)) + <*> (Last <$> v .:? proxyName (Proxy @TraceLocalConnectionManager)) + <*> (Last <$> v .:? proxyName (Proxy @TraceLocalErrorPolicy)) + <*> (Last <$> v .:? proxyName (Proxy @TraceLocalHandshake)) + <*> (Last <$> v .:? proxyName (Proxy @TraceLocalInboundGovernor)) + <*> (Last <$> v .:? proxyName (Proxy @TraceLocalRootPeers)) + <*> (Last <$> v .:? proxyName (Proxy @TraceLocalServer)) + <*> (Last <$> v .:? proxyName (Proxy @TraceLocalStateQueryProtocol)) + <*> (Last <$> v .:? proxyName (Proxy @TraceLocalTxMonitorProtocol)) + <*> (Last <$> v .:? proxyName (Proxy @TraceLocalTxSubmissionProtocol)) + <*> (Last <$> v .:? proxyName (Proxy @TraceLocalTxSubmissionServer)) + <*> (Last <$> v .:? proxyName (Proxy @TraceMempool)) + <*> (Last <$> v .:? proxyName (Proxy @TraceMux)) + <*> (Last <$> v .:? proxyName (Proxy @TraceLocalMux)) + <*> (Last <$> v .:? proxyName (Proxy @TracePeerSelection)) + <*> (Last <$> v .:? proxyName (Proxy @TracePeerSelectionCounters)) + <*> (Last <$> v .:? proxyName (Proxy @TracePeerSelectionActions)) + <*> (Last <$> v .:? proxyName (Proxy @TracePublicRootPeers)) + <*> (Last <$> v .:? proxyName (Proxy @TraceServer)) + <*> (Last <$> v .:? proxyName (Proxy @TraceInboundGovernor)) + <*> (Last <$> v .:? proxyName (Proxy @TraceInboundGovernorCounters)) + <*> (Last <$> v .:? proxyName (Proxy @TraceTxInbound)) + <*> (Last <$> v .:? proxyName (Proxy @TraceTxOutbound)) + <*> (Last <$> v .:? proxyName (Proxy @TraceTxSubmissionProtocol)) + <*> (Last <$> v .:? proxyName (Proxy @TraceTxSubmission2Protocol)) + + +defaultPartialTraceConfiguration :: PartialTraceSelection +defaultPartialTraceConfiguration = + PartialTraceSelection + { pTraceVerbosity = Last Nothing -- Per-trace toggles, alpha-sorted. - <*> v .:? getName acceptPolicy .!= acceptPolicy - <*> v .:? getName blockFetchClient .!= blockFetchClient - <*> v .:? getName blockFetchDecisions .!= blockFetchDecisions - <*> v .:? getName blockFetchProtocol .!= blockFetchProtocol - <*> v .:? getName blockFetchProtocolSerialised .!= blockFetchProtocolSerialised - <*> v .:? getName blockFetchServer .!= blockFetchServer - <*> v .:? getName blockchainTime .!= blockchainTime - <*> v .:? getName chainDB .!= chainDB - <*> v .:? getName chainSyncBlockServer .!= chainSyncBlockServer - <*> v .:? getName chainSyncClient .!= chainSyncClient - <*> v .:? getName chainSyncHeaderServer .!= chainSyncHeaderServer - <*> v .:? getName chainSyncProtocol .!= chainSyncProtocol - <*> v .:? getName connectionManager .!= connectionManager - <*> v .:? getName connectionManagerCounters .!= connectionManagerCounters - <*> v .:? getName connectionManagerTransitions .!= connectionManagerTransitions - <*> v .:? getName debugPeerSelectionInitiator - .!= debugPeerSelectionInitiator - <*> v .:? getName debugPeerSelectionInitiatorResponder - .!= debugPeerSelectionInitiatorResponder - <*> v .:? getName diffusionInitialization .!= diffusionInitialization - <*> v .:? getName dnsResolver .!= dnsResolver - <*> v .:? getName dnsSubscription .!= dnsSubscription - <*> v .:? getName errorPolicy .!= errorPolicy - <*> v .:? getName forge .!= forge - <*> v .:? getName forgeStateInfo .!= forgeStateInfo - <*> v .:? getName handshake .!= handshake - <*> v .:? getName inboundGovernor .!= inboundGovernor - <*> v .:? getName inboundGovernorCounters .!= inboundGovernorCounters - <*> v .:? getName inboundGovernorTransitions .!= inboundGovernorTransitions - <*> v .:? getName ipSubscription .!= ipSubscription - <*> v .:? getName keepAliveClient .!= keepAliveClient - <*> v .:? getName ledgerPeers .!= ledgerPeers - <*> v .:? getName localChainSyncProtocol .!= localChainSyncProtocol - <*> v .:? getName localConnectionManager .!= localConnectionManager - <*> v .:? getName localErrorPolicy .!= localErrorPolicy - <*> v .:? getName localHandshake .!= localHandshake - <*> v .:? getName localInboundGovernor .!= localInboundGovernor - <*> v .:? getName localMux .!= localMux - <*> v .:? getName localRootPeers .!= localRootPeers - <*> v .:? getName localServer .!= localServer - <*> v .:? getName localStateQueryProtocol .!= localStateQueryProtocol - <*> v .:? getName localTxMonitorProtocol .!= localTxMonitorProtocol - <*> v .:? getName localTxSubmissionProtocol .!= localTxSubmissionProtocol - <*> v .:? getName localTxSubmissionServer .!= localTxSubmissionServer - <*> v .:? getName mempool .!= mempool - <*> v .:? getName mux .!= mux - <*> v .:? getName peerSelection .!= peerSelection - <*> v .:? getName peerSelectionCounters .!= peerSelectionCounters - <*> v .:? getName peerSelectionActions .!= peerSelectionActions - <*> v .:? getName publicRootPeers .!= publicRootPeers - <*> v .:? getName server .!= server - <*> v .:? getName txInbound .!= txInbound - <*> v .:? getName txOutbound .!= txOutbound - <*> v .:? getName txSubmissionProtocol .!= txSubmissionProtocol - <*> v .:? getName txSubmission2Protocol .!= txSubmission2Protocol) + , 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 False + , 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 + , pTraceHandshake = pure $ OnOff False + , pTraceInboundGovernor = pure $ OnOff False + , 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 False + , pTraceLocalErrorPolicy = pure $ OnOff True + , pTraceLocalHandshake = pure $ OnOff False + , pTraceLocalInboundGovernor = pure $ OnOff False + , pTraceLocalMux = pure $ OnOff False + , pTraceLocalTxMonitorProtocol = pure $ OnOff False + , pTraceLocalRootPeers = pure $ OnOff False + , pTraceLocalServer = pure $ OnOff False + , pTraceLocalStateQueryProtocol = pure $ OnOff False + , pTraceLocalTxSubmissionProtocol = pure $ OnOff False + , pTraceLocalTxSubmissionServer = pure $ OnOff False + , pTraceMempool = pure $ OnOff True + , pTraceMux = pure $ OnOff True + , pTracePeerSelection = pure $ OnOff False + , pTracePeerSelectionCounters = pure $ OnOff True + , pTracePeerSelectionActions = pure $ OnOff False + , pTracePublicRootPeers = pure $ OnOff False + , pTraceServer = pure $ OnOff False + , pTraceTxInbound = pure $ OnOff False + , pTraceTxOutbound = pure $ OnOff False + , pTraceTxSubmissionProtocol = pure $ OnOff False + , pTraceTxSubmission2Protocol = pure $ OnOff False + } + + +partialTraceSelectionToEither :: PartialTraceOptions -> Either Text TraceOptions +partialTraceSelectionToEither PartialTracingOff = Right TracingOff +partialTraceSelectionToEither (PartialTraceDispatcher pTraceSelection) = do + let PartialTraceSelection {..} = defaultPartialTraceConfiguration <> pTraceSelection + traceVerbosity <- first Text.pack $ lastToEither "Default value not specified for TracingVerbosity" pTraceVerbosity + traceAcceptPolicy <- proxyLastToEither (Proxy @TraceAcceptPolicy) pTraceAcceptPolicy + traceBlockFetchClient <- proxyLastToEither (Proxy @TraceBlockchainTime) pTraceBlockFetchClient + traceBlockFetchDecisions <- proxyLastToEither (Proxy @TraceBlockFetchClient) pTraceBlockFetchDecisions + traceBlockFetchProtocol <- proxyLastToEither (Proxy @TraceBlockFetchDecisions) pTraceBlockFetchProtocol + traceBlockFetchProtocolSerialised <- proxyLastToEither (Proxy @TraceBlockFetchProtocol) pTraceBlockFetchProtocolSerialised + traceBlockFetchServer <- proxyLastToEither (Proxy @TraceBlockFetchProtocolSerialised) pTraceBlockFetchServer + traceBlockchainTime <- proxyLastToEither (Proxy @TraceBlockFetchServer) pTraceBlockchainTime + traceChainDB <- proxyLastToEither (Proxy @TraceChainDB) pTraceChainDB + traceChainSyncBlockServer <- proxyLastToEither (Proxy @TraceChainSyncClient) pTraceChainSyncBlockServer + traceChainSyncClient <- proxyLastToEither (Proxy @TraceChainSyncBlockServer) 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 + traceHandshake <- proxyLastToEither (Proxy @TraceHandshake) pTraceHandshake + traceInboundGovernor <- proxyLastToEither (Proxy @TraceIpSubscription) pTraceInboundGovernor + traceInboundGovernorCounters <- proxyLastToEither (Proxy @TraceKeepAliveClient) pTraceInboundGovernorCounters + traceInboundGovernorTransitions <- proxyLastToEither (Proxy @TraceInboundGovernorTransitions) pTraceInboundGovernorTransitions + traceIpSubscription <- proxyLastToEither (Proxy @TraceLedgerPeers) pTraceIpSubscription + traceKeepAliveClient <- proxyLastToEither (Proxy @TraceLocalChainSyncProtocol) pTraceKeepAliveClient + traceLedgerPeers <- proxyLastToEither (Proxy @TraceLocalConnectionManager) pTraceLedgerPeers + traceLocalChainSyncProtocol <- proxyLastToEither (Proxy @TraceLocalErrorPolicy) pTraceLocalChainSyncProtocol + traceLocalConnectionManager <- proxyLastToEither (Proxy @TraceLocalHandshake) pTraceLocalConnectionManager + traceLocalErrorPolicy <- proxyLastToEither (Proxy @TraceLocalInboundGovernor) pTraceLocalErrorPolicy + traceLocalHandshake <- proxyLastToEither (Proxy @TraceLocalRootPeers) pTraceLocalHandshake + traceLocalInboundGovernor <- proxyLastToEither (Proxy @TraceLocalServer) pTraceLocalInboundGovernor + traceLocalMux <- proxyLastToEither (Proxy @TraceLocalStateQueryProtocol) pTraceLocalMux + traceLocalTxMonitorProtocol <- proxyLastToEither (Proxy @TraceLocalTxMonitorProtocol) pTraceLocalTxMonitorProtocol + traceLocalRootPeers <- proxyLastToEither (Proxy @TraceLocalTxSubmissionProtocol) pTraceLocalRootPeers + traceLocalServer <- proxyLastToEither (Proxy @TraceLocalTxSubmissionServer) pTraceLocalServer + traceLocalStateQueryProtocol <- proxyLastToEither (Proxy @TraceMempool) pTraceLocalStateQueryProtocol + traceLocalTxSubmissionProtocol <- proxyLastToEither (Proxy @TraceMux) pTraceLocalTxSubmissionProtocol + traceLocalTxSubmissionServer <- proxyLastToEither (Proxy @TraceLocalMux) pTraceLocalTxSubmissionServer + traceMempool <- proxyLastToEither (Proxy @TracePeerSelection) pTraceMempool + traceMux <- proxyLastToEither (Proxy @TracePeerSelectionCounters) pTraceMux + tracePeerSelection <- proxyLastToEither (Proxy @TracePeerSelectionActions) pTracePeerSelection + tracePeerSelectionCounters <- proxyLastToEither (Proxy @TracePublicRootPeers) pTracePeerSelectionCounters + tracePeerSelectionActions <- proxyLastToEither (Proxy @TraceServer) pTracePeerSelectionActions + tracePublicRootPeers <- proxyLastToEither (Proxy @TraceInboundGovernor) pTracePublicRootPeers + traceServer <- proxyLastToEither (Proxy @TraceInboundGovernorCounters) pTraceServer + traceTxInbound <- proxyLastToEither (Proxy @TraceTxInbound) pTraceTxInbound + traceTxOutbound <- proxyLastToEither (Proxy @TraceTxOutbound) pTraceTxOutbound + traceTxSubmissionProtocol <- proxyLastToEither (Proxy @TraceTxSubmissionProtocol) pTraceTxSubmissionProtocol + traceTxSubmission2Protocol <- proxyLastToEither (Proxy @TraceTxSubmission2Protocol) pTraceTxSubmission2Protocol + Right $ TracingOnLegacy $ TraceSelection + { traceVerbosity + , traceAcceptPolicy + , traceBlockFetchClient + , traceBlockFetchDecisions + , traceBlockFetchProtocol + , traceBlockFetchProtocolSerialised + , traceBlockFetchServer + , traceBlockchainTime + , traceChainDB + , traceChainSyncBlockServer + , traceChainSyncClient + , traceChainSyncHeaderServer + , traceChainSyncProtocol + , traceConnectionManager + , traceConnectionManagerCounters + , traceConnectionManagerTransitions + , traceDebugPeerSelectionInitiatorTracer + , traceDebugPeerSelectionInitiatorResponderTracer + , traceDiffusionInitialization + , traceDnsResolver + , traceDnsSubscription + , traceErrorPolicy + , traceForge + , traceForgeStateInfo + , traceHandshake + , traceInboundGovernor + , traceInboundGovernorCounters + , traceInboundGovernorTransitions + , traceIpSubscription + , traceKeepAliveClient + , traceLedgerPeers + , traceLocalChainSyncProtocol + , traceLocalConnectionManager + , traceLocalErrorPolicy + , traceLocalHandshake + , traceLocalInboundGovernor + , traceLocalMux + , traceLocalTxMonitorProtocol + , traceLocalRootPeers + , traceLocalServer + , traceLocalStateQueryProtocol + , traceLocalTxSubmissionProtocol + , traceLocalTxSubmissionServer + , traceMempool + , traceMux + , tracePeerSelection + , tracePeerSelectionCounters + , tracePeerSelectionActions + , tracePublicRootPeers + , traceServer + , traceTxInbound + , traceTxOutbound + , traceTxSubmissionProtocol + , traceTxSubmission2Protocol + } + +partialTraceSelectionToEither (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 + traceBlockFetchClient <- proxyLastToEither (Proxy @TraceBlockchainTime) pTraceBlockFetchClient + traceBlockFetchDecisions <- proxyLastToEither (Proxy @TraceBlockFetchClient) pTraceBlockFetchDecisions + traceBlockFetchProtocol <- proxyLastToEither (Proxy @TraceBlockFetchDecisions) pTraceBlockFetchProtocol + traceBlockFetchProtocolSerialised <- proxyLastToEither (Proxy @TraceBlockFetchProtocol) pTraceBlockFetchProtocolSerialised + traceBlockFetchServer <- proxyLastToEither (Proxy @TraceBlockFetchProtocolSerialised) pTraceBlockFetchServer + traceBlockchainTime <- proxyLastToEither (Proxy @TraceBlockFetchServer) pTraceBlockchainTime + traceChainDB <- proxyLastToEither (Proxy @TraceChainDB) pTraceChainDB + traceChainSyncBlockServer <- proxyLastToEither (Proxy @TraceChainSyncClient) pTraceChainSyncBlockServer + traceChainSyncClient <- proxyLastToEither (Proxy @TraceChainSyncBlockServer) 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 + traceHandshake <- proxyLastToEither (Proxy @TraceHandshake) pTraceHandshake + traceInboundGovernor <- proxyLastToEither (Proxy @TraceIpSubscription) pTraceInboundGovernor + traceInboundGovernorCounters <- proxyLastToEither (Proxy @TraceKeepAliveClient) pTraceInboundGovernorCounters + traceInboundGovernorTransitions <- proxyLastToEither (Proxy @TraceInboundGovernorTransitions) pTraceInboundGovernorTransitions + traceIpSubscription <- proxyLastToEither (Proxy @TraceLedgerPeers) pTraceIpSubscription + traceKeepAliveClient <- proxyLastToEither (Proxy @TraceLocalChainSyncProtocol) pTraceKeepAliveClient + traceLedgerPeers <- proxyLastToEither (Proxy @TraceLocalConnectionManager) pTraceLedgerPeers + traceLocalChainSyncProtocol <- proxyLastToEither (Proxy @TraceLocalErrorPolicy) pTraceLocalChainSyncProtocol + traceLocalConnectionManager <- proxyLastToEither (Proxy @TraceLocalHandshake) pTraceLocalConnectionManager + traceLocalErrorPolicy <- proxyLastToEither (Proxy @TraceLocalInboundGovernor) pTraceLocalErrorPolicy + traceLocalHandshake <- proxyLastToEither (Proxy @TraceLocalRootPeers) pTraceLocalHandshake + traceLocalInboundGovernor <- proxyLastToEither (Proxy @TraceLocalServer) pTraceLocalInboundGovernor + traceLocalMux <- proxyLastToEither (Proxy @TraceLocalStateQueryProtocol) pTraceLocalMux + traceLocalRootPeers <- proxyLastToEither (Proxy @TraceLocalTxSubmissionProtocol) pTraceLocalRootPeers + traceLocalServer <- proxyLastToEither (Proxy @TraceLocalTxSubmissionServer) pTraceLocalServer + traceLocalTxMonitorProtocol <- proxyLastToEither (Proxy @TraceLocalTxMonitorProtocol) pTraceLocalTxMonitorProtocol + traceLocalStateQueryProtocol <- proxyLastToEither (Proxy @TraceMempool) pTraceLocalStateQueryProtocol + traceLocalTxSubmissionProtocol <- proxyLastToEither (Proxy @TraceMux) pTraceLocalTxSubmissionProtocol + traceLocalTxSubmissionServer <- proxyLastToEither (Proxy @TraceLocalMux) pTraceLocalTxSubmissionServer + traceMempool <- proxyLastToEither (Proxy @TracePeerSelection) pTraceMempool + traceMux <- proxyLastToEither (Proxy @TracePeerSelectionCounters) pTraceMux + tracePeerSelection <- proxyLastToEither (Proxy @TracePeerSelectionActions) pTracePeerSelection + tracePeerSelectionCounters <- proxyLastToEither (Proxy @TracePublicRootPeers) pTracePeerSelectionCounters + tracePeerSelectionActions <- proxyLastToEither (Proxy @TraceServer) pTracePeerSelectionActions + tracePublicRootPeers <- proxyLastToEither (Proxy @TraceInboundGovernor) pTracePublicRootPeers + traceServer <- proxyLastToEither (Proxy @TraceInboundGovernorCounters) pTraceServer + traceTxInbound <- proxyLastToEither (Proxy @TraceTxInbound) pTraceTxInbound + traceTxOutbound <- proxyLastToEither (Proxy @TraceTxOutbound) pTraceTxOutbound + traceTxSubmissionProtocol <- proxyLastToEither (Proxy @TraceTxSubmissionProtocol) pTraceTxSubmissionProtocol + traceTxSubmission2Protocol <- proxyLastToEither (Proxy @TraceTxSubmission2Protocol) pTraceTxSubmission2Protocol + Right $ TracingOnLegacy $ TraceSelection + { traceVerbosity + , traceAcceptPolicy + , traceBlockFetchClient + , traceBlockFetchDecisions + , traceBlockFetchProtocol + , traceBlockFetchProtocolSerialised + , traceBlockFetchServer + , traceBlockchainTime + , traceChainDB + , traceChainSyncBlockServer + , traceChainSyncClient + , traceChainSyncHeaderServer + , traceChainSyncProtocol + , traceConnectionManager + , traceConnectionManagerCounters + , traceConnectionManagerTransitions + , traceDebugPeerSelectionInitiatorTracer + , traceDebugPeerSelectionInitiatorResponderTracer + , traceDiffusionInitialization + , traceDnsResolver + , traceDnsSubscription + , traceErrorPolicy + , traceForge + , traceForgeStateInfo + , traceHandshake + , traceInboundGovernor + , traceInboundGovernorCounters + , traceInboundGovernorTransitions + , traceIpSubscription + , traceKeepAliveClient + , traceLedgerPeers + , traceLocalChainSyncProtocol + , traceLocalConnectionManager + , traceLocalErrorPolicy + , traceLocalHandshake + , traceLocalInboundGovernor + , traceLocalMux + , traceLocalRootPeers + , traceLocalServer + , traceLocalStateQueryProtocol + , traceLocalTxMonitorProtocol + , traceLocalTxSubmissionProtocol + , traceLocalTxSubmissionServer + , traceMempool + , traceMux + , tracePeerSelection + , tracePeerSelectionCounters + , tracePeerSelectionActions + , tracePublicRootPeers + , traceServer + , traceTxInbound + , traceTxOutbound + , traceTxSubmissionProtocol + , traceTxSubmission2Protocol + } + +proxyLastToEither :: KnownSymbol name => Proxy name -> Last a -> Either Text a +proxyLastToEither name (Last x) = + maybe (Left $ "Default value not specified for " <> proxyName name) Right x + +lastToEither :: String -> Last a -> Either String a +lastToEither errMsg (Last x) = maybe (Left errMsg) Right x + diff --git a/cardano-node/test/Test/Cardano/Node/POM.hs b/cardano-node/test/Test/Cardano/Node/POM.hs index 6cf74354b4d..3656a2227f3 100644 --- a/cardano-node/test/Test/Cardano/Node/POM.hs +++ b/cardano-node/test/Test/Cardano/Node/POM.hs @@ -13,7 +13,7 @@ import Cardano.Node.Configuration.POM import Cardano.Node.Configuration.Socket import Cardano.Node.Handlers.Shutdown import Cardano.Node.Types -import Cardano.Tracing.Config (TraceOptions (..)) +import Cardano.Tracing.Config (PartialTraceOptions (..), TraceOptions (..)) import qualified Ouroboros.Consensus.Node as Consensus (NetworkP2PMode (..)) import Ouroboros.Consensus.Storage.LedgerDB.DiskPolicy (SnapshotInterval (..)) import Ouroboros.Network.Block (MaxSlotNo (..), SlotNo (..)) @@ -59,7 +59,7 @@ testPartialYamlConfig = , pncMaxConcurrencyDeadline = Last Nothing , pncLoggingSwitch = Last $ Just True , pncLogMetrics = Last $ Just True - , pncTraceConfig = Last $ Just TracingOff + , pncTraceConfig = PartialTracingOff , pncConfigFile = mempty , pncTopologyFile = mempty , pncDatabaseFile = mempty @@ -96,7 +96,7 @@ testPartialCliConfig = , pncMaxConcurrencyDeadline = mempty , pncLoggingSwitch = mempty , pncLogMetrics = mempty - , pncTraceConfig = mempty + , pncTraceConfig = PartialTracingOff , pncMaybeMempoolCapacityOverride = mempty , pncProtocolIdleTimeout = mempty , pncTimeWaitTimeout = mempty From 4ad6cddd40517c2eb8c3df144a6fa6737952aa92 Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Fri, 4 Feb 2022 13:05:12 -0400 Subject: [PATCH 3/4] Propagate PartialTraceOptions to cardano-node --- .../src/Cardano/Node/Configuration/POM.hs | 22 +- cardano-node/src/Cardano/Node/Run.hs | 38 ++- cardano-node/src/Cardano/Tracing/Config.hs | 280 +++++++++--------- cardano-node/test/Test/Cardano/Node/POM.hs | 20 +- 4 files changed, 175 insertions(+), 185 deletions(-) diff --git a/cardano-node/src/Cardano/Node/Configuration/POM.hs b/cardano-node/src/Cardano/Node/Configuration/POM.hs index 050c58cba6e..afd84e17688 100644 --- a/cardano-node/src/Cardano/Node/Configuration/POM.hs +++ b/cardano-node/src/Cardano/Node/Configuration/POM.hs @@ -28,6 +28,7 @@ import Prelude (String) import Control.Monad (fail) import Data.Aeson import qualified Data.Aeson.Types as Aeson +import qualified Data.Text as Text import Data.Time.Clock (DiffTime) import Data.Yaml (decodeFileThrow) import Generic.Data (gmappend) @@ -166,7 +167,7 @@ data PartialNodeConfiguration -- Logging parameters: , pncLoggingSwitch :: !(Last Bool) , pncLogMetrics :: !(Last Bool) - , pncTraceConfig :: !(Last TraceOptions) + , pncTraceConfig :: !(Last PartialTraceOptions) -- Configuration for testing purposes , pncMaybeMempoolCapacityOverride :: !(Last MempoolCapacityBytesOverride) @@ -218,13 +219,13 @@ instance FromJSON PartialNodeConfiguration where pncLoggingSwitch' <- v .:? "TurnOnLogging" .!= True pncLogMetrics <- Last <$> v .:? "TurnOnLogMetrics" useTraceDispatcher <- v .:? "UseTraceDispatcher" .!= False - pncTraceConfig <- Last . Just <$> if pncLoggingSwitch' - then - traceConfigParser v - (if useTraceDispatcher - then TraceDispatcher - else TracingOnLegacy) - else pure TracingOff + pncTraceConfig <- if pncLoggingSwitch' + then do + partialTraceSelection <- parseJSON $ Object v + if useTraceDispatcher + then Last . Just <$> return (PartialTraceDispatcher partialTraceSelection) + else Last . Just <$> return (PartialTracingOnLegacy partialTraceSelection) + else Last . Just <$> return PartialTracingOff -- Protocol parameters protocol <- v .:? "Protocol" .!= ByronProtocol @@ -442,9 +443,6 @@ defaultPartialNodeConfiguration = lastOption :: Parser a -> Parser (Last a) lastOption = fmap Last . optional -lastToEither :: String -> Last a -> Either String a -lastToEither errMsg (Last x) = maybe (Left errMsg) Right x - makeNodeConfiguration :: PartialNodeConfiguration -> Either String NodeConfiguration makeNodeConfiguration pnc = do configFile <- lastToEither "Missing YAML config file" $ pncConfigFile pnc @@ -455,7 +453,7 @@ makeNodeConfiguration pnc = do protocolConfig <- lastToEither "Missing ProtocolConfig" $ pncProtocolConfig pnc loggingSwitch <- lastToEither "Missing LoggingSwitch" $ pncLoggingSwitch pnc logMetrics <- lastToEither "Missing LogMetrics" $ pncLogMetrics pnc - traceConfig <- lastToEither "Missing TraceConfig" $ pncTraceConfig pnc + traceConfig <- first Text.unpack $ partialTraceSelectionToEither $ pncTraceConfig pnc diffusionMode <- lastToEither "Missing DiffusionMode" $ pncDiffusionMode pnc snapshotInterval <- lastToEither "Missing SnapshotInterval" $ pncSnapshotInterval pnc shutdownConfig <- lastToEither "Missing ShutdownConfig" $ pncShutdownConfig pnc diff --git a/cardano-node/src/Cardano/Node/Run.hs b/cardano-node/src/Cardano/Node/Run.hs index e93c0cc0997..80c29e5227e 100644 --- a/cardano-node/src/Cardano/Node/Run.hs +++ b/cardano-node/src/Cardano/Node/Run.hs @@ -1,13 +1,13 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE PackageImports #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PackageImports #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} #if !defined(mingw32_HOST_OS) #define UNIX @@ -18,9 +18,9 @@ module Cardano.Node.Run , checkVRFFilePermissions ) where -import Cardano.Prelude hiding (ByteString, STM, atomically, take, trace) -import Prelude (String, error, id) +import Cardano.Prelude hiding (ByteString, STM, atomically, putStrLn, show, take, trace) import Data.IP (toSockAddr) +import Prelude (String, error, id, putStrLn, show) import qualified Control.Concurrent.Async as Async import Control.Monad.Class.MonadSTM.Strict @@ -34,8 +34,7 @@ import Data.Time.Clock (getCurrentTime) import Data.Version (showVersion) import Network.HostName (getHostName) import Network.Socket (Socket) -import System.Directory (canonicalizePath, createDirectoryIfMissing, - makeAbsolute) +import System.Directory (canonicalizePath, createDirectoryIfMissing, makeAbsolute) import System.Environment (lookupEnv) #ifdef UNIX @@ -55,19 +54,18 @@ import qualified Cardano.Crypto.Libsodium as Crypto import Cardano.Node.Configuration.Logging (LoggingLayer (..), createLoggingLayer, shutdownLoggingLayer) +import Cardano.Node.Configuration.NodeAddress import Cardano.Node.Configuration.POM (NodeConfiguration (..), PartialNodeConfiguration (..), SomeNetworkP2PMode (..), defaultPartialNodeConfiguration, makeNodeConfiguration, parseNodeConfigurationFP) -import Cardano.Node.Configuration.NodeAddress import Cardano.Node.Startup -import Cardano.Node.Types import Cardano.Node.Tracing.API import Cardano.Node.Tracing.Tracers.Startup (getStartupInfo) +import Cardano.Node.Types import Cardano.Tracing.Config (TraceOptions (..), TraceSelection (..)) import qualified Ouroboros.Consensus.Config as Consensus -import Ouroboros.Consensus.Config.SupportsNode - (ConfigSupportsNode (..)) +import Ouroboros.Consensus.Config.SupportsNode (ConfigSupportsNode (..)) import Ouroboros.Consensus.Node (NetworkP2PMode (..), RunNode, RunNodeArgs (..), StdRunNodeArgs (..)) import qualified Ouroboros.Consensus.Node as Node (getChainDB, run) @@ -96,8 +94,8 @@ import qualified Cardano.Node.Configuration.TopologyP2P as TopologyP2P import Cardano.Node.Handlers.Shutdown import Cardano.Node.Protocol (mkConsensusProtocol) import Cardano.Node.Protocol.Types -import Cardano.Node.TraceConstraints (TraceConstraints) import Cardano.Node.Queries +import Cardano.Node.TraceConstraints (TraceConstraints) import Cardano.Tracing.Peer import Cardano.Tracing.Tracers @@ -116,7 +114,7 @@ runNode cmdPc = do Left err -> panic $ "Error in creating the NodeConfiguration: " <> Text.pack err Right nc' -> return nc' - putStrLn $ "Node configuration: " <> show @_ @Text nc + putStrLn $ "Node configuration: " <> show nc case shelleyVRFFile $ ncProtocolFiles nc of Just vrfFp -> do vrf <- runExceptT $ checkVRFFilePermissions vrfFp @@ -181,7 +179,7 @@ handleNodeWithTracers cmdPc nc p networkMagic runP = do p loggingLayer <- case eLoggingLayer of - Left err -> putTextLn (show err) >> exitFailure + Left err -> putTextLn (Text.pack $ show err) >> exitFailure Right res -> return res !trace <- setupTrace loggingLayer let tracer = contramap pack $ toLogObject trace diff --git a/cardano-node/src/Cardano/Tracing/Config.hs b/cardano-node/src/Cardano/Tracing/Config.hs index 26e564a1c2a..c6bb2bf1e51 100644 --- a/cardano-node/src/Cardano/Tracing/Config.hs +++ b/cardano-node/src/Cardano/Tracing/Config.hs @@ -1,7 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE KindSignatures #-} -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -54,23 +53,13 @@ instance Semigroup PartialTraceOptions where tracingA <> tracingB = case (tracingA, tracingB) of - (PartialTracingOff, PartialTracingOff) -> PartialTracingOff - (PartialTracingOnLegacy ptsA, PartialTracingOnLegacy ptsB) -> PartialTracingOnLegacy (ptsA <> ptsB) (PartialTraceDispatcher ptsA, PartialTraceDispatcher ptsB) -> PartialTraceDispatcher (ptsA <> ptsB) - (_ , PartialTracingOff) -> PartialTracingOff - - (PartialTracingOff, tracing) -> tracing - - (PartialTracingOnLegacy _, PartialTraceDispatcher pts) -> - PartialTraceDispatcher pts - - (PartialTraceDispatcher _, PartialTracingOnLegacy pts) -> - PartialTracingOnLegacy pts + (_, tracing) -> tracing type TraceAcceptPolicy = ("TraceAcceptPolicy" :: Symbol) type TraceBlockchainTime = ("TraceBlockchainTime" :: Symbol) @@ -324,7 +313,7 @@ instance FromJSON PartialTraceSelection where defaultPartialTraceConfiguration :: PartialTraceSelection defaultPartialTraceConfiguration = PartialTraceSelection - { pTraceVerbosity = Last Nothing + { pTraceVerbosity = Last $ Just NormalVerbosity -- Per-trace toggles, alpha-sorted. , pTraceAcceptPolicy = pure $ OnOff False , pTraceBlockchainTime = pure $ OnOff False @@ -338,7 +327,7 @@ defaultPartialTraceConfiguration = , pTraceChainSyncClient = pure $ OnOff True , pTraceChainSyncHeaderServer = pure $ OnOff False , pTraceChainSyncProtocol = pure $ OnOff False - , pTraceConnectionManager = pure $ OnOff False + , pTraceConnectionManager = pure $ OnOff True , pTraceConnectionManagerCounters = pure $ OnOff True , pTraceConnectionManagerTransitions = pure $ OnOff False , pTraceDebugPeerSelectionInitiatorTracer = pure $ OnOff False @@ -350,7 +339,7 @@ defaultPartialTraceConfiguration = , pTraceForge = pure $ OnOff True , pTraceForgeStateInfo = pure $ OnOff True , pTraceHandshake = pure $ OnOff False - , pTraceInboundGovernor = pure $ OnOff False + , pTraceInboundGovernor = pure $ OnOff True , pTraceInboundGovernorCounters = pure $ OnOff True , pTraceInboundGovernorTransitions = pure $ OnOff True , pTraceIpSubscription = pure $ OnOff True @@ -370,9 +359,9 @@ defaultPartialTraceConfiguration = , pTraceLocalTxSubmissionServer = pure $ OnOff False , pTraceMempool = pure $ OnOff True , pTraceMux = pure $ OnOff True - , pTracePeerSelection = pure $ OnOff False + , pTracePeerSelection = pure $ OnOff True , pTracePeerSelectionCounters = pure $ OnOff True - , pTracePeerSelectionActions = pure $ OnOff False + , pTracePeerSelectionActions = pure $ OnOff True , pTracePublicRootPeers = pure $ OnOff False , pTraceServer = pure $ OnOff False , pTraceTxInbound = pure $ OnOff False @@ -382,21 +371,22 @@ defaultPartialTraceConfiguration = } -partialTraceSelectionToEither :: PartialTraceOptions -> Either Text TraceOptions -partialTraceSelectionToEither PartialTracingOff = Right TracingOff -partialTraceSelectionToEither (PartialTraceDispatcher pTraceSelection) = do +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 - traceBlockFetchClient <- proxyLastToEither (Proxy @TraceBlockchainTime) pTraceBlockFetchClient - traceBlockFetchDecisions <- proxyLastToEither (Proxy @TraceBlockFetchClient) pTraceBlockFetchDecisions - traceBlockFetchProtocol <- proxyLastToEither (Proxy @TraceBlockFetchDecisions) pTraceBlockFetchProtocol - traceBlockFetchProtocolSerialised <- proxyLastToEither (Proxy @TraceBlockFetchProtocol) pTraceBlockFetchProtocolSerialised - traceBlockFetchServer <- proxyLastToEither (Proxy @TraceBlockFetchProtocolSerialised) pTraceBlockFetchServer - traceBlockchainTime <- proxyLastToEither (Proxy @TraceBlockFetchServer) pTraceBlockchainTime + 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 @TraceChainSyncClient) pTraceChainSyncBlockServer - traceChainSyncClient <- proxyLastToEither (Proxy @TraceChainSyncBlockServer) pTraceChainSyncClient + 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 @@ -441,76 +431,76 @@ partialTraceSelectionToEither (PartialTraceDispatcher pTraceSelection) = do traceTxSubmissionProtocol <- proxyLastToEither (Proxy @TraceTxSubmissionProtocol) pTraceTxSubmissionProtocol traceTxSubmission2Protocol <- proxyLastToEither (Proxy @TraceTxSubmission2Protocol) pTraceTxSubmission2Protocol Right $ TracingOnLegacy $ TraceSelection - { traceVerbosity - , traceAcceptPolicy - , traceBlockFetchClient - , traceBlockFetchDecisions - , traceBlockFetchProtocol - , traceBlockFetchProtocolSerialised - , traceBlockFetchServer - , traceBlockchainTime - , traceChainDB - , traceChainSyncBlockServer - , traceChainSyncClient - , traceChainSyncHeaderServer - , traceChainSyncProtocol - , traceConnectionManager - , traceConnectionManagerCounters - , traceConnectionManagerTransitions - , traceDebugPeerSelectionInitiatorTracer - , traceDebugPeerSelectionInitiatorResponderTracer - , traceDiffusionInitialization - , traceDnsResolver - , traceDnsSubscription - , traceErrorPolicy - , traceForge - , traceForgeStateInfo - , traceHandshake - , traceInboundGovernor - , traceInboundGovernorCounters - , traceInboundGovernorTransitions - , traceIpSubscription - , traceKeepAliveClient - , traceLedgerPeers - , traceLocalChainSyncProtocol - , traceLocalConnectionManager - , traceLocalErrorPolicy - , traceLocalHandshake - , traceLocalInboundGovernor - , traceLocalMux - , traceLocalTxMonitorProtocol - , traceLocalRootPeers - , traceLocalServer - , traceLocalStateQueryProtocol - , traceLocalTxSubmissionProtocol - , traceLocalTxSubmissionServer - , traceMempool - , traceMux - , tracePeerSelection - , tracePeerSelectionCounters - , tracePeerSelectionActions - , tracePublicRootPeers - , traceServer - , traceTxInbound - , traceTxOutbound - , traceTxSubmissionProtocol - , traceTxSubmission2Protocol + { 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 + , 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 + , traceLocalTxMonitorProtocol = traceLocalTxMonitorProtocol + , traceLocalRootPeers = traceLocalRootPeers + , traceLocalServer = traceLocalServer + , traceLocalStateQueryProtocol = traceLocalStateQueryProtocol + , traceLocalTxSubmissionProtocol = traceLocalTxSubmissionProtocol + , traceLocalTxSubmissionServer = traceLocalTxSubmissionServer + , traceMempool = traceMempool + , traceMux = traceMux + , tracePeerSelection = tracePeerSelection + , tracePeerSelectionCounters = tracePeerSelectionCounters + , tracePeerSelectionActions = tracePeerSelectionActions + , tracePublicRootPeers = tracePublicRootPeers + , traceServer = traceServer + , traceTxInbound = traceTxInbound + , traceTxOutbound = traceTxOutbound + , traceTxSubmissionProtocol = traceTxSubmissionProtocol + , traceTxSubmission2Protocol = traceTxSubmission2Protocol } -partialTraceSelectionToEither (PartialTracingOnLegacy pTraceSelection) = do +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 - traceBlockFetchClient <- proxyLastToEither (Proxy @TraceBlockchainTime) pTraceBlockFetchClient - traceBlockFetchDecisions <- proxyLastToEither (Proxy @TraceBlockFetchClient) pTraceBlockFetchDecisions - traceBlockFetchProtocol <- proxyLastToEither (Proxy @TraceBlockFetchDecisions) pTraceBlockFetchProtocol - traceBlockFetchProtocolSerialised <- proxyLastToEither (Proxy @TraceBlockFetchProtocol) pTraceBlockFetchProtocolSerialised - traceBlockFetchServer <- proxyLastToEither (Proxy @TraceBlockFetchProtocolSerialised) pTraceBlockFetchServer - traceBlockchainTime <- proxyLastToEither (Proxy @TraceBlockFetchServer) pTraceBlockchainTime + 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 @TraceChainSyncClient) pTraceChainSyncBlockServer - traceChainSyncClient <- proxyLastToEither (Proxy @TraceChainSyncBlockServer) pTraceChainSyncClient + 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 @@ -555,60 +545,60 @@ partialTraceSelectionToEither (PartialTracingOnLegacy pTraceSelection) = do traceTxSubmissionProtocol <- proxyLastToEither (Proxy @TraceTxSubmissionProtocol) pTraceTxSubmissionProtocol traceTxSubmission2Protocol <- proxyLastToEither (Proxy @TraceTxSubmission2Protocol) pTraceTxSubmission2Protocol Right $ TracingOnLegacy $ TraceSelection - { traceVerbosity - , traceAcceptPolicy - , traceBlockFetchClient - , traceBlockFetchDecisions - , traceBlockFetchProtocol - , traceBlockFetchProtocolSerialised - , traceBlockFetchServer - , traceBlockchainTime - , traceChainDB - , traceChainSyncBlockServer - , traceChainSyncClient - , traceChainSyncHeaderServer - , traceChainSyncProtocol - , traceConnectionManager - , traceConnectionManagerCounters - , traceConnectionManagerTransitions - , traceDebugPeerSelectionInitiatorTracer - , traceDebugPeerSelectionInitiatorResponderTracer - , traceDiffusionInitialization - , traceDnsResolver - , traceDnsSubscription - , traceErrorPolicy - , traceForge - , traceForgeStateInfo - , traceHandshake - , traceInboundGovernor - , traceInboundGovernorCounters - , traceInboundGovernorTransitions - , traceIpSubscription - , traceKeepAliveClient - , traceLedgerPeers - , traceLocalChainSyncProtocol - , traceLocalConnectionManager - , traceLocalErrorPolicy - , traceLocalHandshake - , traceLocalInboundGovernor - , traceLocalMux - , traceLocalRootPeers - , traceLocalServer - , traceLocalStateQueryProtocol - , traceLocalTxMonitorProtocol - , traceLocalTxSubmissionProtocol - , traceLocalTxSubmissionServer - , traceMempool - , traceMux - , tracePeerSelection - , tracePeerSelectionCounters - , tracePeerSelectionActions - , tracePublicRootPeers - , traceServer - , traceTxInbound - , traceTxOutbound - , traceTxSubmissionProtocol - , traceTxSubmission2Protocol + { 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 + , 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 + , traceLocalRootPeers = traceLocalRootPeers + , traceLocalServer = traceLocalServer + , traceLocalStateQueryProtocol = traceLocalStateQueryProtocol + , traceLocalTxMonitorProtocol = traceLocalTxMonitorProtocol + , traceLocalTxSubmissionProtocol = traceLocalTxSubmissionProtocol + , traceLocalTxSubmissionServer = traceLocalTxSubmissionServer + , traceMempool = traceMempool + , traceMux = traceMux + , tracePeerSelection = tracePeerSelection + , tracePeerSelectionCounters = tracePeerSelectionCounters + , tracePeerSelectionActions = tracePeerSelectionActions + , tracePublicRootPeers = tracePublicRootPeers + , traceServer = traceServer + , traceTxInbound = traceTxInbound + , traceTxOutbound = traceTxOutbound + , traceTxSubmissionProtocol = traceTxSubmissionProtocol + , traceTxSubmission2Protocol = traceTxSubmission2Protocol } proxyLastToEither :: KnownSymbol name => Proxy name -> Last a -> Either Text a diff --git a/cardano-node/test/Test/Cardano/Node/POM.hs b/cardano-node/test/Test/Cardano/Node/POM.hs index 3656a2227f3..ad365a79383 100644 --- a/cardano-node/test/Test/Cardano/Node/POM.hs +++ b/cardano-node/test/Test/Cardano/Node/POM.hs @@ -13,7 +13,8 @@ import Cardano.Node.Configuration.POM import Cardano.Node.Configuration.Socket import Cardano.Node.Handlers.Shutdown import Cardano.Node.Types -import Cardano.Tracing.Config (PartialTraceOptions (..), TraceOptions (..)) +import Cardano.Tracing.Config (PartialTraceOptions (..), defaultPartialTraceConfiguration, + partialTraceSelectionToEither) import qualified Ouroboros.Consensus.Node as Consensus (NetworkP2PMode (..)) import Ouroboros.Consensus.Storage.LedgerDB.DiskPolicy (SnapshotInterval (..)) import Ouroboros.Network.Block (MaxSlotNo (..), SlotNo (..)) @@ -22,7 +23,7 @@ import Ouroboros.Network.NodeToNode (AcceptedConnectionsLimit (..), import Hedgehog (Property, discover, withTests, (===)) import qualified Hedgehog -import Hedgehog.Internal.Property (failWith) +import Hedgehog.Internal.Property (evalEither, failWith) -- This is a simple test to check that the POM technique is working as intended. @@ -37,6 +38,7 @@ prop_sanityCheck_POM = <> testPartialYamlConfig <> testPartialCliConfig nc = makeNodeConfiguration combinedPartials + expectedConfig <- evalEither eExpectedConfig case nc of Left err -> failWith Nothing $ "Partial Options Monoid sanity check failure: " <> err Right config -> config === expectedConfig @@ -59,7 +61,7 @@ testPartialYamlConfig = , pncMaxConcurrencyDeadline = Last Nothing , pncLoggingSwitch = Last $ Just True , pncLogMetrics = Last $ Just True - , pncTraceConfig = PartialTracingOff + , pncTraceConfig = Last (Just $ PartialTracingOnLegacy defaultPartialTraceConfiguration) , pncConfigFile = mempty , pncTopologyFile = mempty , pncDatabaseFile = mempty @@ -96,7 +98,7 @@ testPartialCliConfig = , pncMaxConcurrencyDeadline = mempty , pncLoggingSwitch = mempty , pncLogMetrics = mempty - , pncTraceConfig = PartialTracingOff + , pncTraceConfig = Last (Just $ PartialTracingOnLegacy defaultPartialTraceConfiguration) , pncMaybeMempoolCapacityOverride = mempty , pncProtocolIdleTimeout = mempty , pncTimeWaitTimeout = mempty @@ -109,9 +111,11 @@ testPartialCliConfig = } -- | Expected final NodeConfiguration -expectedConfig :: NodeConfiguration -expectedConfig = - NodeConfiguration +eExpectedConfig :: Either Text NodeConfiguration +eExpectedConfig = do + traceOptions <- partialTraceSelectionToEither + (return $ PartialTracingOnLegacy defaultPartialTraceConfiguration) + return $ NodeConfiguration { ncSocketConfig = SocketConfig mempty mempty mempty mempty , ncShutdownConfig = ShutdownConfig Nothing (Just . MaxSlotNo $ SlotNo 42) , ncConfigFile = ConfigYamlFilePath "configuration/cardano/mainnet-config.json" @@ -129,7 +133,7 @@ expectedConfig = , ncMaxConcurrencyDeadline = Nothing , ncLoggingSwitch = True , ncLogMetrics = True - , ncTraceConfig = TracingOff + , ncTraceConfig = traceOptions , ncMaybeMempoolCapacityOverride = Nothing , ncProtocolIdleTimeout = 5 , ncTimeWaitTimeout = 60 From bdfd5aeedf404d9e4f111328818298e328137a42 Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Wed, 9 Feb 2022 09:15:50 -0400 Subject: [PATCH 4/4] Improve error reporting of cardano-node-chairman --- cabal.project | 3 ++ cardano-node-chairman/test/Main.hs | 6 ++-- cardano-testnet/src/Test/Process.hs | 33 +++++++++++++++---- cardano-testnet/src/Testnet/Byron.hs | 13 +++++--- cardano-testnet/src/Testnet/Cardano.hs | 10 +++--- cardano-testnet/src/Testnet/Shelley.hs | 16 +++++---- .../defaults/simpleview/config-0.yaml | 2 +- 7 files changed, 55 insertions(+), 28 deletions(-) diff --git a/cabal.project b/cabal.project index d6521ec4986..869ea0eb160 100644 --- a/cabal.project +++ b/cabal.project @@ -34,6 +34,9 @@ package cardano-node package cardano-node-chairman ghc-options: -Werror +package cardano-testnet + ghc-options: -Werror + package tx-generator ghc-options: -Werror diff --git a/cardano-node-chairman/test/Main.hs b/cardano-node-chairman/test/Main.hs index fcdc750f7a1..c62d28b1172 100644 --- a/cardano-node-chairman/test/Main.hs +++ b/cardano-node-chairman/test/Main.hs @@ -4,17 +4,17 @@ module Main ( main ) where -import Prelude +import Prelude import qualified System.Environment as E import qualified Test.Tasty as T -import qualified Test.Tasty.Ingredients as T import qualified Test.Tasty.Hedgehog as H +import qualified Test.Tasty.Ingredients as T -import qualified Spec.Network import qualified Spec.Chairman.Byron import qualified Spec.Chairman.Cardano import qualified Spec.Chairman.Shelley +import qualified Spec.Network tests :: IO T.TestTree tests = do diff --git a/cardano-testnet/src/Test/Process.hs b/cardano-testnet/src/Test/Process.hs index 9032d416513..23ef50616c3 100644 --- a/cardano-testnet/src/Test/Process.hs +++ b/cardano-testnet/src/Test/Process.hs @@ -1,5 +1,6 @@ module Test.Process - ( bashPath + ( assertByDeadlineIOCustom + , bashPath , execCli , execCli' , execCreateScriptContext @@ -10,20 +11,23 @@ module Test.Process , procChairman ) where -import Control.Monad (return) +import Prelude + +import qualified Control.Concurrent as IO +import Control.Monad import Control.Monad.Catch (MonadCatch) -import Control.Monad.IO.Class (MonadIO) -import Data.Function -import Data.Maybe -import Data.String +import Control.Monad.IO.Class +import Data.Time.Clock (UTCTime) +import qualified Data.Time.Clock as DTC import GHC.Stack (HasCallStack) import Hedgehog (MonadTest) import Hedgehog.Extras.Test.Process (ExecConfig) -import System.IO (FilePath) import System.Process (CreateProcess) import qualified GHC.Stack as GHC +import Hedgehog.Extras.Test.Base import qualified Hedgehog.Extras.Test.Process as H +import qualified Hedgehog.Internal.Property as H import qualified System.Environment as IO import qualified System.IO.Unsafe as IO @@ -111,3 +115,18 @@ procChairman -> m CreateProcess -- ^ Captured stdout procChairman = GHC.withFrozenCallStack $ H.procFlex "cardano-node-chairman" "CARDANO_NODE_CHAIRMAN" . ("run":) + +assertByDeadlineIOCustom + :: (MonadTest m, MonadIO m, HasCallStack) + => String -> UTCTime -> IO Bool -> m () +assertByDeadlineIOCustom str deadline f = GHC.withFrozenCallStack $ do + success <- liftIO f + unless success $ do + currentTime <- liftIO DTC.getCurrentTime + if currentTime < deadline + then do + liftIO $ IO.threadDelay 1000000 + assertByDeadlineIOCustom str deadline f + else do + H.annotateShow currentTime + failMessage GHC.callStack $ "Condition not met by deadline: " <> str diff --git a/cardano-testnet/src/Testnet/Byron.hs b/cardano-testnet/src/Testnet/Byron.hs index e8602b4a434..048a894db7c 100644 --- a/cardano-testnet/src/Testnet/Byron.hs +++ b/cardano-testnet/src/Testnet/Byron.hs @@ -13,7 +13,7 @@ module Testnet.Byron import Control.Monad import Data.Aeson (Value, (.=)) -import Data.Bool (Bool(..)) +import Data.Bool (Bool (..)) import Data.ByteString.Lazy (ByteString) import Data.Eq import Data.Function @@ -31,10 +31,10 @@ import Hedgehog.Extras.Stock.Time import System.FilePath.Posix (()) import Text.Show -import qualified Cardano.Node.Configuration.Topology as NonP2P +import qualified Cardano.Node.Configuration.Topology as NonP2P import qualified Cardano.Node.Configuration.TopologyP2P as P2P -import Ouroboros.Network.PeerSelection.RelayAccessPoint (RelayAccessPoint (..)) import Ouroboros.Network.PeerSelection.LedgerPeers (UseLedgerAfter (..)) +import Ouroboros.Network.PeerSelection.RelayAccessPoint (RelayAccessPoint (..)) import qualified Data.Aeson as J import qualified Data.HashMap.Lazy as HM @@ -50,8 +50,8 @@ import qualified Hedgehog.Extras.Test.Base as H import qualified Hedgehog.Extras.Test.File as H import qualified Hedgehog.Extras.Test.Network as H import qualified Hedgehog.Extras.Test.Process as H -import qualified System.Info as OS import qualified System.IO as IO +import qualified System.Info as OS import qualified System.Process as IO import qualified Test.Process as H import qualified Testnet.Conf as H @@ -85,6 +85,8 @@ replaceNodeLog :: Int -> String -> String replaceNodeLog n s = T.unpack (T.replace "logs/node-0.log" replacement (T.pack s)) where replacement = T.pack ("logs/node-" <> show @Int n <> ".log") +-- TODO: We need to refactor this to directly check the parsed configuration +-- and fail with a suitable error message. -- | Rewrite a line in the configuration file rewriteConfiguration :: Bool -> Int -> String -> String rewriteConfiguration _ _ "TraceBlockchainTime: False" = "TraceBlockchainTime: True" @@ -236,12 +238,13 @@ testnet testnetOptions H.Conf {..} = do si <- H.noteShow $ show @Int i sprocket <- H.noteShow $ Sprocket tempBaseAbsPath (socketDir "node-" <> si) _spocketSystemNameFile <- H.noteShow $ IO.sprocketSystemName sprocket + -- TODO: Better error message need to indicate a sprocket was not created H.waitByDeadlineM deadline $ H.doesSprocketExist sprocket forM_ nodeIndexes $ \i -> do si <- H.noteShow $ show @Int i nodeStdoutFile <- H.noteTempFile tempAbsPath $ "cardano-node-" <> si <> ".stdout.log" - H.assertByDeadlineIO deadline $ IO.fileContains "until genesis start time at" nodeStdoutFile + H.assertByDeadlineIOCustom "stdout does not contain \"until genesis start time\"" deadline $ IO.fileContains "until genesis start time at" nodeStdoutFile H.copyFile (tempAbsPath "config-1.yaml") (tempAbsPath "configuration.yaml") diff --git a/cardano-testnet/src/Testnet/Cardano.hs b/cardano-testnet/src/Testnet/Cardano.hs index b99e80e4bdf..2e834b269e3 100644 --- a/cardano-testnet/src/Testnet/Cardano.hs +++ b/cardano-testnet/src/Testnet/Cardano.hs @@ -23,7 +23,7 @@ module Testnet.Cardano ) where #ifdef UNIX -import Prelude (map, Bool(..)) +import Prelude (Bool (..), map) #else import Prelude (Bool (..)) #endif @@ -59,10 +59,10 @@ import Text.Show import System.Posix.Files #endif -import qualified Cardano.Node.Configuration.Topology as NonP2P +import qualified Cardano.Node.Configuration.Topology as NonP2P import qualified Cardano.Node.Configuration.TopologyP2P as P2P -import Ouroboros.Network.PeerSelection.RelayAccessPoint (RelayAccessPoint (..)) import Ouroboros.Network.PeerSelection.LedgerPeers (UseLedgerAfter (..)) +import Ouroboros.Network.PeerSelection.RelayAccessPoint (RelayAccessPoint (..)) import qualified Data.Aeson as J import qualified Data.HashMap.Lazy as HM @@ -810,8 +810,8 @@ testnet testnetOptions H.Conf {..} = do forM_ allNodes $ \node -> do nodeStdoutFile <- H.noteTempFile logDir $ node <> ".stdout.log" - H.assertByDeadlineIO deadline $ IO.fileContains "until genesis start time at" nodeStdoutFile - H.assertByDeadlineIO deadline $ IO.fileContains "Chain extended, new tip" nodeStdoutFile + H.assertByDeadlineIOCustom "stdout does not contain \"until genesis start time\"" deadline $ IO.fileContains "until genesis start time at" nodeStdoutFile + H.assertByDeadlineIOCustom "stdout does not contain \"Chain extended\"" deadline $ IO.fileContains "Chain extended, new tip" nodeStdoutFile H.noteShowIO_ DTC.getCurrentTime diff --git a/cardano-testnet/src/Testnet/Shelley.hs b/cardano-testnet/src/Testnet/Shelley.hs index 250868167a6..20b804a1ee4 100644 --- a/cardano-testnet/src/Testnet/Shelley.hs +++ b/cardano-testnet/src/Testnet/Shelley.hs @@ -17,9 +17,9 @@ module Testnet.Shelley ) where #ifdef UNIX -import Prelude (Integer, map, Bool(..), (-)) +import Prelude (Bool (..), Integer, map, (-)) #else -import Prelude (Integer, Bool(..), (-)) +import Prelude (Bool (..), Integer, (-)) #endif import Control.Monad @@ -44,10 +44,10 @@ import Hedgehog.Extras.Stock.IO.Network.Sprocket (Sprocket (..)) import System.FilePath.Posix (()) import Text.Show -import qualified Cardano.Node.Configuration.Topology as NonP2P +import qualified Cardano.Node.Configuration.Topology as NonP2P import qualified Cardano.Node.Configuration.TopologyP2P as P2P -import Ouroboros.Network.PeerSelection.RelayAccessPoint (RelayAccessPoint (..)) import Ouroboros.Network.PeerSelection.LedgerPeers (UseLedgerAfter (..)) +import Ouroboros.Network.PeerSelection.RelayAccessPoint (RelayAccessPoint (..)) import qualified Control.Concurrent as IO import qualified Data.Aeson as J @@ -59,8 +59,8 @@ import qualified Hedgehog as H import qualified Hedgehog.Extras.Stock.IO.File as IO import qualified Hedgehog.Extras.Stock.IO.Network.Socket as IO import qualified Hedgehog.Extras.Stock.IO.Network.Sprocket as IO -import qualified Hedgehog.Extras.Stock.String as S import qualified Hedgehog.Extras.Stock.OS as OS +import qualified Hedgehog.Extras.Stock.String as S import qualified Hedgehog.Extras.Test.Base as H import qualified Hedgehog.Extras.Test.File as H import qualified Hedgehog.Extras.Test.Network as H @@ -104,6 +104,8 @@ defaultTestnetOptions = TestnetOptions , enableP2P = False } +-- TODO: We need to refactor this to directly check the parsed configuration +-- and fail with a suitable error message. -- | Rewrite a line in the configuration file rewriteConfiguration :: Bool -> String -> String rewriteConfiguration True "EnableP2P: False" = "EnableP2P: True" @@ -474,8 +476,8 @@ testnet testnetOptions H.Conf {..} = do forM_ allNodes $ \node -> do nodeStdoutFile <- H.noteTempFile logDir $ node <> ".stdout.log" - H.assertByDeadlineIO deadline $ IO.fileContains "until genesis start time at" nodeStdoutFile - H.assertByDeadlineIO deadline $ IO.fileContains "Chain extended, new tip" nodeStdoutFile + H.assertByDeadlineIOCustom "stdout does not contain \"until genesis start time\"" deadline $ IO.fileContains "until genesis start time at" nodeStdoutFile + H.assertByDeadlineIOCustom "stdout does not contain \"Chain extended\"" deadline $ IO.fileContains "Chain extended, new tip" nodeStdoutFile H.noteShowIO_ DTC.getCurrentTime diff --git a/configuration/defaults/simpleview/config-0.yaml b/configuration/defaults/simpleview/config-0.yaml index bb906ff1b9e..6bda8d64fc4 100644 --- a/configuration/defaults/simpleview/config-0.yaml +++ b/configuration/defaults/simpleview/config-0.yaml @@ -99,7 +99,7 @@ TraceBlockFetchProtocolSerialised: False TraceBlockFetchServer: True # Trace BlockchainTime. -TraceBlockchainTime: False +TraceBlockchainTime: True # Verbose tracer of ChainDB TraceChainDb: False