diff --git a/CHANGELOG.md b/CHANGELOG.md index 7806eee26a6..552336adef6 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,12 +2,10 @@ Changelogs for components can be found as follows: -- [trace-resources](https://github.com/IntersectMBO/cardano-node/blob/master/trace-resources/CHANGELOG.md) -- [trace-dispatcher](https://github.com/IntersectMBO/cardano-node/blob/master/trace-dispatcher/CHANGELOG.md) -- [cardano-testnet](https://github.com/IntersectMBO/cardano-node/blob/master/cardano-testnet/CHANGELOG.md) -- [cardano-submit-api](https://github.com/IntersectMBO/cardano-node/blob/master/cardano-submit-api/CHANGELOG.md) -- [trace-forward](https://github.com/IntersectMBO/cardano-node/blob/master/trace-forward/CHANGELOG.md) -- [cardano-tracer](https://github.com/IntersectMBO/cardano-node/blob/master/cardano-tracer/CHANGELOG.md) -- [cardano-node-capi](https://github.com/IntersectMBO/cardano-node/blob/master/cardano-node-capi/CHANGELOG.md) -- [bench/tx-generator](https://github.com/IntersectMBO/cardano-node/blob/master/bench/tx-generator/CHANGELOG.md) - +- [trace-resources](https://github.com/IntersectMBO/cardano-node/blob/master/trace-resources/CHANGELOG.md) +- [cardano-testnet](https://github.com/IntersectMBO/cardano-node/blob/master/cardano-testnet/CHANGELOG.md) +- [cardano-submit-api](https://github.com/IntersectMBO/cardano-node/blob/master/cardano-submit-api/CHANGELOG.md) +- [trace-forward](https://github.com/IntersectMBO/cardano-node/blob/master/trace-forward/CHANGELOG.md) +- [cardano-tracer](https://github.com/IntersectMBO/cardano-node/blob/master/cardano-tracer/CHANGELOG.md) +- [cardano-node-capi](https://github.com/IntersectMBO/cardano-node/blob/master/cardano-node-capi/CHANGELOG.md) +- [bench/tx-generator](https://github.com/IntersectMBO/cardano-node/blob/master/bench/tx-generator/CHANGELOG.md) diff --git a/CODEOWNERS b/CODEOWNERS index 497887eca97..6a55e8ab2a2 100644 --- a/CODEOWNERS +++ b/CODEOWNERS @@ -8,7 +8,6 @@ # Perf/Tracing bench/ @intersectmbo/performance-and-tracing nix/workbench/ @intersectmbo/performance-and-tracing -trace-dispatcher/ @intersectmbo/performance-and-tracing trace-forward/ @intersectmbo/performance-and-tracing trace-resources/ @intersectmbo/performance-and-tracing Makefile @intersectmbo/performance-and-tracing @@ -22,4 +21,3 @@ flake.lock @intersectmbo/core ci/ @intersectmbo/core-tech-devx @intersectmbo/core-tech-release-1 configuration/ @intersectmbo/core-tech-devx @intersectmbo/core-tech-release-1 docker-compose.yml @intersectmbo/core-tech-devx @intersectmbo/core-tech-release-1 - diff --git a/README.md b/README.md index 2f0afb2af9e..1562249e7ef 100644 --- a/README.md +++ b/README.md @@ -16,7 +16,6 @@ The `cardano-node` repository is the point of integration of the [ledger](https://github.com/IntersectMBO/cardano-ledger), [consensus](https://github.com/IntersectMBO/ouroboros-consensus), [networking](https://github.com/IntersectMBO/ouroboros-network) -and [logging](https://github.com/IntersectMBO/cardano-node/tree/master/trace-dispatcher) layers. It provides the `cardano-node` executable which is used to participate in the Cardano network. This is an approximate diagram of the dependencies among the different components: diff --git a/bench/locli/locli.cabal b/bench/locli/locli.cabal index 21b5d941ee3..282c9c16712 100644 --- a/bench/locli/locli.cabal +++ b/bench/locli/locli.cabal @@ -126,8 +126,8 @@ library , fingertree == 0.1.5.0 , hashable , optparse-applicative - , ouroboros-consensus - , ouroboros-network-api ^>= 0.16 + , ouroboros-consensus:ouroboros-consensus + , ouroboros-network:api ^>= 1.1 , sop-core , split , sqlite-easy >= 1.1.0.1 diff --git a/bench/plutus-scripts-bench/plutus-scripts-bench.cabal b/bench/plutus-scripts-bench/plutus-scripts-bench.cabal index 3815b0a3be1..c1d484469bd 100644 --- a/bench/plutus-scripts-bench/plutus-scripts-bench.cabal +++ b/bench/plutus-scripts-bench/plutus-scripts-bench.cabal @@ -82,10 +82,10 @@ library -- IOG dependencies -------------------------- build-depends: - , cardano-api ^>=10.24.1 - , plutus-ledger-api ^>=1.58 - , plutus-tx ^>=1.58 - , plutus-tx-plugin ^>=1.58 + , cardano-api ^>=10.25 + , plutus-ledger-api ^>=1.59 + , plutus-tx ^>=1.59 + , plutus-tx-plugin ^>=1.59 ------------------------ -- Non-IOG dependencies diff --git a/bench/tx-generator/src/Cardano/Benchmarking/Command.hs b/bench/tx-generator/src/Cardano/Benchmarking/Command.hs index 87066f4a121..e1a8bdb1781 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/Command.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/Command.hs @@ -35,7 +35,7 @@ import Data.Foldable (for_) import Data.Maybe (catMaybes) import qualified Data.Text.IO as Text import Options.Applicative as Opt -import Ouroboros.Network.NodeToClient (IOManager, withIOManager) +import Cardano.Network.NodeToClient (IOManager, withIOManager) import System.Exit diff --git a/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/NodeToNode.hs b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/NodeToNode.hs index d15da29a231..0769317bdf3 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/NodeToNode.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/NodeToNode.hs @@ -48,9 +48,9 @@ import Ouroboros.Network.KeepAlive import Ouroboros.Network.Magic import Ouroboros.Network.Mux (MiniProtocolCb (..), OuroborosApplication (..), OuroborosBundle, RunMiniProtocol (..)) -import Ouroboros.Network.NodeToClient (chainSyncPeerNull) -import Ouroboros.Network.NodeToNode (NetworkConnectTracers (..)) -import qualified Ouroboros.Network.NodeToNode as NtN +import Cardano.Network.NodeToClient (chainSyncPeerNull) +import Cardano.Network.NodeToNode (NetworkConnectTracers (..)) +import qualified Cardano.Network.NodeToNode as NtN import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing (..)) import Ouroboros.Network.PeerSelection.PeerSharing.Codec (decodeRemoteAddress, encodeRemoteAddress) diff --git a/bench/tx-generator/src/Cardano/Benchmarking/LogTypes.hs b/bench/tx-generator/src/Cardano/Benchmarking/LogTypes.hs index 67e5fa75aac..8f8ee238e55 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/LogTypes.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/LogTypes.hs @@ -39,7 +39,7 @@ import Cardano.TxGenerator.Types (TPSRate) import Ouroboros.Consensus.Ledger.SupportsMempool (GenTxId) import Ouroboros.Network.Driver (TraceSendRecv (..)) import Ouroboros.Network.IOManager (IOManager) -import Ouroboros.Network.NodeToNode (NodeToNodeVersion, RemoteConnectionId) +import Cardano.Network.NodeToNode (NodeToNodeVersion, RemoteConnectionId) import Ouroboros.Network.Protocol.Handshake.Type (Handshake) import Ouroboros.Network.Protocol.TxSubmission2.Type (TxSubmission2) diff --git a/bench/tx-generator/src/Cardano/Benchmarking/OuroborosImports.hs b/bench/tx-generator/src/Cardano/Benchmarking/OuroborosImports.hs index 38bbb53d0cf..f16d6dd0f69 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/OuroborosImports.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/OuroborosImports.hs @@ -23,7 +23,7 @@ module Cardano.Benchmarking.OuroborosImports import Cardano.Api (BlockType (..), ConsensusModeParams (..), EpochSlots (..), LocalNodeConnectInfo (..), NetworkId (..), PaymentKey, SigningKey, SocketPath, - TxInMode, TxValidationErrorInCardanoMode, protocolInfo, submitTxToNodeLocal) + TxInMode, TxSubmitResult (..), protocolInfo, submitTxToNodeLocal) import Cardano.CLI.Type.Common (SigningKeyFile) import Cardano.Ledger.Shelley.Genesis (ShelleyGenesis) @@ -35,7 +35,6 @@ import Ouroboros.Consensus.Config (TopLevelConfig, configBlock, config import Ouroboros.Consensus.Config.SupportsNode (ConfigSupportsNode (..), getNetworkMagic) import Ouroboros.Consensus.Node (ProtocolInfo (..)) import Ouroboros.Consensus.Shelley.Eras (StandardCrypto) -import Ouroboros.Network.Protocol.LocalTxSubmission.Type (SubmitResult (..)) import Prelude @@ -61,4 +60,4 @@ makeLocalConnectInfo :: NetworkId -> SocketPath -> LocalNodeConnectInfo makeLocalConnectInfo networkId socketPath = LocalNodeConnectInfo (CardanoModeParams (EpochSlots 21600)) networkId socketPath -type LocalSubmitTx = (TxInMode -> IO (SubmitResult TxValidationErrorInCardanoMode)) +type LocalSubmitTx = (TxInMode -> IO TxSubmitResult) diff --git a/bench/tx-generator/src/Cardano/Benchmarking/Script/Core.hs b/bench/tx-generator/src/Cardano/Benchmarking/Script/Core.hs index 291be5f4b85..cfb742008dd 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/Script/Core.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/Script/Core.hs @@ -207,16 +207,20 @@ waitForEra era = do liftIO $ threadDelay 1_000_000 waitForEra era -localSubmitTx :: TxInMode -> ActionM (SubmitResult TxValidationErrorInCardanoMode) +localSubmitTx :: TxInMode -> ActionM TxSubmitResult localSubmitTx tx = do submit <- getLocalSubmitTx ret <- liftIO $ submit tx case ret of - SubmitSuccess -> return ret - SubmitFail e -> do + TxSubmitSuccess -> return ret + TxSubmitFail e -> do let msg = concat [ "local submit failed: " , show e , " (" , show tx , ")" ] traceDebug msg return ret + TxSubmitError e -> do + let msg = concat [ "local submit error: " , show e , " (" , show tx , ")" ] + traceDebug msg + return ret -- throwE $ ApiError msg -- TODO: diff --git a/bench/tx-generator/src/Cardano/Benchmarking/Script/Env.hs b/bench/tx-generator/src/Cardano/Benchmarking/Script/Env.hs index 4f82cfb6d1f..8eec3e43321 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/Script/Env.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/Script/Env.hs @@ -76,7 +76,7 @@ import Cardano.Node.Protocol.Types (SomeConsensusProtocol) import Cardano.TxGenerator.PlutusContext (PlutusBudgetSummary) import Cardano.TxGenerator.Setup.NixService as Nix (NixServiceOptions) import Cardano.TxGenerator.Types (TxGenError (..)) -import Ouroboros.Network.NodeToClient (IOManager) +import Cardano.Network.NodeToClient (IOManager) import Prelude diff --git a/bench/tx-generator/src/Cardano/Benchmarking/Tracer.hs b/bench/tx-generator/src/Cardano/Benchmarking/Tracer.hs index 453a01217d3..c7e27504354 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/Tracer.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/Tracer.hs @@ -37,6 +37,8 @@ import qualified Cardano.Logging.Types as Net import Cardano.Node.Startup import Cardano.Node.Tracing.NodeInfo () import Ouroboros.Network.IOManager (IOManager) +import qualified Ouroboros.Network.Protocol.TxSubmission2.Type as TxSubmission +import Ouroboros.Network.Tracing () import Control.Exception (SomeException (..)) import Control.Monad (forM, guard) @@ -49,6 +51,8 @@ import Data.Maybe (fromMaybe) import qualified Data.Text as Text import Data.Time.Clock import GHC.Generics +import Network.Mux.Tracing () +import qualified Network.TypedProtocol.Codec as TypedProtocol import Trace.Forward.Forwarding (InitForwardingConfig (..), initForwardingDelayed) import Trace.Forward.Utils.TraceObject @@ -395,30 +399,16 @@ instance MetaTrace NodeToNodeSubmissionTrace where , Namespace [] ["TxList"] ] -instance LogFormatting SendRecvConnect where +instance (Show txid, Show tx) => LogFormatting (TypedProtocol.AnyMessage (TxSubmission.TxSubmission2 txid tx)) where forHuman = Text.pack . show - forMachine _ _ = KeyMap.fromList [ "kind" .= A.String "SendRecvConnect" ] + forMachine _ _ = KeyMap.fromList [ "kind" .= A.String "TxSubmission2" ] -instance MetaTrace SendRecvConnect where - namespaceFor _ = Namespace [] ["ReqIdsBlocking"] +instance MetaTrace (TypedProtocol.AnyMessage (TxSubmission.TxSubmission2 tx a)) where + namespaceFor _ = Namespace [] ["TxSubmission2"] severityFor _ _ = Just Info documentFor _ = Just "" allNamespaces = [ - Namespace [] ["SendRecvConnect"] - ] - -instance LogFormatting SendRecvTxSubmission2 where - forHuman = Text.pack . show - forMachine _ _ = KeyMap.fromList [ "kind" .= A.String "SendRecvTxSubmission2" ] - -instance MetaTrace SendRecvTxSubmission2 where - namespaceFor _ = Namespace [] ["SendRecvTxSubmission2"] - severityFor _ _ = Just Info - - documentFor _ = Just "" - - allNamespaces = [ - Namespace [] ["SendRecvTxSubmission2"] + Namespace [] ["TxSubmission2"] ] diff --git a/bench/tx-generator/src/Cardano/TxGenerator/ProtocolParameters.hs b/bench/tx-generator/src/Cardano/TxGenerator/ProtocolParameters.hs index 2ed26726be7..ede1ccd534a 100644 --- a/bench/tx-generator/src/Cardano/TxGenerator/ProtocolParameters.hs +++ b/bench/tx-generator/src/Cardano/TxGenerator/ProtocolParameters.hs @@ -48,6 +48,7 @@ import qualified Cardano.Ledger.Babbage.Core as Ledger import qualified Cardano.Ledger.BaseTypes as Ledger import qualified Cardano.Ledger.Coin as L import qualified Cardano.Ledger.Plutus.Language as Plutus +import qualified Cardano.Ledger.Compactible as L import Data.Aeson ((.!=), (.:), (.:?), (.=)) import qualified Data.Aeson as Aeson @@ -379,8 +380,8 @@ toShelleyCommonPParams protVer <- mkProtVer protocolParamProtocolVersion let ppCommon = emptyPParams - & ppMinFeeAL .~ protocolParamTxFeePerByte - & ppMinFeeBL .~ protocolParamTxFeeFixed + & ppTxFeePerByteL .~ (CoinPerByte . L.compactCoinOrError $ protocolParamTxFeePerByte) + & ppTxFeeFixedL .~ protocolParamTxFeeFixed & ppMaxBBSizeL .~ fromIntegral protocolParamMaxBlockBodySize & ppMaxTxSizeL .~ fromIntegral protocolParamMaxTxSize & ppMaxBHSizeL .~ fromIntegral protocolParamMaxBlockHeaderSize @@ -457,9 +458,9 @@ toAlonzoCommonPParams & ppPricesL .~ prices & ppMaxTxExUnitsL .~ toAlonzoExUnits maxTxExUnits & ppMaxBlockExUnitsL .~ toAlonzoExUnits maxBlockExUnits - & ppMaxValSizeL .~ maxValueSize - & ppCollateralPercentageL .~ collateralPercent - & ppMaxCollateralInputsL .~ maxCollateralInputs + & ppMaxValSizeL .~ fromIntegral maxValueSize + & ppCollateralPercentageL .~ fromIntegral collateralPercent + & ppMaxCollateralInputsL .~ fromIntegral maxCollateralInputs pure ppAlonzoCommon -- Was removed in "cardano-api" module "Cardano.Api.Internal.ProtocolParameters" @@ -495,7 +496,7 @@ toBabbagePParams requireParam "protocolParamUTxOCostPerByte" Right protocolParamUTxOCostPerByte let ppBabbage = ppAlonzoCommon - & ppCoinsPerUTxOByteL .~ CoinPerByte utxoCostPerByte + & ppCoinsPerUTxOByteL .~ CoinPerByte (L.compactCoinOrError utxoCostPerByte) pure ppBabbage -- Was removed in "cardano-api" module "Cardano.Api.Internal.ProtocolParameters" @@ -531,8 +532,8 @@ fromShelleyCommonPParams pp = , protocolParamMaxBlockHeaderSize = fromIntegral $ pp ^. ppMaxBHSizeL , protocolParamMaxBlockBodySize = fromIntegral $ pp ^. ppMaxBBSizeL , protocolParamMaxTxSize = fromIntegral $ pp ^. ppMaxTxSizeL - , protocolParamTxFeeFixed = pp ^. ppMinFeeBL - , protocolParamTxFeePerByte = pp ^. ppMinFeeAL + , protocolParamTxFeeFixed = pp ^. ppTxFeeFixedL + , protocolParamTxFeePerByte = L.fromCompact . L.unCoinPerByte $ pp ^. ppTxFeePerByteL , protocolParamStakeAddressDeposit = pp ^. ppKeyDepositL , protocolParamStakePoolDeposit = pp ^. ppPoolDepositL , protocolParamMinPoolCost = pp ^. ppMinPoolCostL @@ -579,9 +580,9 @@ fromAlonzoPParams pp = , protocolParamPrices = Just . fromAlonzoPrices $ pp ^. ppPricesL , protocolParamMaxTxExUnits = Just . fromAlonzoExUnits $ pp ^. ppMaxTxExUnitsL , protocolParamMaxBlockExUnits = Just . fromAlonzoExUnits $ pp ^. ppMaxBlockExUnitsL - , protocolParamMaxValueSize = Just $ pp ^. ppMaxValSizeL - , protocolParamCollateralPercent = Just $ pp ^. ppCollateralPercentageL - , protocolParamMaxCollateralInputs = Just $ pp ^. ppMaxCollateralInputsL + , protocolParamMaxValueSize = Just $ fromIntegral (pp ^. ppMaxValSizeL) + , protocolParamCollateralPercent = Just $ fromIntegral (pp ^. ppCollateralPercentageL) + , protocolParamMaxCollateralInputs = Just $ fromIntegral (pp ^. ppMaxCollateralInputsL) } fromExactlyAlonzoPParams @@ -599,7 +600,7 @@ fromBabbagePParams -> ProtocolParameters fromBabbagePParams pp = (fromAlonzoPParams pp) - { protocolParamUTxOCostPerByte = Just . unCoinPerByte $ pp ^. ppCoinsPerUTxOByteL + { protocolParamUTxOCostPerByte = Just . L.fromCompact . unCoinPerByte $ pp ^. ppCoinsPerUTxOByteL , protocolParamDecentralization = Nothing } diff --git a/bench/tx-generator/src/Cardano/TxGenerator/Setup/NodeConfig.hs b/bench/tx-generator/src/Cardano/TxGenerator/Setup/NodeConfig.hs index bb1e80d8751..2c1b7137f80 100644 --- a/bench/tx-generator/src/Cardano/TxGenerator/Setup/NodeConfig.hs +++ b/bench/tx-generator/src/Cardano/TxGenerator/Setup/NodeConfig.hs @@ -17,7 +17,7 @@ import Cardano.Node.Protocol.Cardano import Cardano.Node.Protocol.Types (SomeConsensusProtocol (..)) import Cardano.Node.Types (ConfigYamlFilePath (..), GenesisFile, NodeProtocolConfiguration (..), NodeShelleyProtocolConfiguration (..), - ProtocolFilepaths (..)) + ProtocolFilepaths (..), KESSource(..)) import Cardano.TxGenerator.Types import qualified Ouroboros.Consensus.Cardano.Node as Consensus @@ -70,7 +70,7 @@ mkNodeConfig configFp_ ProtocolFilepaths { byronCertFile = Just "" , byronKeyFile = Just "" - , shelleyKESFile = Just "" + , shelleyKESSource = Just (KESKeyFilePath "") , shelleyVRFFile = Just "" , shelleyCertFile = Just "" , shelleyBulkCredsFile = Just "" diff --git a/bench/tx-generator/tx-generator.cabal b/bench/tx-generator/tx-generator.cabal index c18c68ddcb0..ad994d1e612 100644 --- a/bench/tx-generator/tx-generator.cabal +++ b/bench/tx-generator/tx-generator.cabal @@ -108,12 +108,13 @@ library , attoparsec-aeson , base16-bytestring , bytestring - , cardano-api ^>= 10.24.1 + , cardano-api ^>= 10.25 , cardano-binary , cardano-cli ^>= 10.15.0.1 , cardano-crypto-class , cardano-crypto-wrapper , cardano-data + , cardano-diffusion ^>= 1.0 , cardano-git-rev ^>= 0.2.2 , cardano-ledger-alonzo , cardano-ledger-api @@ -121,6 +122,7 @@ library , cardano-ledger-core , cardano-node , cardano-prelude + , cardano-strict-containers >=0.1 , contra-tracer , cborg >= 0.2.2 && < 0.3 , containers @@ -137,16 +139,12 @@ library , network , network-mux , optparse-applicative - , ouroboros-consensus >= 0.6 - , ouroboros-consensus-cardano >= 0.5 - , ouroboros-consensus-diffusion >= 0.7.0 - , ouroboros-network - , ouroboros-network-api - , ouroboros-network-framework - , ouroboros-network-protocols + , ouroboros-consensus:{ouroboros-consensus, cardano, diffusion} >= 1.0 + , ouroboros-network:{api, framework, framework-tracing, ouroboros-network, protocols} >= 1.1 , plutus-ledger-api , plutus-tx , random + , typed-protocols ^>= 1.2 , serialise , streaming , cardano-ledger-shelley diff --git a/cabal.project b/cabal.project index 1a821ddc7db..4b25216c8bc 100644 --- a/cabal.project +++ b/cabal.project @@ -13,8 +13,8 @@ repository cardano-haskell-packages -- See CONTRIBUTING for information about these, including some Nix commands -- you need to run if you change them index-state: - , hackage.haskell.org 2026-02-06T20:27:32Z - , cardano-haskell-packages 2026-03-03T10:50:34Z + , hackage.haskell.org 2026-02-17T10:15:41Z + , cardano-haskell-packages 2026-03-19T11:07:17Z constraints: -- haskell.nix patch does not work for 1.6.8 @@ -33,7 +33,6 @@ packages: bench/plutus-scripts-bench bench/tx-generator bench/cardano-recon-framework - trace-dispatcher trace-resources trace-forward @@ -41,7 +40,7 @@ packages: extra-packages: alex program-options - ghc-options: -Werror + -- ghc-options: -Werror test-show-details: direct @@ -77,3 +76,11 @@ if impl(ghc >= 9.12) -- IMPORTANT -- Do NOT add more source-repository-package stanzas here unless they are strictly -- temporary! Please read the section in CONTRIBUTING about updating dependencies. + +source-repository-package + type: git + location: https://github.com/IntersectMBO/cardano-cli + tag: 88c601cc05d33615bb355d13d372cc94f3bbc911 + --sha256: sha256-+CN9JI5ayCb/QQXvRcmLhNPEj0wLDjms+VKnJlr0EQs= + subdir: + cardano-cli diff --git a/cardano-node-chairman/cardano-node-chairman.cabal b/cardano-node-chairman/cardano-node-chairman.cabal index 3a2c9e630e1..487e00bb2aa 100644 --- a/cardano-node-chairman/cardano-node-chairman.cabal +++ b/cardano-node-chairman/cardano-node-chairman.cabal @@ -44,17 +44,15 @@ executable cardano-node-chairman build-depends: cardano-api , cardano-crypto-class , cardano-git-rev ^>= 0.2.2 - , cardano-ledger-core ^>= 1.18 + , cardano-ledger-core ^>= 1.19 , cardano-node ^>= 10.6 , cardano-prelude , containers , contra-tracer - , io-classes:{io-classes, strict-stm, si-timers} + , io-classes:{io-classes, strict-stm, si-timers} ^>= 1.8 , optparse-applicative - , ouroboros-consensus - , ouroboros-consensus-cardano - , ouroboros-network-api - , ouroboros-network-protocols + , ouroboros-consensus:{ouroboros-consensus, cardano} + , ouroboros-network:{api, protocols} , text , time @@ -69,7 +67,7 @@ test-suite chairman-tests build-depends: , cardano-api , cardano-testnet - , cardano-crypto-class ^>=2.2.3.2 + , cardano-crypto-class ^>=2.3 , data-default-class , filepath , hedgehog diff --git a/cardano-node/app/cardano-node.hs b/cardano-node/app/cardano-node.hs index f18175f9497..08d3fd5dcae 100644 --- a/cardano-node/app/cardano-node.hs +++ b/cardano-node/app/cardano-node.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TemplateHaskell #-} diff --git a/cardano-node/cardano-node.cabal b/cardano-node/cardano-node.cabal index 9f463f9b347..cbe8e915c4d 100644 --- a/cardano-node/cardano-node.cabal +++ b/cardano-node/cardano-node.cabal @@ -104,14 +104,12 @@ library Cardano.Node.Tracing.Tracers.ChainDB Cardano.Node.Tracing.Tracers.Consensus Cardano.Node.Tracing.Tracers.ConsensusStartupException - Cardano.Node.Tracing.Tracers.Diffusion Cardano.Node.Tracing.Tracers.ForgingStats Cardano.Node.Tracing.Tracers.KESInfo Cardano.Node.Tracing.Tracers.LedgerMetrics Cardano.Node.Tracing.Tracers.NodeToClient Cardano.Node.Tracing.Tracers.NodeToNode Cardano.Node.Tracing.Tracers.NodeVersion - Cardano.Node.Tracing.Tracers.P2P Cardano.Node.Tracing.Tracers.Resources Cardano.Node.Tracing.Tracers.Shutdown Cardano.Node.Tracing.Tracers.Startup @@ -138,8 +136,9 @@ library , async , base16-bytestring , bytestring - , cardano-api ^>= 10.24.1 - , cardano-crypto-class ^>=2.2.3.2 + , cardano-api ^>= 10.25 + , cardano-data + , cardano-crypto-class ^>=2.3 , cardano-crypto-wrapper , cardano-git-rev ^>=0.2.2 , cardano-ledger-alonzo @@ -165,13 +164,12 @@ library , ekg-wai , ekg-core , filepath - , formatting , generic-data , hashable , hostname - , io-classes:{io-classes,strict-stm,si-timers} >= 1.5 + , io-classes:{io-classes,strict-stm,si-timers} ^>= 1.8 , iohk-monitoring ^>= 0.2 - , kes-agent ^>=0.2 + , kes-agent ^>=1.2 , microlens , mmap , network-mux @@ -185,14 +183,9 @@ library , network-mux >= 0.8 , nothunks , optparse-applicative - , ouroboros-consensus >=0.30.0.1 && <0.31 - , ouroboros-consensus-cardano ^>= 0.26 - , ouroboros-consensus-diffusion ^>= 0.26 - , ouroboros-consensus-protocol - , ouroboros-network-api ^>= 0.16 - , ouroboros-network:{ouroboros-network, cardano-diffusion, orphan-instances} ^>= 0.22.6 - , ouroboros-network-framework ^>= 0.19.3 - , ouroboros-network-protocols ^>= 0.15.2 + , ouroboros-consensus:{ouroboros-consensus, lmdb, lsm, cardano, diffusion, protocol} ^>= 1.0 + , ouroboros-network:{api, ouroboros-network, orphan-instances, framework, protocols, framework-tracing, tracing} ^>= 1.1 + , cardano-diffusion:{api, cardano-diffusion, orphan-instances, tracing} ^>=1.0 , prettyprinter , prettyprinter-ansi-terminal , psqueues @@ -214,7 +207,7 @@ library , tracer-transformers , transformers , transformers-except - , typed-protocols:{typed-protocols, stateful} >= 1.0 + , typed-protocols:{typed-protocols, stateful} >= 1.2 , yaml executable cardano-node @@ -252,6 +245,7 @@ test-suite cardano-node-test , cardano-crypto-class , cardano-crypto-wrapper , cardano-api + , cardano-diffusion:{api, cardano-diffusion, orphan-instances} , cardano-protocol-tpraos , cardano-node , cardano-slotting @@ -263,11 +257,8 @@ test-suite cardano-node-test , hedgehog-extras ^>= 0.10 , iproute , mtl - , ouroboros-consensus - , ouroboros-consensus-cardano - , ouroboros-consensus-diffusion - , ouroboros-network:{ouroboros-network, cardano-diffusion} - , ouroboros-network-api + , ouroboros-consensus:{ouroboros-consensus, cardano, diffusion} + , ouroboros-network:{api, framework, ouroboros-network} , strict-sop-core , text , trace-dispatcher diff --git a/cardano-node/src/Cardano/Node/Configuration/LedgerDB.hs b/cardano-node/src/Cardano/Node/Configuration/LedgerDB.hs index f43c5029725..32ea7e9143c 100644 --- a/cardano-node/src/Cardano/Node/Configuration/LedgerDB.hs +++ b/cardano-node/src/Cardano/Node/Configuration/LedgerDB.hs @@ -1,28 +1,35 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralisedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-orphans #-} module Cardano.Node.Configuration.LedgerDB ( - DeprecatedOptions (..) - , LedgerDbConfiguration (..) - , LedgerDbSelectorFlag(..) - , Gigabytes - , noDeprecatedOptions - , selectorToArgs - ) where + DeprecatedOptions (..), + LedgerDbConfiguration (..), + LedgerDbSelectorFlag (..), + Gigabytes, + noDeprecatedOptions, + selectorToArgs, +) where +import Ouroboros.Consensus.Ledger.SupportsProtocol +import Ouroboros.Consensus.Storage.LedgerDB.API import Ouroboros.Consensus.Storage.LedgerDB.Args import Ouroboros.Consensus.Storage.LedgerDB.Snapshots import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.Args as V1 -import Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.Impl.LMDB (LMDBLimits (..)) -import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.Args as V2 -import Ouroboros.Consensus.Util.Args +import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.Impl.LMDB as LMDB +import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.InMemory as InMemory +import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.LSM as LSM import qualified Data.Aeson.Types as Aeson (FromJSON) import Data.Maybe (fromMaybe) -import Data.SOP.Dict +import Data.Proxy +import System.FilePath +import System.Random (StdGen) -- | Choose the LedgerDB Backend -- @@ -34,21 +41,25 @@ import Data.SOP.Dict -- -- - 'V1LMDB': uses less memory but is somewhat slower. -- --- - 'V1InMemory': Not intended for production. It is an in-memory reproduction --- of the LMDB implementation. +-- - 'V2LSM': Uses the LSM backend. data LedgerDbSelectorFlag = V1LMDB V1.FlushFrequency -- ^ The frequency at which changes are flushed to the disk. (Maybe FilePath) - -- ^ Path for the live tables. + -- ^ Path for the live tables. If not provided the default will be used + -- (@/lmdb@). (Maybe Gigabytes) -- ^ A map size can be specified, this is the maximum disk space the LMDB -- database can fill. If not provided, the default of 16GB will be used. (Maybe Int) -- ^ An override to the max number of readers. - | V1InMemory V1.FlushFrequency | V2InMemory + | V2LSM + (Maybe FilePath) + -- ^ Maybe a custom path to the LSM database. If not provided the default + -- will be used (@/lsm@). + deriving (Eq, Show) -- | Some options that existed in the TopLevel were now moved to a @@ -118,24 +129,23 @@ toBytes (Gigabytes x) = x * 1024 * 1024 * 1024 -- * The @lmdb-simple@ and @haskell-lmdb@ forked repositories. -- * The official LMDB API documentation at -- . -defaultLMDBLimits :: LMDBLimits -defaultLMDBLimits = LMDBLimits { - lmdbMapSize = 16 * 1024 * 1024 * 1024 - , lmdbMaxDatabases = 10 - , lmdbMaxReaders = 16 +defaultLMDBLimits :: LMDB.LMDBLimits +defaultLMDBLimits = LMDB.LMDBLimits { + LMDB.lmdbMapSize = 16 * 1024 * 1024 * 1024 + , LMDB.lmdbMaxDatabases = 10 + , LMDB.lmdbMaxReaders = 16 } -defaultLMDBPath :: FilePath -defaultLMDBPath = "mainnet/db/lmdb" +defaultLMDBPath :: FilePath -> FilePath +defaultLMDBPath = ( "lmdb") -selectorToArgs :: LedgerDbSelectorFlag -> Complete LedgerDbFlavorArgs IO -selectorToArgs (V1InMemory ff) = LedgerDbFlavorArgsV1 $ V1.V1Args ff V1.InMemoryBackingStoreArgs -selectorToArgs V2InMemory = LedgerDbFlavorArgsV2 $ V2.V2Args V2.InMemoryHandleArgs -selectorToArgs (V1LMDB ff fp l mxReaders) = - LedgerDbFlavorArgsV1 - $ V1.V1Args ff - $ V1.LMDBBackingStoreArgs - (fromMaybe defaultLMDBPath fp) - (maybe id (\overrideMaxReaders lim -> lim { lmdbMaxReaders = overrideMaxReaders }) mxReaders - $ maybe id (\ll lim -> lim { lmdbMapSize = toBytes ll }) l defaultLMDBLimits) - Dict +selectorToArgs :: forall blk. (LedgerSupportsProtocol blk, LedgerSupportsLedgerDB blk) => LedgerDbSelectorFlag -> FilePath -> StdGen -> (LedgerDbBackendArgs IO blk, StdGen) +selectorToArgs V2InMemory _ = InMemory.mkInMemoryArgs +selectorToArgs (V1LMDB ff fp l mxReaders) fastStoragePath = + LMDB.mkLMDBArgs + ff + (fromMaybe (defaultLMDBPath fastStoragePath) fp) + ( maybe id (\overrideMaxReaders lim -> lim{LMDB.lmdbMaxReaders = overrideMaxReaders}) mxReaders $ + maybe id (\ll lim -> lim{LMDB.lmdbMapSize = toBytes ll}) l defaultLMDBLimits + ) +selectorToArgs (V2LSM fp) fastStoragePath = LSM.mkLSMArgs (Proxy @blk) (fromMaybe "lsm" fp) fastStoragePath diff --git a/cardano-node/src/Cardano/Node/Configuration/POM.hs b/cardano-node/src/Cardano/Node/Configuration/POM.hs index 13f9052837d..8bfcd3d13d4 100644 --- a/cardano-node/src/Cardano/Node/Configuration/POM.hs +++ b/cardano-node/src/Cardano/Node/Configuration/POM.hs @@ -28,7 +28,8 @@ where import Cardano.Crypto (RequiresNetworkMagic (..)) import Cardano.Logging.Types import qualified Cardano.Network.Diffusion.Configuration as Cardano -import Cardano.Network.Types (NumberOfBigLedgerPeers (..)) +import Cardano.Network.PeerSelection (NumberOfBigLedgerPeers (..)) +import Cardano.Network.ConsensusMode (ConsensusMode(..), defaultConsensusMode) import Cardano.Node.Configuration.LedgerDB import Cardano.Node.Configuration.Socket (SocketConfig (..)) import Cardano.Node.Handlers.Shutdown @@ -49,6 +50,8 @@ import Ouroboros.Network.Diffusion.Configuration as Configuration import qualified Ouroboros.Network.Diffusion.Configuration as Ouroboros import qualified Ouroboros.Network.Mux as Mux import qualified Ouroboros.Network.PeerSelection.Governor as PeerSelection +import Ouroboros.Network.TxSubmission.Inbound.V2.Types + (TxSubmissionInitDelay(..), TxSubmissionLogicVersion(..), defaultTxSubmissionInitDelay) import Control.Concurrent (getNumCapabilities) import Control.Monad (unless, void, when) @@ -196,6 +199,9 @@ data NodeConfiguration , ncGenesisConfig :: GenesisConfig , ncResponderCoreAffinityPolicy :: ResponderCoreAffinityPolicy + + , ncTxSubmissionLogicVersion :: TxSubmissionLogicVersion + , ncTxSubmissionInitDelay :: TxSubmissionInitDelay } deriving (Eq, Show) -- | We expose the `Ouroboros.Network.Mux.ForkPolicy` as a `NodeConfiguration` field. @@ -296,6 +302,9 @@ data PartialNodeConfiguration , pncGenesisConfigFlags :: !(Last GenesisConfigFlags) , pncResponderCoreAffinityPolicy :: !(Last ResponderCoreAffinityPolicy) + + , pncTxSubmissionLogicVersion :: !(Last TxSubmissionLogicVersion) + , pncTxSubmissionInitDelay :: !(Last TxSubmissionInitDelay) } deriving (Eq, Generic, Show) instance AdjustFilePaths PartialNodeConfiguration where @@ -412,6 +421,12 @@ instance FromJSON PartialNodeConfiguration where <$> v .:? "ResponderCoreAffinityPolicy" <*> v .:? "ForkPolicy" -- deprecated + txSubmissionLogicVersion <- Last <$> v .:? "TxSubmissionLogicVersion" + let parseInitDelay = + maybe (pncTxSubmissionInitDelay defaultPartialNodeConfiguration) (fmap TxSubmissionInitDelay) + <$> v .:? "TxSubmissionInitDelay" + pncTxSubmissionInitDelay <- parseInitDelay + pure PartialNodeConfiguration { pncProtocolConfig , pncSocketConfig = Last . Just $ SocketConfig mempty mempty mempty pncSocketPath @@ -459,6 +474,8 @@ instance FromJSON PartialNodeConfiguration where , pncPeerSharing , pncGenesisConfigFlags , pncResponderCoreAffinityPolicy + , pncTxSubmissionLogicVersion = txSubmissionLogicVersion + , pncTxSubmissionInitDelay } where parseMempoolCapacityBytesOverride v = parseNoOverride <|> parseOverride @@ -500,9 +517,6 @@ instance FromJSON PartialNodeConfiguration where qsize <- (fmap RequestedQueryBatchSize <$> o .:? "QueryBatchSize") .!= DefaultQueryBatchSize backend <- o .:? "Backend" .!= "V2InMemory" selector <- case backend of - "V1InMemory" -> do - flush <- (fmap RequestedFlushFrequency <$> o .:? "FlushFrequency") .!= DefaultFlushFrequency - return $ V1InMemory flush "V1LMDB" -> do flush <- (fmap RequestedFlushFrequency <$> o .:? "FlushFrequency") .!= DefaultFlushFrequency mapSize :: Maybe Gigabytes <- o .:? "MapSize" @@ -510,6 +524,9 @@ instance FromJSON PartialNodeConfiguration where mxReaders :: Maybe Int <- o .:? "MaxReaders" return $ V1LMDB flush lmdbPath mapSize mxReaders "V2InMemory" -> return V2InMemory + "V2LSM" -> do + lsmPath :: Maybe FilePath <- o .:? "LSMDatabasePath" + pure $ V2LSM lsmPath _ -> fail $ "Malformed LedgerDB Backend: " <> backend pure $ Just $ LedgerDbConfiguration ldbSnapNum ldbSnapInterval qsize selector deprecatedOpts @@ -717,13 +734,16 @@ defaultPartialNodeConfiguration = , pncMinBigLedgerPeersForTrustedState = Last (Just Cardano.defaultNumberOfBigLedgerPeers) -- https://ouroboros-network.cardano.intersectmbo.org/ouroboros-network/cardano-diffusion/Cardano-Network-Diffusion-Configuration.html#v:defaultNumberOfBigLedgerPeers - , pncConsensusMode = Last (Just Ouroboros.defaultConsensusMode) + , pncConsensusMode = Last (Just defaultConsensusMode) -- https://ouroboros-network.cardano.intersectmbo.org/ouroboros-network/Ouroboros-Network-Diffusion-Configuration.html#v:defaultConsensusMode , pncPeerSharing = mempty -- the default is defined in `makeNodeConfiguration` , pncGenesisConfigFlags = Last (Just defaultGenesisConfigFlags) -- https://ouroboros-consensus.cardano.intersectmbo.org/haddocks/ouroboros-consensus-diffusion/Ouroboros-Consensus-Node-Genesis.html#v:defaultGenesisConfigFlags , pncResponderCoreAffinityPolicy = Last $ Just NoResponderCoreAffinity + + , pncTxSubmissionLogicVersion = Last $ Just TxSubmissionLogicV1 + , pncTxSubmissionInitDelay = Last $ Just defaultTxSubmissionInitDelay } lastOption :: Parser a -> Parser (Last a) @@ -821,7 +841,7 @@ makeNodeConfiguration pnc = do , getLast (pncMempoolTimeoutHard pnc) , getLast (pncMempoolTimeoutCapacity pnc) ) - (ncMempoolTimeoutSoft, ncMempoolTimeoutHard, ncMempoolTimeoutCapacity) <- + (ncMempoolTimeoutSoft, ncMempoolTimeoutHard, ncMempoolTimeoutCapacity) <- case mempoolTimeouts of (Just s, Just h, Just c) -> pure (s, h, c) (Nothing, Nothing, Nothing) -> pure (1, 1.5, 5) @@ -845,6 +865,9 @@ makeNodeConfiguration pnc = do ncResponderCoreAffinityPolicy <- lastToEither "Missing ResponderCoreAffinityPolicy" $ pncResponderCoreAffinityPolicy pnc + ncTxSubmissionLogicVersion <- lastToEither "Missing TxSubmissionLogicVersion" $ pncTxSubmissionLogicVersion pnc + ncTxSubmissionInitDelay <- lastToEither "Missing TxSubmissionInitDelay" $ pncTxSubmissionInitDelay pnc + let deadlineTargets = PeerSelectionTargets { targetNumberOfRootPeers = ncDeadlineTargetOfRootPeers, @@ -922,6 +945,8 @@ makeNodeConfiguration pnc = do , ncConsensusMode , ncGenesisConfig , ncResponderCoreAffinityPolicy + , ncTxSubmissionLogicVersion + , ncTxSubmissionInitDelay } ncProtocol :: NodeConfiguration -> Protocol diff --git a/cardano-node/src/Cardano/Node/Configuration/Socket.hs b/cardano-node/src/Cardano/Node/Configuration/Socket.hs index f0de1bbb3f2..ed15f8661ed 100644 --- a/cardano-node/src/Cardano/Node/Configuration/Socket.hs +++ b/cardano-node/src/Cardano/Node/Configuration/Socket.hs @@ -26,7 +26,7 @@ import qualified Network.Socket as Socket import Cardano.Node.Configuration.NodeAddress -import Ouroboros.Network.NodeToClient (LocalAddress (..), LocalSocket (..)) +import Cardano.Network.NodeToClient (LocalAddress (..), LocalSocket (..)) #if !defined(mingw32_HOST_OS) import System.Directory (removeFile) diff --git a/cardano-node/src/Cardano/Node/Configuration/TopologyP2P.hs b/cardano-node/src/Cardano/Node/Configuration/TopologyP2P.hs index 201c3aa499b..2e780d7a000 100644 --- a/cardano-node/src/Cardano/Node/Configuration/TopologyP2P.hs +++ b/cardano-node/src/Cardano/Node/Configuration/TopologyP2P.hs @@ -1,5 +1,4 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE NamedFieldPuns #-} @@ -7,53 +6,30 @@ {-# LANGUAGE PackageImports #-} {-# LANGUAGE RankNTypes #-} --- TODO: We need `2a89d89775 orphan-instances: more flexible NetworkTopology --- JSON encoding` in `ouroboros-network-0.23` for `networkTopologyFromJSON` in --- `Ouroboros.Network.OrphanInstances` to implement a drop in replacement using --- `Ouroboros.Network.Diffusion.Topology` API. +-- needed for instance AdjustFilePaths CardanoNetworkTopology +{-# OPTIONS_GHC -Wno-orphans #-} + module Cardano.Node.Configuration.TopologyP2P - ( TopologyError(..) - , NetworkTopology(..) - , PublicRootPeers(..) - , LocalRootPeersGroup(..) - , LocalRootPeersGroups(..) - , RootConfig(..) - , NodeHostIPAddress(..) - , NodeHostIPv4Address(..) - , NodeHostIPv6Address(..) - , NodeSetup(..) - , nodeAddressToSockAddr - , readTopologyFile + ( readTopologyFile , readPeerSnapshotFile , readTopologyFileOrError - , rootConfigToRelayAccessPoint - -- * Re-exports - , DiffusionMode(..) - , PeerAdvertise(..) - , PeerTrustable(..) - , RelayAccessPoint(..) - , UseBootstrapPeers(..) - , UseLedgerPeers(..) ) where import Cardano.Api (handleIOExceptionsLiftWith, liftEither, runExceptT, throwError) import Cardano.Network.ConsensusMode (ConsensusMode (..)) -import Cardano.Network.PeerSelection.Bootstrap (UseBootstrapPeers (..)) -import Cardano.Network.PeerSelection.PeerTrustable (PeerTrustable (..)) -import Cardano.Node.Configuration.NodeAddress import Cardano.Node.Configuration.POM (NodeConfiguration (..)) import Cardano.Node.Startup (StartupTrace (..)) import Cardano.Node.Types import Cardano.Tracing.OrphanInstances.Network () -import Ouroboros.Network.NodeToNode (DiffusionMode (..), PeerAdvertise (..)) import Ouroboros.Network.PeerSelection.LedgerPeers.Type (LedgerPeerSnapshot (..), - UseLedgerPeers (..), RelayAccessPoint (..)) -import Ouroboros.Network.PeerSelection.State.LocalRootPeers (HotValency (..), - WarmValency (..)) + LedgerPeersKind(..), isLedgerPeersEnabled) +import Cardano.Network.PeerSelection.Bootstrap (UseBootstrapPeers (..)) +import Ouroboros.Network.Diffusion.Topology (NetworkTopology(..)) +import Cardano.Network.Diffusion.Topology (CardanoNetworkTopology, isValidTrustedPeerConfiguration) +import Ouroboros.Network.OrphanInstances () -import Control.Applicative (Alternative (..)) import Control.Exception.Safe (Exception (..), IOException, try) import Control.Monad import Control.Monad.IO.Class @@ -65,209 +41,37 @@ import qualified Data.ByteString.Lazy.Char8 as LBS import Data.Maybe (isJust, isNothing) import Data.Text (Text) import qualified Data.Text as Text -import Data.Word (Word64) -import GHC.Generics (Generic) import System.FilePath (takeDirectory, ()) -newtype TopologyError - = NodeIdNotFoundInToplogyFile FilePath - deriving Show - - -data NodeSetup adr = NodeSetup - { nodeId :: !Word64 - , nodeIPv4Address :: !(Maybe NodeIPv4Address) - , nodeIPv6Address :: !(Maybe NodeIPv6Address) - , producers :: ![RootConfig adr] - , useLedger :: !UseLedgerPeers - } deriving (Eq, Show, Generic, Functor, Foldable, Traversable) - -instance FromJSON adr => FromJSON (NodeSetup adr) where - parseJSON = withObject "NodeSetup" $ \o -> - NodeSetup - <$> o .: "nodeId" - <*> o .: "nodeIPv4Address" - <*> o .: "nodeIPv6Address" - <*> o .: "producers" - <*> o .:? "useLedgerAfterSlot" .!= DontUseLedgerPeers - -instance ToJSON adr => ToJSON (NodeSetup adr) where - toJSON ns = - object - [ "nodeId" .= nodeId ns - , "nodeIPv4Address" .= nodeIPv4Address ns - , "nodeIPv6Address" .= nodeIPv6Address ns - , "producers" .= producers ns - , "useLedgerAfterSlot" .= useLedger ns - ] - - --- | Each root peer consists of a list of access points and a shared --- 'PeerAdvertise' field. --- -data RootConfig adr = RootConfig - { rootAccessPoints :: [adr] - -- ^ a list of relay access points, each of which is either an ip address - -- or domain name and a port number. - , rootAdvertise :: PeerAdvertise - -- ^ 'advertise' configures whether the root should be advertised through - -- peer sharing. - } deriving (Eq, Show, Generic, Functor, Foldable, Traversable) - -instance FromJSON adr => FromJSON (RootConfig adr) where - parseJSON = withObject "RootConfig" $ \o -> - RootConfig - <$> o .: "accessPoints" - <*> o .:? "advertise" .!= DoNotAdvertisePeer - -instance ToJSON adr => ToJSON (RootConfig adr) where - toJSON ra = - object - [ "accessPoints" .= rootAccessPoints ra - , "advertise" .= rootAdvertise ra - ] - --- | Transforms a 'RootConfig' into a pair of 'RelayAccessPoint' and its --- corresponding 'PeerAdvertise' value. --- -rootConfigToRelayAccessPoint :: () - => forall adr. RootConfig adr - -> [(adr, PeerAdvertise)] -rootConfigToRelayAccessPoint RootConfig { rootAccessPoints, rootAdvertise } = - [ (accessPoint, rootAdvertise) | accessPoint <- rootAccessPoints ] - - --- | A local root peers group. Local roots are treated by the outbound --- governor in a special way. The node will make sure that a node has the --- requested number ('valency'/'hotValency') of connections to the local root peer group. --- 'warmValency' value is the value of warm/established connections that the node --- will attempt to maintain. By default this value will be equal to 'hotValency'. --- -data LocalRootPeersGroup adr = LocalRootPeersGroup - { localRoots :: RootConfig adr - , hotValency :: HotValency - , warmValency :: WarmValency - , trustable :: PeerTrustable - -- ^ 'trustable' configures whether the root should be trusted in fallback - -- state. - , rootDiffusionMode :: DiffusionMode - -- ^ diffusion mode; used for local root peers. - } deriving (Eq, Show, Generic, Functor, Foldable, Traversable) - --- | Does not use the 'FromJSON' instance of 'RootConfig', so that --- 'accessPoints', 'advertise', 'valency' and 'warmValency' fields are attached to the --- same object. -instance FromJSON adr => FromJSON (LocalRootPeersGroup adr) where - parseJSON = withObject "LocalRootPeersGroup" $ \o -> do - hv@(HotValency v) <- o .: "valency" - <|> o .: "hotValency" - LocalRootPeersGroup - <$> parseJSON (Object o) - <*> pure hv - <*> o .:? "warmValency" .!= WarmValency v - <*> o .:? "trustable" .!= IsNotTrustable - -- deserialise via NodeDiffusionMode - <*> (maybe InitiatorAndResponderDiffusionMode getDiffusionMode - <$> o .:? "diffusionMode") - -instance ToJSON adr => ToJSON (LocalRootPeersGroup adr) where - toJSON lrpg = - object - [ "accessPoints" .= rootAccessPoints (localRoots lrpg) - , "advertise" .= rootAdvertise (localRoots lrpg) - , "hotValency" .= hotValency lrpg - , "warmValency" .= warmValency lrpg - , "trustable" .= trustable lrpg - -- serialise via NodeDiffusionMode - , "diffusionMode" .= NodeDiffusionMode (rootDiffusionMode lrpg) - ] - -newtype LocalRootPeersGroups adr = LocalRootPeersGroups - { groups :: [LocalRootPeersGroup adr] - } deriving (Eq, Show, Generic, Functor, Foldable, Traversable) - -instance FromJSON adr => FromJSON (LocalRootPeersGroups adr) where - parseJSON = fmap LocalRootPeersGroups . parseJSONList - -instance ToJSON adr => ToJSON (LocalRootPeersGroups adr) where - toJSON = toJSONList . groups - -newtype PublicRootPeers adr = PublicRootPeers - { publicRoots :: RootConfig adr - } deriving (Eq, Show, Generic, Functor, Foldable, Traversable) - -instance FromJSON adr => FromJSON (PublicRootPeers adr) where - parseJSON = fmap PublicRootPeers . parseJSON - -instance ToJSON adr => ToJSON (PublicRootPeers adr) where - toJSON = toJSON . publicRoots - --- | Describes the P2P topology of a node. Whenever the node actually runs, --- the type parameter `adr` should be `RelayAccessPoint`. However, we might want to --- use and serialize this type with `adr` being `NodeId`, or another placeholder --- type, if we want the user to be able to edit the topology without knowing the --- actual addresses of the nodes: those might only be knowable at runtime. -data NetworkTopology adr = RealNodeTopology - { ntLocalRootPeersGroups :: !(LocalRootPeersGroups adr) - , ntPublicRootPeers :: ![PublicRootPeers adr] - , ntUseLedgerPeers :: !UseLedgerPeers - , ntUseBootstrapPeers :: !UseBootstrapPeers - , ntPeerSnapshotPath :: !(Maybe PeerSnapshotFile) - } - deriving (Eq, Show, Generic, Functor, Foldable, Traversable) - -instance AdjustFilePaths (NetworkTopology adr) where - adjustFilePaths f nt@(RealNodeTopology _ _ _ _ mPeerSnapshotPath) = - nt{ntPeerSnapshotPath = PeerSnapshotFile . f . unPeerSnapshotFile <$> mPeerSnapshotPath} - -instance FromJSON adr => FromJSON (NetworkTopology adr) where - parseJSON = withObject "NetworkTopology" $ \o -> - RealNodeTopology <$> (o .: "localRoots" ) - <*> (o .: "publicRoots" ) - <*> (o .:? "useLedgerAfterSlot" .!= DontUseLedgerPeers ) - <*> (o .:? "bootstrapPeers" .!= DontUseBootstrapPeers ) - <*> (o .:? "peerSnapshotFile") - -instance ToJSON adr => ToJSON (NetworkTopology adr) where - toJSON top = - case top of - RealNodeTopology { ntLocalRootPeersGroups - , ntPublicRootPeers - , ntUseLedgerPeers - , ntUseBootstrapPeers - , ntPeerSnapshotPath - } -> object [ "localRoots" .= ntLocalRootPeersGroups - , "publicRoots" .= ntPublicRootPeers - , "useLedgerAfterSlot" .= ntUseLedgerPeers - , "bootstrapPeers" .= ntUseBootstrapPeers - , "peerSnapshotFile" .= ntPeerSnapshotPath - ] +instance AdjustFilePaths CardanoNetworkTopology where + adjustFilePaths f nt@NetworkTopology{peerSnapshotPath} = + nt{peerSnapshotPath = f <$> peerSnapshotPath} -- | Read the `NetworkTopology` configuration from the specified file. readTopologyFile :: () - => forall adr. FromJSON adr => NodeConfiguration - -> CT.Tracer IO (StartupTrace blk) -> IO (Either Text (NetworkTopology adr)) -readTopologyFile NodeConfiguration{ncTopologyFile=TopologyFile topologyFilePath, ncConsensusMode, ncProtocolFiles} tracer = runExceptT $ do + -> CT.Tracer IO (StartupTrace blk) -> IO (Either Text CardanoNetworkTopology) +readTopologyFile + NodeConfiguration{ncTopologyFile=TopologyFile topologyFilePath, ncConsensusMode, ncProtocolFiles} tracer = runExceptT $ do bs <- handleIOExceptionsLiftWith handler $ BS.readFile topologyFilePath - topology@RealNodeTopology{ntUseLedgerPeers, ntUseBootstrapPeers, ntPeerSnapshotPath} <- + topology@NetworkTopology{useLedgerPeers, peerSnapshotPath, extraConfig} <- liftEither . first handlerJSON $ eitherDecode $ LBS.fromStrict bs unless (isValidTrustedPeerConfiguration topology) $ throwError handlerBootstrap - when (isBlockProducer && useLedgerPeers ntUseLedgerPeers) $ + when (isBlockProducer && isLedgerPeersEnabled useLedgerPeers) $ liftIO $ CT.traceWith tracer $ NetworkConfigUpdateWarning $ createMsg "Use of ledger peers is not recommended for BP operation" - when (isJust ntPeerSnapshotPath && not (useLedgerPeers ntUseLedgerPeers) && isBlockProducer) $ + when (isJust peerSnapshotPath && not (isLedgerPeersEnabled useLedgerPeers) && isBlockProducer) $ liftIO $ CT.traceWith tracer $ NetworkConfigUpdateInfo $ createMsg "Ledger peers and peer snapshot, although specified in the topology file, are disabled in line with recommended BP operation" - when (inPraosMode && isJust ntPeerSnapshotPath && not (useLedgerPeers ntUseLedgerPeers)) $ + when (inPraosMode && isJust peerSnapshotPath && not (isLedgerPeersEnabled useLedgerPeers)) $ if isBlockProducer then liftIO $ CT.traceWith tracer $ NetworkConfigUpdateWarning @@ -281,12 +85,12 @@ readTopologyFile NodeConfiguration{ncTopologyFile=TopologyFile topologyFilePath, <> "To turn off this message enable the use of ledger peers or remove peerSnapshotFile from the topology file." - when (inGenesisMode && not (useLedgerPeers ntUseLedgerPeers) && not isBlockProducer) $ + when (inGenesisMode && not (isLedgerPeersEnabled useLedgerPeers) && not isBlockProducer) $ liftIO $ CT.traceWith tracer $ NetworkConfigUpdateWarning $ createMsg "It is recommended to use ledger peers and peer snapshot file for relay operations in Genesis mode" - when (inGenesisMode && isNothing ntPeerSnapshotPath && useLedgerPeers ntUseLedgerPeers && not isBlockProducer) $ + when (inGenesisMode && isNothing peerSnapshotPath && isLedgerPeersEnabled useLedgerPeers && not isBlockProducer) $ liftIO $ CT.traceWith tracer $ NetworkConfigUpdateWarning $ createMsg @@ -295,11 +99,11 @@ readTopologyFile NodeConfiguration{ncTopologyFile=TopologyFile topologyFilePath, -- make all relative paths in the topology file relative to the topology file location adjustFilePaths (takeDirectory topologyFilePath ) <$> - if isGenesisCompatible ncConsensusMode ntUseBootstrapPeers + if isGenesisCompatible ncConsensusMode extraConfig then pure topology else do liftIO $ CT.traceWith tracer $ NetworkConfigUpdateWarning genesisIncompatible - pure $ topology{ntUseBootstrapPeers = DontUseBootstrapPeers} + pure $ topology{extraConfig = DontUseBootstrapPeers} where createMsg msg = "Cardano.Node.Configuration.Topology.readTopologyFile: " <> msg @@ -320,7 +124,7 @@ readTopologyFile NodeConfiguration{ncTopologyFile=TopologyFile topologyFilePath, "Bootstrap peers (field 'bootstrapPeers') are not compatible " <> "with Genesis syncing mode, reverting to 'DontUseBootstrapPeers'. " <> "Big ledger peers will be leveraged for decentralized syncing - it " - <> "is recommened to provide an up-to-date big ledger peer snapshot file " + <> "is recommended to provide an up-to-date big ledger peer snapshot file " <> "(field 'peerSnapshotFile' in topology configuration) to facilitate " <> "this process." handlerBootstrap :: Text @@ -330,8 +134,6 @@ readTopologyFile NodeConfiguration{ncTopologyFile=TopologyFile topologyFilePath, , "in bootstrap mode. Make sure you provide at least one bootstrap peer " , "source. " ] - useLedgerPeers DontUseLedgerPeers = False - useLedgerPeers _ = True isGenesisCompatible GenesisMode UseBootstrapPeers{} = False isGenesisCompatible _ _ = True inPraosMode = ncConsensusMode == PraosMode @@ -339,15 +141,14 @@ readTopologyFile NodeConfiguration{ncTopologyFile=TopologyFile topologyFilePath, isBlockProducer = hasProtocolFile ncProtocolFiles readTopologyFileOrError :: () - => forall adr. FromJSON adr - => NodeConfiguration -> CT.Tracer IO (StartupTrace blk) -> IO (NetworkTopology adr) + => NodeConfiguration -> CT.Tracer IO (StartupTrace blk) -> IO CardanoNetworkTopology readTopologyFileOrError nc tr = readTopologyFile nc tr >>= either (\err -> error $ "Cardano.Node.Configuration.TopologyP2P.readTopologyFile: " <> Text.unpack err) pure -readPeerSnapshotFile :: PeerSnapshotFile -> IO (Either Text LedgerPeerSnapshot) +readPeerSnapshotFile :: PeerSnapshotFile -> IO (Either Text (LedgerPeerSnapshot BigLedgerPeers)) readPeerSnapshotFile (PeerSnapshotFile file) = do content <- first renderException <$> try (BS.readFile file) return $ first handler $ content >>= eitherDecodeStrict @@ -359,26 +160,3 @@ readPeerSnapshotFile (PeerSnapshotFile file) = do handler msg = Text.pack $ "Cardano.Node.Configuration.TopologyP2P.readPeerSnapshotFile: " <> msg - --- --- Checking for chance of progress in bootstrap phase --- - --- | This function returns false if non-trustable peers are configured --- -isValidTrustedPeerConfiguration :: NetworkTopology adr -> Bool -isValidTrustedPeerConfiguration (RealNodeTopology (LocalRootPeersGroups lprgs) _ _ ubp _) = - case ubp of - DontUseBootstrapPeers -> True - UseBootstrapPeers [] -> anyTrustable - UseBootstrapPeers (_:_) -> True - where - anyTrustable = - any (\LocalRootPeersGroup {localRoots, trustable} -> - case trustable of - IsNotTrustable -> False - IsTrustable -> not - . null - . rootAccessPoints - $ localRoots - ) lprgs diff --git a/cardano-node/src/Cardano/Node/Orphans.hs b/cardano-node/src/Cardano/Node/Orphans.hs index beee7e97337..aec38fd8358 100644 --- a/cardano-node/src/Cardano/Node/Orphans.hs +++ b/cardano-node/src/Cardano/Node/Orphans.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -7,16 +10,21 @@ module Cardano.Node.Orphans () where -import Cardano.Api () - +import Cardano.Api ( HasTypeProxy (..), HasTextEnvelope (..) + , ToCBOR (..), FromCBOR (..), SerialiseAsCBOR (..) + , Proxy (..)) import Ouroboros.Consensus.Node import Ouroboros.Consensus.Node.Genesis (GenesisConfigFlags (..)) import Ouroboros.Consensus.Storage.LedgerDB.Snapshots (Flag(..)) +import Ouroboros.Consensus.Protocol.Praos.Common (PraosCredentialsSource (..)) import Ouroboros.Network.SizeInBytes (SizeInBytes (..)) +import qualified Cardano.Crypto.KES.Class as Crypto +import Cardano.Protocol.Crypto (StandardCrypto, KES) import Data.Aeson.Types import qualified Data.Text as Text import Text.Printf (PrintfArg (..)) +import Data.String (IsString (..)) deriving instance Eq NodeDatabasePaths deriving instance Show NodeDatabasePaths @@ -48,3 +56,30 @@ instance FromJSON GenesisConfigFlags where <*> v .:? "BucketRate" <*> v .:? "CSJJumpSize" <*> v .:? "GDDRateLimit" + +-- TODO(11.0): move to `ouroboros-consensus` +instance ToCBOR (PraosCredentialsSource StandardCrypto) where + toCBOR = \case + PraosCredentialsUnsound ocert kesKey -> toCBOR (ocert, kesKey) + PraosCredentialsAgent _path -> + error "PraosCredentialsAgent cannot be serialized to CBOR" + +-- TODO(11.0): move to `ouroboros-consensus` +instance FromCBOR (PraosCredentialsSource StandardCrypto) where + fromCBOR = do + (ocert, kesKey) <- fromCBOR + pure $ PraosCredentialsUnsound ocert kesKey + +-- TODO(11.0): consider moving to `cardano-api` +instance SerialiseAsCBOR (PraosCredentialsSource StandardCrypto) + +-- TODO(11.0): consider moving to `cardano-api` +instance HasTypeProxy (PraosCredentialsSource StandardCrypto) where + data AsType (PraosCredentialsSource StandardCrypto) = AsPraosCredentialsSource + proxyToAsType _ = AsPraosCredentialsSource + +-- TODO(11.0): consider moving to `cardano-api` +instance HasTextEnvelope (PraosCredentialsSource StandardCrypto) where + textEnvelopeType _ = + "PraosCredentialsSource_" + <> fromString (Crypto.algorithmNameKES (Proxy @(KES StandardCrypto))) diff --git a/cardano-node/src/Cardano/Node/Parsers.hs b/cardano-node/src/Cardano/Node/Parsers.hs index b6ec0c7441b..5cb756c4858 100644 --- a/cardano-node/src/Cardano/Node/Parsers.hs +++ b/cardano-node/src/Cardano/Node/Parsers.hs @@ -64,7 +64,7 @@ nodeRunParser = do -- Protocol files byronCertFile <- optional parseByronDelegationCert byronKeyFile <- optional parseByronSigningKey - shelleyKESFile <- optional parseKesKeyFilePath + shelleyKESSource <- optional parseKesSourceFilePath shelleyVRFFile <- optional parseVrfKeyFilePath shelleyCertFile <- optional parseOperationalCertFilePath shelleyBulkCredsFile <- optional parseBulkCredsFilePath @@ -99,7 +99,7 @@ nodeRunParser = do , pncProtocolFiles = Last $ Just ProtocolFilepaths { byronCertFile , byronKeyFile - , shelleyKESFile + , shelleyKESSource , shelleyVRFFile , shelleyCertFile , shelleyBulkCredsFile @@ -144,6 +144,8 @@ nodeRunParser = do , pncPeerSharing = mempty , pncGenesisConfigFlags = mempty , pncResponderCoreAffinityPolicy = mempty + , pncTxSubmissionLogicVersion = mempty + , pncTxSubmissionInitDelay = mempty } parseSocketPath :: Text -> Parser SocketPath @@ -380,15 +382,23 @@ parseBulkCredsFilePath = <> completer (bashCompleter "file") ) ---TODO: pass the current KES evolution, not the KES_0 -parseKesKeyFilePath :: Parser FilePath -parseKesKeyFilePath = - strOption - ( long "shelley-kes-key" - <> metavar "FILEPATH" - <> help "Path to the KES signing key." - <> completer (bashCompleter "file") - ) +parseKesSourceFilePath :: Parser KESSource +parseKesSourceFilePath = asum + [ KESKeyFilePath <$> + strOption + ( long "shelley-kes-key" + <> metavar "FILEPATH" + <> help "Path to the KES signing key." + <> completer (bashCompleter "file") + ) + , KESAgentSocketPath <$> + strOption + ( long "shelley-kes-agent-socket" + <> metavar "SOCKET_FILEPATH" + <> help "Path to the KES Agent socket" + <> completer (bashCompleter "file") + ) + ] parseVrfKeyFilePath :: Parser FilePath parseVrfKeyFilePath = diff --git a/cardano-node/src/Cardano/Node/Protocol/Byron.hs b/cardano-node/src/Cardano/Node/Protocol/Byron.hs index 7b53ff28e4c..50155342fd6 100644 --- a/cardano-node/src/Cardano/Node/Protocol/Byron.hs +++ b/cardano-node/src/Cardano/Node/Protocol/Byron.hs @@ -1,5 +1,6 @@ -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE NamedFieldPuns #-} module Cardano.Node.Protocol.Byron @@ -35,12 +36,12 @@ 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 () import Control.Exception import qualified Data.ByteString.Lazy as LB import Data.Maybe (fromMaybe) - ------------------------------------------------------------------------------ -- Byron protocol -- @@ -167,7 +168,7 @@ data ByronProtocolInstantiationError = | SigningKeyFilepathNotSpecified deriving Show -instance Exception ByronProtocolInstantiationError where +instance Exception ByronProtocolInstantiationError where displayException = docToString . prettyError instance Error ByronProtocolInstantiationError where diff --git a/cardano-node/src/Cardano/Node/Protocol/Cardano.hs b/cardano-node/src/Cardano/Node/Protocol/Cardano.hs index e4efea5ab0a..513465bbe65 100644 --- a/cardano-node/src/Cardano/Node/Protocol/Cardano.hs +++ b/cardano-node/src/Cardano/Node/Protocol/Cardano.hs @@ -37,6 +37,7 @@ import qualified Ouroboros.Consensus.Cardano as Consensus import Ouroboros.Consensus.Cardano.Condense () import qualified Ouroboros.Consensus.Cardano.Node as Consensus import Ouroboros.Consensus.HardFork.Combinator.Condense () +import Ouroboros.Consensus.HardFork.Combinator.AcrossEras () import Prelude diff --git a/cardano-node/src/Cardano/Node/Protocol/Shelley.hs b/cardano-node/src/Cardano/Node/Protocol/Shelley.hs index 4cec1a0f8e3..1fa2fc10f15 100644 --- a/cardano-node/src/Cardano/Node/Protocol/Shelley.hs +++ b/cardano-node/src/Cardano/Node/Protocol/Shelley.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} @@ -42,6 +44,8 @@ import qualified Ouroboros.Consensus.Cardano as Consensus import Ouroboros.Consensus.Protocol.Praos.Common (PraosCanBeLeader (..), PraosCredentialsSource (..)) import Ouroboros.Consensus.Shelley.Node (Nonce (..), ProtocolParamsShelleyBased (..), ShelleyLeaderCredentials (..)) +import Ouroboros.Consensus.HardFork.Combinator.AcrossEras () +import Cardano.Node.Orphans () import Control.Exception (IOException) import Control.Monad @@ -51,6 +55,7 @@ import qualified Data.Text as T import System.Directory (getFileSize) import qualified System.IO.MMap as MMap + ------------------------------------------------------------------------------ -- Shelley protocol -- @@ -164,27 +169,38 @@ readLeaderCredentialsSingleton ProtocolFilepaths { shelleyCertFile = Nothing, shelleyVRFFile = Nothing, - shelleyKESFile = Nothing + shelleyKESSource = Nothing } = pure [] -- Or to supply all of the files readLeaderCredentialsSingleton ProtocolFilepaths { shelleyCertFile = Just opCertFile, shelleyVRFFile = Just vrfFile, - shelleyKESFile = Just kesFile + shelleyKESSource = Just kesSource } = do vrfSKey <- firstExceptT FileError (newExceptT $ readFileTextEnvelope (File vrfFile)) - (opCert, kesSKey) <- opCertKesKeyCheck (File kesFile) (File opCertFile) + (credentialsSource, vkey) <- case kesSource of + KESKeyFilePath kesFile -> do + (OperationalCertificate opCert vkey, KesSigningKey kesKey) <- + opCertKesKeyCheck (File kesFile) (File opCertFile) + pure (PraosCredentialsUnsound opCert kesKey, vkey) + + -- TODO: minor yikes: when we're using an agent, we don't check that the + -- opcert and the key provided by the KES agent match, like we do when + -- the key is provided in a file on the command line + KESAgentSocketPath socketFile -> do + OperationalCertificate _ vkey <- firstExceptT FileError $ newExceptT $ readFileTextEnvelope $ File opCertFile + pure (PraosCredentialsAgent socketFile, vkey) - return [mkPraosLeaderCredentials opCert vrfSKey kesSKey] + return [mkPraosLeaderCredentials credentialsSource vkey vrfSKey] -- But not OK to supply some of the files without the others. readLeaderCredentialsSingleton ProtocolFilepaths {shelleyCertFile = Nothing} = left OCertNotSpecified readLeaderCredentialsSingleton ProtocolFilepaths {shelleyVRFFile = Nothing} = left VRFKeyNotSpecified -readLeaderCredentialsSingleton ProtocolFilepaths {shelleyKESFile = Nothing} = +readLeaderCredentialsSingleton ProtocolFilepaths {shelleyKESSource = Nothing} = left KESKeyNotSpecified opCertKesKeyCheck @@ -248,20 +264,20 @@ readLeaderCredentialsBulk ProtocolFilepaths { shelleyBulkCredsFile = mfp } = (teKes, loc "kes") mkPraosLeaderCredentials :: - OperationalCertificate + PraosCredentialsSource StandardCrypto + -> VerificationKey StakePoolKey -> SigningKey VrfKey - -> SigningKey KesKey -> ShelleyLeaderCredentials StandardCrypto mkPraosLeaderCredentials - (OperationalCertificate opcert (StakePoolVerificationKey vkey)) - (VrfSigningKey vrfKey) - (KesSigningKey kesKey) = + credentialsSource + (StakePoolVerificationKey vkey) + (VrfSigningKey vrfKey) = ShelleyLeaderCredentials { shelleyLeaderCredentialsCanBeLeader = PraosCanBeLeader { + praosCanBeLeaderCredentialsSource = credentialsSource, praosCanBeLeaderColdVerKey = coerceKeyRole vkey, - praosCanBeLeaderSignKeyVRF = vrfKey, - praosCanBeLeaderCredentialsSource = PraosCredentialsUnsound opcert kesKey + praosCanBeLeaderSignKeyVRF = vrfKey }, shelleyLeaderCredentialsLabel = "Shelley" } diff --git a/cardano-node/src/Cardano/Node/Protocol/Types.hs b/cardano-node/src/Cardano/Node/Protocol/Types.hs index 26220b9999f..a62c23d4cbf 100644 --- a/cardano-node/src/Cardano/Node/Protocol/Types.hs +++ b/cardano-node/src/Cardano/Node/Protocol/Types.hs @@ -17,6 +17,8 @@ import Cardano.Node.Orphans () import Cardano.Node.Queries (HasKESInfo, HasKESMetricsData) import Cardano.Node.TraceConstraints (TraceConstraints) +import Ouroboros.Network.Block (HeaderHash) + import Control.DeepSeq (NFData) import Data.Aeson import GHC.Generics (Generic) @@ -45,6 +47,8 @@ data SomeConsensusProtocol where , HasKESMetricsData blk , HasKESInfo blk , TraceConstraints blk + , Api.ToCBOR (HeaderHash blk) + , Api.FromCBOR (HeaderHash blk) ) => Api.BlockType blk -> Api.ProtocolInfoArgs blk diff --git a/cardano-node/src/Cardano/Node/Queries.hs b/cardano-node/src/Cardano/Node/Queries.hs index 7bb1c364f3e..dfb5623a290 100644 --- a/cardano-node/src/Cardano/Node/Queries.hs +++ b/cardano-node/src/Cardano/Node/Queries.hs @@ -71,8 +71,8 @@ import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB import Ouroboros.Consensus.TypeFamilyWrappers import Ouroboros.Consensus.Util.Orphans () import qualified Ouroboros.Network.AnchoredFragment as AF -import Ouroboros.Network.NodeToClient (LocalConnectionId) -import Ouroboros.Network.NodeToNode (RemoteAddress, RemoteConnectionId) +import Cardano.Network.NodeToClient (LocalConnectionId) +import Cardano.Network.NodeToNode (RemoteAddress, RemoteConnectionId) import Control.Monad.STM (atomically) import Data.ByteString (ByteString) diff --git a/cardano-node/src/Cardano/Node/Run.hs b/cardano-node/src/Cardano/Node/Run.hs index edc43f58078..2dcedd0e882 100644 --- a/cardano-node/src/Cardano/Node/Run.hs +++ b/cardano-node/src/Cardano/Node/Run.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} @@ -7,6 +8,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE PackageImports #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -64,11 +66,12 @@ 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 qualified Ouroboros.Consensus.Config as Consensus import Ouroboros.Consensus.Config.SupportsNode (ConfigSupportsNode (..)) import Ouroboros.Consensus.Node (SnapshotPolicyArgs (..), - NodeDatabasePaths (..), RunNodeArgs (..), StdRunNodeArgs (..)) + NodeDatabasePaths (..), nonImmutableDbPath, RunNodeArgs (..), StdRunNodeArgs (..)) import Ouroboros.Consensus.Protocol.Praos.AgentClient (KESAgentClientTrace) import Ouroboros.Consensus.Ledger.SupportsMempool (GenTxId) import Ouroboros.Consensus.Node (RunNodeArgs (..), @@ -79,7 +82,6 @@ import Ouroboros.Consensus.Node.NetworkProtocolVersion import Ouroboros.Consensus.Node.ProtocolInfo import qualified Ouroboros.Consensus.Node.Tracers as Consensus import qualified Ouroboros.Consensus.Storage.LedgerDB.Args as LDBArgs -import Ouroboros.Consensus.Storage.LedgerDB.V2.Args import Ouroboros.Consensus.Util.Args import Ouroboros.Consensus.Util.Orphans () @@ -100,23 +102,27 @@ import qualified Cardano.Network.PeerSelection.Governor.PeerSelectionActions as import qualified Cardano.Network.LedgerPeerConsensusInterface as Cardano import qualified Cardano.Network.PeerSelection.PeerSelectionActions as Cardano import qualified Cardano.Network.PeerSelection.Churn as Cardano.Churn -import Cardano.Network.Types (NumberOfBigLedgerPeers (..)) +import Cardano.Network.PeerSelection (NumberOfBigLedgerPeers (..), PeerAdvertise(..)) +import Ouroboros.Network.Diffusion.Topology (NetworkTopology(..), producerAddresses) +import Ouroboros.Network.Block (pattern BlockPoint, pattern GenesisPoint, HeaderHash, atSlot, withHash) import Ouroboros.Network.BlockFetch (FetchMode) import qualified Ouroboros.Network.Diffusion as Diffusion import qualified Ouroboros.Network.Diffusion.Types as Diffusion import qualified Ouroboros.Network.Diffusion.Configuration as Configuration +import Ouroboros.Network.Magic import Ouroboros.Network.Mux (noBindForkPolicy, responderForkPolicy, ForkPolicy) -import Ouroboros.Network.NodeToClient (LocalAddress (..), LocalSocket (..)) -import Ouroboros.Network.NodeToNode (AcceptedConnectionsLimit (..), ConnectionId, +import Cardano.Network.NodeToClient (LocalAddress (..), LocalSocket (..)) +import Cardano.Network.NodeToNode (AcceptedConnectionsLimit (..), ConnectionId, PeerSelectionTargets (..), RemoteAddress) import Ouroboros.Network.PeerSelection.Governor.Types (PeerSelectionState, PublicPeerSelectionState, makePublicPeerSelectionStateVar, BootstrapPeersCriticalTimeoutError) import Ouroboros.Network.PeerSelection.LedgerPeers.Type (LedgerPeerSnapshot (..), - UseLedgerPeers (..), AfterSlot (..)) + UseLedgerPeers (..), AfterSlot (..), LedgerPeersKind(..)) import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing (..)) import Ouroboros.Network.PeerSelection.RelayAccessPoint (RelayAccessPoint (..)) import Ouroboros.Network.PeerSelection.RootPeersDNS.PublicRootPeers (TracePublicRootPeers) +import Ouroboros.Network.ConnectionManager.Types (Provenance (..)) import Ouroboros.Network.PeerSelection.State.LocalRootPeers (HotValency, LocalRootConfig (..), WarmValency) import Ouroboros.Network.Protocol.ChainSync.Codec @@ -261,7 +267,7 @@ handleNodeWithTracers cmdPc nc p@(SomeConsensusProtocol blockType runP) = do then DisabledBlockForging else EnabledBlockForging)) - handleSimpleNode blockType runP tracers nc + handleSimpleNode blockType runP tracers nc networkMagic (\nk -> do setNodeKernel nodeKernelData nk traceWith (nodeStateTracer tracers) NodeKernelOnline) @@ -307,7 +313,7 @@ handleNodeWithTracers cmdPc nc p@(SomeConsensusProtocol blockType runP) = do -- We ignore peer logging thread if it dies, but it will be killed -- when 'handleSimpleNode' terminates. - handleSimpleNode blockType runP tracers nc + handleSimpleNode blockType runP tracers nc networkMagic (\nk -> do setNodeKernel nodeKernelData nk traceWith (nodeStateTracer tracers) NodeKernelOnline) @@ -380,12 +386,13 @@ handleSimpleNode -> Api.ProtocolInfoArgs blk -> Tracers RemoteAddress LocalAddress blk IO -> NodeConfiguration + -> NetworkMagic -> (NodeKernel IO RemoteAddress LocalConnectionId blk -> IO ()) -- ^ Called on the 'NodeKernel' after creating it, but before the network -- layer is initialised. This implies this function must not block, -- otherwise the node won't actually start. -> IO () -handleSimpleNode blockType runP tracers nc onKernel = do +handleSimpleNode blockType runP tracers nc networkMagic onKernel = do logStartupWarnings logDeprecatedLedgerDBOptions @@ -431,17 +438,17 @@ handleSimpleNode blockType runP tracers nc onKernel = do withShutdownHandling (ncShutdownConfig nc) (shutdownTracer tracers) $ do traceWith (startupTracer tracers) (StartupP2PInfo (ncDiffusionMode nc)) - nt@TopologyP2P.RealNodeTopology - { ntUseLedgerPeers - , ntUseBootstrapPeers - , ntPeerSnapshotPath + nt@NetworkTopology + { useLedgerPeers + , peerSnapshotPath + , extraConfig } <- TopologyP2P.readTopologyFileOrError nc (startupTracer tracers) let (localRoots, publicRoots) = producerAddresses nt traceWith (startupTracer tracers) $ NetworkConfig localRoots publicRoots - ntUseLedgerPeers - ntPeerSnapshotPath + useLedgerPeers + (PeerSnapshotFile <$> peerSnapshotPath) case ncPeerSharing nc of PeerSharingEnabled | hasProtocolFile (ncProtocolFiles nc) -> @@ -451,12 +458,13 @@ handleSimpleNode blockType runP tracers nc onKernel = do _otherwise -> pure () localRootsVar <- newTVarIO localRoots publicRootsVar <- newTVarIO publicRoots - useLedgerVar <- newTVarIO ntUseLedgerPeers - useBootstrapVar <- newTVarIO ntUseBootstrapPeers - ledgerPeerSnapshotPathVar <- newTVarIO ntPeerSnapshotPath + useLedgerVar <- newTVarIO useLedgerPeers + useBootstrapVar <- newTVarIO extraConfig + ledgerPeerSnapshotPathVar <- newTVarIO (PeerSnapshotFile <$> peerSnapshotPath) ledgerPeerSnapshotVar <- newTVarIO =<< updateLedgerPeerSnapshot (startupTracer tracers) nc + networkMagic (readTVar ledgerPeerSnapshotPathVar) (readTVar useLedgerVar) (const . pure $ ()) @@ -487,6 +495,9 @@ handleSimpleNode blockType runP tracers nc onKernel = do onKernel nodeKernel , rnPeerSharing = ncPeerSharing nc , rnGetUseBootstrapPeers = readTVar useBootstrapVar + , rnTxSubmissionLogicVersion = ncTxSubmissionLogicVersion nc + , rnTxSubmissionInitDelay = ncTxSubmissionInitDelay nc + , rnFeatureFlags = mempty -- TODO(10.7) forward this to CLI options? } #ifdef UNIX -- initial `SIGHUP` handler, which only rereads the topology file but @@ -502,6 +513,7 @@ handleSimpleNode blockType runP tracers nc onKernel = do void $ updateLedgerPeerSnapshot (startupTracer tracers) nc + networkMagic (readTVar ledgerPeerSnapshotPathVar) (readTVar useLedgerVar) (writeTVar ledgerPeerSnapshotVar) @@ -515,7 +527,7 @@ handleSimpleNode blockType runP tracers nc onKernel = do let diffusionNodeArguments :: Cardano.Diffusion.CardanoNodeArguments IO diffusionNodeArguments = Cardano.Diffusion.CardanoNodeArguments { Cardano.Diffusion.consensusMode = ncConsensusMode nc, - Cardano.Diffusion.genesisPeerTargets = + Cardano.Diffusion.genesisPeerSelectionTargets = PeerSelectionTargets { targetNumberOfRootPeers = ncSyncTargetOfRootPeers nc, targetNumberOfKnownPeers = ncSyncTargetOfKnownPeers nc, @@ -547,9 +559,9 @@ handleSimpleNode blockType runP tracers nc onKernel = do nodeArgs { rnNodeKernelHook = \registry nodeKernel -> do -- reinstall `SIGHUP` handler - installSigHUPHandler (startupTracer tracers) (Consensus.kesAgentTracer $ consensusTracers tracers) blockType nc nodeKernel - localRootsVar publicRootsVar useLedgerVar useBootstrapVar - ledgerPeerSnapshotPathVar ledgerPeerSnapshotVar + installSigHUPHandler (startupTracer tracers) (Consensus.kesAgentTracer $ consensusTracers tracers) + blockType nc networkMagic nodeKernel localRootsVar publicRootsVar useLedgerVar + useBootstrapVar ledgerPeerSnapshotPathVar ledgerPeerSnapshotVar rnNodeKernelHook nodeArgs registry nodeKernel } StdRunNodeArgs @@ -566,7 +578,7 @@ handleSimpleNode blockType runP tracers nc onKernel = do , srnChainSyncIdleTimeout = customizeChainSyncTimeout , srnSnapshotPolicyArgs = snapshotPolicyArgs , srnQueryBatchSize = queryBatchSize - , srnLdbFlavorArgs = selectorToArgs ldbBackend + , srnLedgerDbBackendArgs = selectorToArgs ldbBackend (nonImmutableDbPath dbPath) } where customizeChainSyncTimeout :: ChainSyncIdleTimeout @@ -643,19 +655,20 @@ installSigHUPHandler :: Tracer IO (StartupTrace blk) -> Tracer IO KESAgentClientTrace -> Api.BlockType blk -> NodeConfiguration + -> NetworkMagic -> NodeKernel IO RemoteAddress (ConnectionId LocalAddress) blk -> StrictTVar IO [(HotValency, WarmValency, Map RelayAccessPoint (LocalRootConfig PeerTrustable))] -> StrictTVar IO (Map RelayAccessPoint PeerAdvertise) -> StrictTVar IO UseLedgerPeers -> StrictTVar IO UseBootstrapPeers -> StrictTVar IO (Maybe PeerSnapshotFile) - -> StrictTVar IO (Maybe LedgerPeerSnapshot) + -> StrictTVar IO (Maybe (LedgerPeerSnapshot BigLedgerPeers)) -> IO () #ifndef UNIX -installSigHUPHandler _ _ _ _ _ _ _ _ _ _ _ = return () +installSigHUPHandler _ _ _ _ _ _ _ _ _ _ _ _ = return () #else -installSigHUPHandler startupTracer kesAgentTracer blockType nc nodeKernel localRootsVar publicRootsVar useLedgerVar - useBootstrapPeersVar ledgerPeerSnapshotPathVar ledgerPeerSnapshotVar = +installSigHUPHandler startupTracer kesAgentTracer blockType nc networkMagic nodeKernel localRootsVar + publicRootsVar useLedgerVar useBootstrapPeersVar ledgerPeerSnapshotPathVar ledgerPeerSnapshotVar = void $ Signals.installHandler Signals.sigHUP (Signals.Catch $ do @@ -665,6 +678,7 @@ installSigHUPHandler startupTracer kesAgentTracer blockType nc nodeKernel localR void $ updateLedgerPeerSnapshot startupTracer nc + networkMagic (readTVar ledgerPeerSnapshotPathVar) (readTVar useLedgerVar) (writeTVar ledgerPeerSnapshotVar) @@ -743,28 +757,31 @@ updateTopologyConfiguration startupTracer nc localRootsVar publicRootsVar useLed traceWith startupTracer $ NetworkConfigUpdateError $ pack "Error reading topology configuration file:" <> err - Right nt@RealNodeTopology { ntUseLedgerPeers - , ntUseBootstrapPeers - , ntPeerSnapshotPath + Right nt@NetworkTopology { useLedgerPeers + , peerSnapshotPath + , extraConfig } -> do let (localRoots, publicRoots) = producerAddresses nt traceWith startupTracer - $ NetworkConfig localRoots publicRoots ntUseLedgerPeers ntPeerSnapshotPath + $ NetworkConfig localRoots publicRoots useLedgerPeers (PeerSnapshotFile <$> peerSnapshotPath) atomically $ do writeTVar localRootsVar localRoots writeTVar publicRootsVar publicRoots - writeTVar useLedgerVar ntUseLedgerPeers - writeTVar useBootsrapPeersVar ntUseBootstrapPeers - writeTVar ledgerPeerSnapshotPathVar ntPeerSnapshotPath + writeTVar useLedgerVar useLedgerPeers + writeTVar useBootsrapPeersVar extraConfig + writeTVar ledgerPeerSnapshotPathVar (PeerSnapshotFile <$> peerSnapshotPath) #endif updateLedgerPeerSnapshot :: Tracer IO (StartupTrace blk) -> NodeConfiguration + -> NetworkMagic -> STM IO (Maybe PeerSnapshotFile) -> STM IO UseLedgerPeers - -> (Maybe LedgerPeerSnapshot -> STM IO ()) - -> IO (Maybe LedgerPeerSnapshot) -updateLedgerPeerSnapshot startupTracer (NodeConfiguration {ncConsensusMode}) readLedgerPeerPath readUseLedgerVar writeVar = do + -> (Maybe (LedgerPeerSnapshot BigLedgerPeers) -> STM IO ()) + -> IO (Maybe (LedgerPeerSnapshot BigLedgerPeers)) +updateLedgerPeerSnapshot startupTracer + (NodeConfiguration {ncConsensusMode}) + networkMagic readLedgerPeerPath readUseLedgerVar writeVar = do (mPeerSnapshotFile, useLedgerPeers) <- atomically $ (,) <$> readLedgerPeerPath <*> readUseLedgerVar @@ -778,30 +795,32 @@ updateLedgerPeerSnapshot startupTracer (NodeConfiguration {ncConsensusMode}) rea snapshotFile <- hoistMaybe mPeerSnapshotFile eSnapshot <- liftIO $ readPeerSnapshotFile snapshotFile - lps@(LedgerPeerSnapshot (wOrigin, _)) <- - case ncConsensusMode of - GenesisMode -> - MaybeT $ hushM eSnapshot (trace . NetworkConfigUpdateError) - PraosMode -> - MaybeT $ hushM eSnapshot (trace . NetworkConfigUpdateWarning) + lps <- case eSnapshot of + Left e -> do + case ncConsensusMode of + GenesisMode -> error $ Text.unpack e + PraosMode -> empty <$ traceL $ NetworkConfigUpdateError e + Right lps -> pure lps + fileSlot <- case lps of + LedgerBigPeerSnapshotV23 pt magic _pools + | networkMagic == magic, BlockPoint { atSlot } <- pt -> pure atSlot + | GenesisPoint <- pt -> + error "GenesisPoint is not a valid value in the peer snapshot file" + | otherwise -> error $ + "NetworkMagic " <> show networkMagic <> " doesn't match " + <> "peer snapshot NetworkMagic " <> show magic + LedgerPeerSnapshotV2 {} -> + error "Unsupported legacy peer snapshot version." case afterSlot of Always -> do - traceL $ LedgerPeerSnapshotLoaded wOrigin + traceL $ LedgerPeerSnapshotLoaded fileSlot return lps After ledgerSlotNo | fileSlot >= ledgerSlotNo -> do - traceL $ LedgerPeerSnapshotLoaded wOrigin + traceL $ LedgerPeerSnapshotLoaded fileSlot pure lps | otherwise -> do - case ncConsensusMode of - GenesisMode -> do - traceL $ LedgerPeerSnapshotError ledgerSlotNo fileSlot snapshotFile - liftIO $ throwIO (LedgerPeerSnapshotTooOld ledgerSlotNo fileSlot snapshotFile) - PraosMode -> do - traceL $ LedgerPeerSnapshotIgnored ledgerSlotNo fileSlot snapshotFile - empty - where - fileSlot = case wOrigin of; Origin -> 0; At slot -> slot + liftIO . throwIO $ LedgerPeerSnapshotTooOld ledgerSlotNo fileSlot snapshotFile mLedgerPeerSnapshot <$ atomically (writeVar mLedgerPeerSnapshot) @@ -874,7 +893,7 @@ mkDiffusionConfiguration -- valency of its group. -> STM IO (Map RelayAccessPoint PeerAdvertise) -> STM IO UseLedgerPeers - -> STM IO (Maybe LedgerPeerSnapshot) + -> STM IO (Maybe (LedgerPeerSnapshot BigLedgerPeers)) -> NodeConfiguration -> Cardano.Diffusion.CardanoConfiguration IO mkDiffusionConfiguration @@ -932,36 +951,3 @@ mkDiffusionConfiguration targetNumberOfEstablishedBigLedgerPeers = ncDeadlineTargetOfEstablishedBigLedgerPeers nc, targetNumberOfActiveBigLedgerPeers = ncDeadlineTargetOfActiveBigLedgerPeers nc } - - -producerAddresses - :: NetworkTopology RelayAccessPoint - -> ( [(HotValency, WarmValency, Map RelayAccessPoint (LocalRootConfig PeerTrustable))] - , Map RelayAccessPoint PeerAdvertise - ) - -- ^ local roots & public roots -producerAddresses RealNodeTopology { ntLocalRootPeersGroups - , ntPublicRootPeers - } = - ( map (\lrp -> ( hotValency lrp - , warmValency lrp - , Map.fromList - . map (\(addr, peerAdvertise) -> - ( addr - , LocalRootConfig { - diffusionMode = rootDiffusionMode lrp, - peerAdvertise, - extraFlags = trustable lrp - } - ) - ) - . rootConfigToRelayAccessPoint - $ localRoots lrp - ) - ) - (groups ntLocalRootPeersGroups) - , foldMap ( Map.fromList - . rootConfigToRelayAccessPoint - . publicRoots - ) ntPublicRootPeers - ) diff --git a/cardano-node/src/Cardano/Node/Startup.hs b/cardano-node/src/Cardano/Node/Startup.hs index e6ec33a8d74..1be1c443c4d 100644 --- a/cardano-node/src/Cardano/Node/Startup.hs +++ b/cardano-node/src/Cardano/Node/Startup.hs @@ -28,7 +28,7 @@ import Cardano.Node.Configuration.Socket import Cardano.Node.Protocol (ProtocolInstantiationError) import Cardano.Node.Protocol.Types (SomeConsensusProtocol (..)) import Cardano.Node.Types (PeerSnapshotFile (..)) -import Cardano.Slotting.Slot (SlotNo, WithOrigin) +import Cardano.Slotting.Slot (SlotNo) import qualified Ouroboros.Consensus.BlockchainTime.WallClock.Types as WCT import Ouroboros.Consensus.Cardano.Block import Ouroboros.Consensus.Cardano.CanHardFork (shelleyLedgerConfig) @@ -40,8 +40,8 @@ import Ouroboros.Consensus.Node.NetworkProtocolVersion (BlockNodeToCli BlockNodeToNodeVersion) import Ouroboros.Consensus.Shelley.Ledger.Ledger (shelleyLedgerGenesis) import Ouroboros.Network.Magic (NetworkMagic (..)) -import Ouroboros.Network.NodeToClient (NodeToClientVersion) -import Ouroboros.Network.NodeToNode (DiffusionMode (..), NodeToNodeVersion, PeerAdvertise) +import Cardano.Network.NodeToClient (NodeToClientVersion) +import Cardano.Network.NodeToNode (DiffusionMode (..), NodeToNodeVersion, PeerAdvertise) import Ouroboros.Network.PeerSelection.LedgerPeers.Type (UseLedgerPeers) import Ouroboros.Network.PeerSelection.RelayAccessPoint (RelayAccessPoint) import Ouroboros.Network.PeerSelection.State.LocalRootPeers (HotValency, WarmValency) @@ -140,13 +140,7 @@ data StartupTrace blk = | BIShelley BasicInfoShelleyBased | BIByron BasicInfoByron | BINetwork BasicInfoNetwork - | LedgerPeerSnapshotLoaded (WithOrigin SlotNo) - -- | Ledger peer snapshot ignored since the peer snapshot slot is older than - -- `UseLedgerPeers` in the topology file. Arguments are: - -- useLedgerPeersAfterSlot, peerSnapshotSlot, peerSnapshotFile. - | LedgerPeerSnapshotIgnored SlotNo SlotNo PeerSnapshotFile - -- | Like above, but in `GenesisMode` it is an error to have an old snapshot. - | LedgerPeerSnapshotError SlotNo SlotNo PeerSnapshotFile + | LedgerPeerSnapshotLoaded SlotNo | MovedTopLevelOption String data LedgerPeerSnapshotError = LedgerPeerSnapshotTooOld SlotNo SlotNo PeerSnapshotFile diff --git a/cardano-node/src/Cardano/Node/TraceConstraints.hs b/cardano-node/src/Cardano/Node/TraceConstraints.hs index 59c84b7bb34..a17e7bf3772 100644 --- a/cardano-node/src/Cardano/Node/TraceConstraints.hs +++ b/cardano-node/src/Cardano/Node/TraceConstraints.hs @@ -17,7 +17,7 @@ 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) + GetHeader, HasHeader, Header, HeaderHash) import Ouroboros.Consensus.HeaderValidation (OtherHeaderEnvelopeError) import Ouroboros.Consensus.Ledger.Abstract (LedgerError) import Ouroboros.Consensus.Ledger.Inspect (LedgerEvent, LedgerUpdate, LedgerWarning) @@ -25,7 +25,8 @@ import Ouroboros.Consensus.Ledger.SupportsMempool (ApplyTxErr, HasTxId import Ouroboros.Consensus.Node.NetworkProtocolVersion (HasNetworkProtocolVersion (BlockNodeToClientVersion, BlockNodeToNodeVersion)) import Ouroboros.Consensus.Node.Run (RunNode, SerialiseNodeToNodeConstraints) -import Ouroboros.Consensus.Protocol.Abstract (SelectView, ValidationErr) +import Ouroboros.Consensus.Peras.SelectView +import Ouroboros.Consensus.Protocol.Abstract (SelectView, ValidationErr, SelectViewReasonForSwitch, ReasonForSwitch, TiebreakerView) import Ouroboros.Consensus.Shelley.Ledger.Mempool (GenTx, TxId) import Ouroboros.Network.Block (Serialised) @@ -53,13 +54,14 @@ type TraceConstraints blk = , ToObject (LedgerError blk) , ToObject (LedgerEvent blk) , ToObject (OtherHeaderEnvelopeError blk) - , ToObject (SelectView (BlockProtocol 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) , LogFormatting (GenTx blk) @@ -68,10 +70,12 @@ type TraceConstraints blk = , LogFormatting (LedgerUpdate blk) , LogFormatting (LedgerWarning blk) , LogFormatting (OtherHeaderEnvelopeError blk) - , LogFormatting (SelectView (BlockProtocol blk)) + , LogFormatting (WeightedSelectView (BlockProtocol blk)) , LogFormatting (ValidationErr (BlockProtocol blk)) , LogFormatting (CannotForge blk) , LogFormatting (ForgeStateUpdateError blk) - , LogFormatting (Set (Credential 'Staking)) - , LogFormatting (NonEmpty.NonEmpty (KeyHash 'Staking)) + , LogFormatting (Set (Credential Staking)) + , LogFormatting (NonEmpty.NonEmpty (KeyHash Staking)) + , LogFormatting (Either (WithEmptyFragmentReasonForSwitch (WeightedSelectView (BlockProtocol blk))) (SelectViewReasonForSwitch (BlockProtocol blk))) + , LogFormatting (ReasonForSwitch (TiebreakerView (BlockProtocol blk))) ) diff --git a/cardano-node/src/Cardano/Node/Tracing/API.hs b/cardano-node/src/Cardano/Node/Tracing/API.hs index e33d1c88915..26bf2ca58b0 100644 --- a/cardano-node/src/Cardano/Node/Tracing/API.hs +++ b/cardano-node/src/Cardano/Node/Tracing/API.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MonoLocalBinds #-} @@ -32,8 +33,8 @@ import Ouroboros.Consensus.Node.GSM import Ouroboros.Network.Block import Ouroboros.Network.ConnectionId (ConnectionId) import Ouroboros.Network.Magic (NetworkMagic) -import Ouroboros.Network.NodeToClient (LocalAddress, withIOManager) -import Ouroboros.Network.NodeToNode (RemoteAddress) +import Cardano.Network.NodeToClient (LocalAddress, withIOManager) +import Cardano.Network.NodeToNode (RemoteAddress) import Prelude diff --git a/cardano-node/src/Cardano/Node/Tracing/Consistency.hs b/cardano-node/src/Cardano/Node/Tracing/Consistency.hs index 8f1a4f3da4c..0bf208a34ad 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Consistency.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Consistency.hs @@ -16,6 +16,11 @@ module Cardano.Node.Tracing.Consistency import Cardano.Logging import Cardano.Logging.Resources import Cardano.Logging.Resources.Types () +import Cardano.Network.NodeToNode (RemoteAddress) +import qualified Cardano.Network.NodeToNode as NtN +import qualified Cardano.Network.PeerSelection.ExtraRootPeers as Cardano.PublicRootPeers +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.Handlers.Shutdown (ShutdownTrace) import Cardano.Node.Startup @@ -25,18 +30,13 @@ import Cardano.Node.Tracing.Formatting () import qualified Cardano.Node.Tracing.StateRep as SR import Cardano.Node.Tracing.Tracers.BlockReplayProgress import Cardano.Node.Tracing.Tracers.ConsensusStartupException -import Cardano.Node.Tracing.Tracers.Diffusion () import Cardano.Node.Tracing.Tracers.KESInfo () import Cardano.Node.Tracing.Tracers.LedgerMetrics (LedgerMetrics) import Cardano.Node.Tracing.Tracers.NodeToClient () import Cardano.Node.Tracing.Tracers.NodeToNode () import Cardano.Node.Tracing.Tracers.NodeVersion (NodeVersionTrace) -import Cardano.Node.Tracing.Tracers.P2P () import Cardano.Node.Tracing.Tracers.Shutdown () import Cardano.Node.Tracing.Tracers.Startup () -import qualified Cardano.Network.PeerSelection.Governor.PeerSelectionState as Cardano -import qualified Cardano.Network.PeerSelection.Governor.Types as Cardano -import qualified Cardano.Network.PeerSelection.ExtraRootPeers as Cardano.PublicRootPeers import Ouroboros.Consensus.Block.SupportsSanityCheck (SanityCheckIssue) import Ouroboros.Consensus.BlockchainTime.WallClock.Types (RelativeTime) import Ouroboros.Consensus.BlockchainTime.WallClock.Util (TraceBlockchainTimeEvent (..)) @@ -68,17 +68,14 @@ import Ouroboros.Network.Driver.Simple (TraceSendRecv) import qualified Ouroboros.Network.Driver.Stateful as Stateful (TraceSendRecv) import qualified Ouroboros.Network.InboundGovernor as InboundGovernor import Ouroboros.Network.KeepAlive (TraceKeepAliveClient (..)) -import qualified Ouroboros.Network.NodeToClient as NtC -import Ouroboros.Network.NodeToNode (RemoteAddress) -import qualified Ouroboros.Network.NodeToNode as NtN -import Ouroboros.Network.PeerSelection.Churn (ChurnCounters) import Ouroboros.Network.PeerSelection.Governor (DebugPeerSelection (..), - PeerSelectionCounters, TracePeerSelection (..)) + PeerSelectionCounters) +import Ouroboros.Network.PeerSelection.Governor.Types (TracePeerSelection) import Ouroboros.Network.PeerSelection.LedgerPeers (TraceLedgerPeers) 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.DNSActions (DNSTrace (..)) import Ouroboros.Network.PeerSelection.RootPeersDNS.PublicRootPeers (TracePublicRootPeers (..)) import Ouroboros.Network.Protocol.BlockFetch.Type (BlockFetch) @@ -92,11 +89,16 @@ import qualified Ouroboros.Network.Protocol.LocalTxSubmission.Type as LTS import Ouroboros.Network.Protocol.TxSubmission2.Type (TxSubmission2) import qualified Ouroboros.Network.Server as Server (Trace (..)) import Ouroboros.Network.Snocket (LocalAddress (..)) -import Ouroboros.Network.TxSubmission.Inbound (TraceTxSubmissionInbound) +import Ouroboros.Network.TxSubmission.Inbound.V2 (TraceTxSubmissionInbound) import Ouroboros.Network.TxSubmission.Outbound (TraceTxSubmissionOutbound) +import Ouroboros.Network.Tracing.PeerSelection () +import Cardano.Network.Tracing.PeerSelection () +import Cardano.Network.Tracing.PeerSelectionCounters () +import qualified Codec.CBOR.Term as CBOR import qualified Data.Text as T import qualified Network.Mux as Mux +import Network.Mux.Tracing () import qualified Network.Socket as Socket @@ -283,12 +285,12 @@ getAllNamespaces = dtHandshakeNS = map (nsGetTuple . nsReplacePrefix ["Net", "Handshake", "Remote"]) (allNamespaces :: [Namespace - (NtN.HandshakeTr NtN.RemoteAddress NtN.NodeToNodeVersion)]) + (Mux.WithBearer (ConnectionId ntnAddr) (TraceSendRecv (NtN.Handshake ntnVersion CBOR.Term)))]) + dtLocalHandshakeNS = map (nsGetTuple . nsReplacePrefix ["Net", "Handshake", "Local"]) (allNamespaces :: [Namespace - (NtC.HandshakeTr LocalAddress - NtC.NodeToClientVersion)]) + (Mux.WithBearer (ConnectionId ntcAddr) (TraceSendRecv (NtN.Handshake ntcVersion CBOR.Term)))]) dtDiffusionInitializationNS = map (nsGetTuple . nsReplacePrefix ["Startup", "DiffusionInit"]) (allNamespaces :: [Namespace @@ -322,10 +324,7 @@ getAllNamespaces = peerSelectionCountersNS = map (nsGetTuple . nsReplacePrefix ["Net", "PeerSelection", "Counters"]) (allNamespaces :: [Namespace - (PeerSelectionCounters (Cardano.ExtraPeerSelectionSetsWithSizes Socket.SockAddr))]) - churnCountersNS = map (nsGetTuple . nsReplacePrefix - ["Net", "Churn"]) - (allNamespaces :: [Namespace ChurnCounters]) + (PeerSelectionCounters (Cardano.ViewExtraPeers (Cardano.PublicRootPeers.ExtraPeers Socket.SockAddr)))]) peerSelectionActionsNS = map (nsGetTuple . nsReplacePrefix ["Net", "PeerSelection", "Actions"]) (allNamespaces :: [Namespace @@ -440,7 +439,6 @@ getAllNamespaces = <> debugPeerSelectionNS <> debugPeerSelectionResponderNS <> peerSelectionCountersNS - <> churnCountersNS <> peerSelectionActionsNS <> connectionManagerNS <> connectionManagerTransitionsNS diff --git a/cardano-node/src/Cardano/Node/Tracing/Documentation.hs b/cardano-node/src/Cardano/Node/Tracing/Documentation.hs index 1658bed634d..f5653d99ebb 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Documentation.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Documentation.hs @@ -1,9 +1,9 @@ +{-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} @@ -20,6 +20,11 @@ module Cardano.Node.Tracing.Documentation , docTracersFirstPhase ) where +import Ouroboros.Network.Tracing.TxSubmission.Inbound () +import Ouroboros.Network.Tracing.TxSubmission.Outbound () +import Ouroboros.Network.Tracing.PeerSelection () +import Cardano.Network.Tracing.PeerSelection () +import Cardano.Network.Tracing.PeerSelectionCounters () import Cardano.Git.Rev (gitRev) import Cardano.Logging as Logging import Cardano.Logging.Resources @@ -27,7 +32,6 @@ import Cardano.Logging.Resources.Types () import Cardano.Network.PeerSelection.PeerTrustable (PeerTrustable (..)) import Cardano.Node.Handlers.Shutdown (ShutdownTrace) import Cardano.Node.Startup -import Cardano.Node.TraceConstraints import Cardano.Node.Tracing.DefaultTraceConfig (defaultCardanoConfig) import Cardano.Node.Tracing.Formatting () import Cardano.Node.Tracing.NodeInfo () @@ -37,14 +41,12 @@ import Cardano.Node.Tracing.Tracers.BlockReplayProgress import Cardano.Node.Tracing.Tracers.ChainDB import Cardano.Node.Tracing.Tracers.Consensus import Cardano.Node.Tracing.Tracers.ConsensusStartupException -import Cardano.Node.Tracing.Tracers.Diffusion () import Cardano.Node.Tracing.Tracers.ForgingStats (ForgingStats) import Cardano.Node.Tracing.Tracers.KESInfo () import Cardano.Node.Tracing.Tracers.LedgerMetrics (LedgerMetrics) import Cardano.Node.Tracing.Tracers.NodeToClient () import Cardano.Node.Tracing.Tracers.NodeToNode () import Cardano.Node.Tracing.Tracers.NodeVersion (NodeVersionTrace) -import Cardano.Node.Tracing.Tracers.P2P () import Cardano.Node.Tracing.Tracers.Shutdown () import Cardano.Node.Tracing.Tracers.Startup () import qualified Cardano.Network.PeerSelection.Governor.PeerSelectionState as Cardano @@ -82,11 +84,10 @@ import Ouroboros.Network.Driver.Simple (TraceSendRecv) import qualified Ouroboros.Network.Driver.Stateful as Stateful (TraceSendRecv) import qualified Ouroboros.Network.InboundGovernor as InboundGovernor import Ouroboros.Network.KeepAlive (TraceKeepAliveClient (..)) -import Ouroboros.Network.NodeToNode (RemoteAddress) -import qualified Ouroboros.Network.NodeToNode as NtN -import Ouroboros.Network.PeerSelection.Churn (ChurnCounters (..)) +import Cardano.Network.NodeToNode (RemoteAddress) +import qualified Cardano.Network.NodeToNode as NtN import Ouroboros.Network.PeerSelection.Governor (DebugPeerSelection (..), - PeerSelectionCounters, TracePeerSelection (..)) + PeerSelectionCounters, TracePeerSelection) import Ouroboros.Network.PeerSelection.LedgerPeers (TraceLedgerPeers) import Ouroboros.Network.PeerSelection.PeerStateActions (PeerSelectionActionsTrace (..)) import Ouroboros.Network.PeerSelection.RootPeersDNS.LocalRootPeers @@ -104,8 +105,11 @@ import qualified Ouroboros.Network.Protocol.LocalTxSubmission.Type as LTS import Ouroboros.Network.Protocol.TxSubmission2.Type (TxSubmission2) import qualified Ouroboros.Network.Server as Server (Trace (..)) import Ouroboros.Network.Snocket (LocalAddress (..)) -import Ouroboros.Network.TxSubmission.Inbound (TraceTxSubmissionInbound) +import Ouroboros.Network.TxSubmission.Inbound.V2 (TraceTxSubmissionInbound) import Ouroboros.Network.TxSubmission.Outbound (TraceTxSubmissionOutbound) +import Ouroboros.Network.Tracing () +import Network.Mux.Tracing () +import qualified Network.Mux as Mux import Control.Monad (forM_) import Data.Aeson.Types (ToJSON) @@ -114,8 +118,6 @@ import Data.Text (pack) import qualified Data.Text.IO as T import Data.Time (getZonedTime) import Data.Version (showVersion) -import GHC.Generics (Generic) -import qualified Network.Mux as Mux import qualified Network.Socket as Socket import qualified Options.Applicative as Opt import System.IO @@ -161,9 +163,6 @@ parseTraceDocumentationCmd = ] ) -deriving instance Generic UnversionedProtocol -deriving instance Generic UnversionedProtocolData - instance ToJSON UnversionedProtocol instance ToJSON UnversionedProtocolData @@ -177,7 +176,7 @@ runTraceDocumentationCmd TraceDocumentationCmd{..} = do -- as the tracers are behind old tracer interface after construction in mkDispatchTracers. -- Can be changed, when old tracers have gone docTracers :: - FilePath + FilePath -> FilePath -> Maybe FilePath -> IO () @@ -190,8 +189,7 @@ docTracers configFileName outputFileName mbMetricsHelpFilename = do -- as the tracers are behind old tracer interface after construction in mkDispatchTracers. -- Can be changed, when old tracers have gone docTracersFirstPhase :: forall blk peer remotePeer. - ( TraceConstraints blk - , Proxy blk ~ Proxy (CardanoBlock StandardCrypto) + ( Proxy blk ~ Proxy (CardanoBlock StandardCrypto) , Proxy peer ~ Proxy (NtN.ConnectionId LocalAddress) , Proxy remotePeer ~ Proxy (NtN.ConnectionId NtN.RemoteAddress) ) @@ -606,13 +604,7 @@ docTracersFirstPhase condConfigFileName = do ["Net", "PeerSelection", "Counters"] configureTracers configReflection trConfig [peerSelectionCountersTr] peerSelectionCountersTrDoc <- documentTracer (peerSelectionCountersTr :: - Logging.Trace IO (PeerSelectionCounters (Cardano.ExtraPeerSelectionSetsWithSizes Socket.SockAddr))) - - churnCountersTr <- mkCardanoTracer - trBase trForward mbTrEKG - ["Net", "Churn"] - configureTracers configReflection trConfig [churnCountersTr] - churnCountersTrDoc <- documentTracer (churnCountersTr :: Logging.Trace IO ChurnCounters) + Logging.Trace IO (PeerSelectionCounters (Cardano.ViewExtraPeers (Cardano.PublicRootPeers.ExtraPeers Socket.SockAddr)))) peerSelectionActionsTr <- mkCardanoTracer trBase trForward mbTrEKG @@ -756,7 +748,6 @@ docTracersFirstPhase condConfigFileName = do <> debugPeerSelectionTrDoc <> debugPeerSelectionResponderTrDoc <> peerSelectionCountersTrDoc - <> churnCountersTrDoc <> peerSelectionActionsTrDoc <> connectionManagerTrDoc <> connectionManagerTransitionsTrDoc diff --git a/cardano-node/src/Cardano/Node/Tracing/Era/HardFork.hs b/cardano-node/src/Cardano/Node/Tracing/Era/HardFork.hs index 7e528ba3c2f..aebc3a1f721 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Era/HardFork.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Era/HardFork.hs @@ -19,7 +19,7 @@ import Cardano.Logging import Cardano.Slotting.Slot (EpochSize (..)) import Cardano.Tracing.OrphanInstances.HardFork () import Ouroboros.Consensus.Block (BlockProtocol, CannotForge, ForgeStateInfo, - ForgeStateUpdateError) + ForgeStateUpdateError, PerasWeight (..)) import Ouroboros.Consensus.BlockchainTime (getSlotLength) import Ouroboros.Consensus.Cardano.Condense () import Ouroboros.Consensus.HardFork.Combinator @@ -36,7 +36,8 @@ import Ouroboros.Consensus.HeaderValidation (OtherHeaderEnvelopeError) import Ouroboros.Consensus.Ledger.Abstract (LedgerError) import Ouroboros.Consensus.Ledger.Inspect (LedgerUpdate, LedgerWarning) import Ouroboros.Consensus.Ledger.SupportsMempool (ApplyTxErr) -import Ouroboros.Consensus.Protocol.Abstract (ValidationErr, TiebreakerView, SelectView(..)) +import Ouroboros.Consensus.Peras.SelectView +import Ouroboros.Consensus.Protocol.Abstract (TiebreakerView, ValidationErr) import Ouroboros.Consensus.TypeFamilyWrappers import Ouroboros.Consensus.Util.Condense (Condense (..)) @@ -352,10 +353,11 @@ instance LogFormatting (ForgeStateUpdateError blk) => LogFormatting (WrapForgeSt instance All (LogFormatting `Compose` WrapTiebreakerView) xs => LogFormatting (HardForkTiebreakerView xs) where forMachine dtal = forMachine dtal . getHardForkTiebreakerView -instance LogFormatting (TiebreakerView protocol) => LogFormatting (SelectView protocol) where +instance LogFormatting (TiebreakerView protocol) => LogFormatting (WeightedSelectView protocol) where forMachine dtal sv = mconcat - [ "blockNo" .= svBlockNo sv - , forMachine dtal (svTiebreakerView sv) + [ "blockNo" .= wsvBlockNo sv + , "weightBoost" .= unPerasWeight (wsvWeightBoost sv) + , forMachine dtal (wsvTiebreaker sv) ] instance All (LogFormatting `Compose` WrapTiebreakerView) xs => LogFormatting (OneEraTiebreakerView xs) where diff --git a/cardano-node/src/Cardano/Node/Tracing/Era/Shelley.hs b/cardano-node/src/Cardano/Node/Tracing/Era/Shelley.hs index 0f76c298ab1..76e89e55ec8 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Era/Shelley.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Era/Shelley.hs @@ -36,13 +36,14 @@ import Cardano.Ledger.BaseTypes (Mismatch (..), activeSlotLog, strictM import Cardano.Ledger.Chain import Cardano.Ledger.Conway.Governance (govActionIdToText) import qualified Cardano.Ledger.Conway.Rules as Conway +import qualified Cardano.Ledger.Dijkstra.Rules as Dijkstra import qualified Cardano.Ledger.Core as Ledger import qualified Cardano.Ledger.Hashes as Hashes import Cardano.Ledger.Shelley.API import Cardano.Ledger.Shelley.Rules import Cardano.Logging import Cardano.Node.Tracing.Render (renderMissingRedeemers, renderScriptHash, - renderScriptIntegrityHash) + renderScriptIntegrityHash, renderIncompleteWithdrawals) import qualified Cardano.Protocol.Crypto as Ledger import Cardano.Protocol.TPraos.API (ChainTransitionError (ChainTransitionError)) import Cardano.Protocol.TPraos.BHeader (LastAppliedBlock, labBlockNo) @@ -69,13 +70,17 @@ import Ouroboros.Consensus.Util.Condense (condense) import Ouroboros.Network.Block (SlotNo (..), blockHash, blockNo, blockSlot) import Ouroboros.Network.Point (WithOrigin, withOriginToMaybe) +import qualified Data.Aeson.Types as Aeson import Data.Aeson (ToJSON (..), Value (..), (.=)) +import qualified Data.Aeson.Key as Aeson (fromText) import qualified Data.ByteString.Base16 as B16 import qualified Data.List.NonEmpty as NonEmpty import Data.Set (Set) import qualified Data.Set as Set +import qualified Data.Map as Map import Data.Text (Text) import qualified Data.Text.Encoding as Text +import qualified Data.Set.NonEmpty as NonEmptySet {- HLINT ignore "Use :" -} @@ -93,13 +98,13 @@ instance ( "txid" .= txId tx ) : [ "tx" .= condense tx | dtal == DDetailed ] -instance LogFormatting (Set (Credential 'Staking)) where +instance LogFormatting (Set (Credential Staking)) where forMachine _dtal creds = mconcat [ "kind" .= String "StakeCreds" , "stakeCreds" .= map toJSON (Set.toList creds) ] -instance LogFormatting (NonEmpty.NonEmpty (KeyHash 'Staking)) where +instance LogFormatting (NonEmpty.NonEmpty (KeyHash Staking)) where forMachine _dtal keyHashes = mconcat [ "kind" .= String "StakingKeyHashes" , "stakeKeyHashes" .= toJSON keyHashes @@ -176,8 +181,8 @@ instance LogFormatting (Conway.ConwayDelegPredFailure era) where , "amount" .= String (textShow credential) , "error" .= String "Stake key not registered" ] - Conway.StakeKeyHasNonZeroRewardAccountBalanceDELEG coin -> - [ "kind" .= String "StakeKeyHasNonZeroRewardAccountBalanceDELEG" + Conway.StakeKeyHasNonZeroAccountBalanceDELEG coin -> + [ "kind" .= String "StakeKeyHasNonZeroAccountBalanceDELEG" , "amount" .= coin , "error" .= String "Stake key has non-zero account balance" ] @@ -215,9 +220,13 @@ instance , LogFormatting (PredicateFailure (ShelleyUTXO era)) , LogFormatting (PredicateFailure (ShelleyUTXOW era)) , LogFormatting (PredicateFailure (Ledger.EraRule "LEDGER" era)) + , ToJSON (ApplyTxError era) ) => LogFormatting (ApplyTxError era) where - forMachine dtal (ApplyTxError predicateFailures) = - mconcat $ NonEmpty.toList $ fmap (forMachine dtal) predicateFailures + forMachine _dtal err = + mconcat + [ "kind" .= String "ApplyTxError" + , "reason" .= toJSON err + ] instance ( Ledger.Crypto era @@ -336,6 +345,15 @@ instance ) => LogFormatting (ShelleyLedgersPredFailure era) where forMachine dtal (LedgerFailure f) = forMachine dtal f +instance LogFormatting Withdrawals where + forMachine _dtal (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 ( Consensus.ShelleyBasedEra era @@ -347,6 +365,10 @@ instance forMachine dtal = \case UtxowFailure f -> forMachine dtal f DelegsFailure f -> forMachine dtal f + ShelleyWithdrawalsMissingAccounts withdrawals -> forMachine dtal withdrawals + ShelleyIncompleteWithdrawals payload -> + mconcat ["kind" .= String "ShelleyIncompleteWithdrawals" + , "withdrawals" .= renderIncompleteWithdrawals payload] instance ( Api.ShelleyLedgerEra era ~ ledgerera @@ -364,7 +386,7 @@ instance forMachine _ (MissingRequiredDatums required received) = mconcat [ "kind" .= String "MissingRequiredDatums" , "required" .= map (Crypto.hashToTextAsHex . Hashes.extractHash) - (Set.toList required) + (NonEmptySet.toList required) , "received" .= map (Crypto.hashToTextAsHex . Hashes.extractHash) (Set.toList received) ] @@ -375,11 +397,11 @@ instance ] forMachine _ (UnspendableUTxONoDatumHash txins) = mconcat [ "kind" .= String "MissingRequiredSigners" - , "txins" .= Set.toList txins + , "txins" .= NonEmptySet.toList txins ] forMachine _ (NotAllowedSupplementalDatums disallowed acceptable) = mconcat [ "kind" .= String "NotAllowedSupplementalDatums" - , "disallowed" .= Set.toList disallowed + , "disallowed" .= NonEmptySet.toList disallowed , "acceptable" .= Set.toList acceptable ] forMachine _ (ExtraRedeemers rdmrs) = @@ -388,7 +410,7 @@ instance (\alonzoOnwards -> mconcat [ "kind" .= String "ExtraRedeemers" - , "rdmrs" .= map (Api.toScriptIndex alonzoOnwards) rdmrs + , "rdmrs" .= map (Api.toScriptIndex alonzoOnwards) (NonEmpty.toList rdmrs) ] ) (Api.shelleyBasedEra :: Api.ShelleyBasedEra era) @@ -410,7 +432,7 @@ instance ) => LogFormatting (ShelleyUtxowPredFailure era) where forMachine _dtal (InvalidWitnessesUTXOW wits') = mconcat [ "kind" .= String "InvalidWitnessesUTXOW" - , "invalidWitnesses" .= map textShow wits' + , "invalidWitnesses" .= map textShow (NonEmpty.toList wits') ] forMachine _dtal (MissingVKeyWitnessesUTXOW wits') = mconcat [ "kind" .= String "MissingVKeyWitnessesUTXOW" @@ -448,7 +470,7 @@ instance ] forMachine _dtal (ExtraneousScriptWitnessesUTXOW scriptHashes) = mconcat [ "kind" .= String "ExtraneousScriptWitnessesUTXOW" - , "scriptHashes" .= Set.map renderScriptHash scriptHashes + , "scriptHashes" .= Set.map renderScriptHash (NonEmptySet.toSet scriptHashes) ] instance @@ -458,7 +480,7 @@ instance forMachine _dtal (BadInputsUTxO badInputs) = mconcat [ "kind" .= String "BadInputsUTxO" , "badInputs" .= badInputs - , "error" .= renderBadInputsUTxOErr badInputs + , "error" .= renderBadInputsUTxOErr (NonEmptySet.toSet badInputs) ] forMachine _dtal (ExpiredUTxO Mismatch {mismatchSupplied, mismatchExpected}) = mconcat [ "kind" .= String "ExpiredUTxO" @@ -520,7 +542,7 @@ instance forMachine _dtal (Allegra.BadInputsUTxO badInputs) = mconcat [ "kind" .= String "BadInputsUTxO" , "badInputs" .= badInputs - , "error" .= renderBadInputsUTxOErr badInputs + , "error" .= renderBadInputsUTxOErr (NonEmptySet.toSet badInputs) ] forMachine _dtal (Allegra.OutsideValidityIntervalUTxO validityInterval slot) = mconcat [ "kind" .= String "ExpiredUTxO" @@ -606,14 +628,6 @@ instance ( Consensus.ShelleyBasedEra era , LogFormatting (PredicateFailure (Ledger.EraRule "DELPL" era)) ) => LogFormatting (ShelleyDelegsPredFailure era) where - forMachine _dtal (DelegateeNotRegisteredDELEG targetPool) = - mconcat [ "kind" .= String "DelegateeNotRegisteredDELEG" - , "targetPool" .= targetPool - ] - forMachine _dtal (WithdrawalsNotInRewardsDELEGS incorrectWithdrawals) = - mconcat [ "kind" .= String "WithdrawalsNotInRewardsCERTS" - , "incorrectWithdrawals" .= unWithdrawals incorrectWithdrawals - ] forMachine dtal (DelplFailure f) = forMachine dtal f @@ -697,6 +711,10 @@ instance LogFormatting (ShelleyDelegPredFailure era) where TreasuryMIR -> "Treasury") , "coin" .= coin ] + forMachine _dtal (DelegateeNotRegisteredDELEG targetPool) = + mconcat [ "kind" .= String "DelegateeNotRegisteredDELEG" + , "targetPool" .= targetPool + ] instance LogFormatting (ShelleyPoolPredFailure era) where forMachine _dtal (StakePoolNotRegisteredOnKeyPOOL (KeyHash unregStakePool)) = @@ -877,8 +895,8 @@ instance ) => LogFormatting (AlonzoUtxoPredFailure era) where forMachine _dtal (Alonzo.BadInputsUTxO badInputs) = mconcat [ "kind" .= String "BadInputsUTxO" - , "badInputs" .= badInputs - , "error" .= renderBadInputsUTxOErr badInputs + , "badInputs" .= NonEmptySet.toSet badInputs + , "error" .= renderBadInputsUTxOErr (NonEmptySet.toSet badInputs) ] forMachine _dtal (Alonzo.OutsideValidityIntervalUTxO validtyInterval slot) = mconcat [ "kind" .= String "ExpiredUTxO" @@ -1073,6 +1091,14 @@ instance , LogFormatting (PredicateFailure (Ledger.EraRule "CERTS" era)) ) => LogFormatting (Conway.ConwayLedgerPredFailure era) where forMachine v (Conway.ConwayUtxowFailure f) = forMachine v f + forMachine _ (Conway.ConwayWithdrawalsMissingAccounts missingWithdrawals) = + mconcat [ "kind" .= String "ConwayWithdrawalsMissingAccounts" + , "withdrawals" .= unWithdrawals missingWithdrawals + ] + forMachine _ (Conway.ConwayIncompleteWithdrawals incompleteWithdrawals) = + mconcat [ "kind" .= String "ConwayIncompleteWithdrawals" + , "withdrawals" .= renderIncompleteWithdrawals incompleteWithdrawals + ] forMachine _ (Conway.ConwayTxRefScriptsSizeTooBig Mismatch {mismatchSupplied, mismatchExpected}) = mconcat [ "kind" .= String "ConwayTxRefScriptsSizeTooBig" , "actual" .= mismatchSupplied @@ -1147,11 +1173,6 @@ instance , "protVer" .= mismatchSupplied , "prevProtVer" .= mismatchExpected ] - forMachine _ (Conway.InvalidPolicyHash actualPolicyHash expectedPolicyHash) = - mconcat [ "kind" .= String "InvalidPolicyHash" - , "actualPolicyHash" .= actualPolicyHash - , "expectedPolicyHash" .= expectedPolicyHash - ] forMachine _ (Conway.DisallowedProposalDuringBootstrap proposal) = mconcat [ "kind" .= String "DisallowedProposalDuringBootstrap" , "proposal" .= proposal @@ -1177,6 +1198,12 @@ instance mconcat [ "kind" .= String "UnelectedCommitteeVoters" , "unelectedCommitteeVoters" .= voters ] + forMachine _ (Conway.InvalidGuardrailsScriptHash actualPolicyHash expectedPolicyHash) = + mconcat [ "kind" .= String "InvalidPolicyHash" + , "actualPolicyHash" .= actualPolicyHash + , "expectedPolicyHash" .= expectedPolicyHash + ] + instance ( Consensus.ShelleyBasedEra era @@ -1189,6 +1216,37 @@ instance forMachine dtal (Conway.CertFailure certFailure) = forMachine dtal certFailure +instance + ( LogFormatting (PredicateFailure (Ledger.EraRule "CERTS" ledgerera)) + , LogFormatting (PredicateFailure (Ledger.EraRule "UTXOW" ledgerera)) + , LogFormatting (PredicateFailure (Ledger.EraRule "GOV" ledgerera)) + ) => LogFormatting (Dijkstra.DijkstraLedgerPredFailure ledgerera) where + forMachine _ = error "Dijkstra era is not active yet" + +instance + (LogFormatting (PredicateFailure (Ledger.EraRule "CERTS" ledgerera)) + ) => LogFormatting (Dijkstra.DijkstraGovCertPredFailure ledgerera) where + forMachine _ = error "Dijkstra era is not active yet" + +instance + (LogFormatting (PredicateFailure (Ledger.EraRule "CERTS" ledgerera)) + ) => LogFormatting (Dijkstra.DijkstraGovPredFailure ledgerera) where + forMachine _ = error "Dijkstra era is not active yet" + +instance + (LogFormatting (PredicateFailure (Ledger.EraRule "UTXOW" ledgerera)) + ) => LogFormatting (Dijkstra.DijkstraUtxowPredFailure ledgerera) where + forMachine _ = error "Dijkstra era is not active yet" + +instance + (LogFormatting (PredicateFailure (Ledger.EraRule "CERTS" ledgerera)) + ) => LogFormatting (Dijkstra.DijkstraBbodyPredFailure ledgerera) where + forMachine _ = error "Dijkstra era is not active yet" + +instance + (LogFormatting (PredicateFailure (Ledger.EraRule "CERTS" ledgerera)) + ) => LogFormatting (Dijkstra.DijkstraUtxoPredFailure ledgerera) where + forMachine _ = error "Dijkstra era is not active yet" instance ( Ledger.Crypto crypto @@ -1312,8 +1370,8 @@ instance Conway.UtxosFailure utxosPredFailure -> forMachine dtal utxosPredFailure Conway.BadInputsUTxO badInputs -> mconcat [ "kind" .= String "BadInputsUTxO" - , "badInputs" .= badInputs - , "error" .= renderBadInputsUTxOErr badInputs + , "badInputs" .= NonEmptySet.toSet badInputs + , "error" .= renderBadInputsUTxOErr (NonEmptySet.toSet badInputs) ] Conway.OutsideValidityIntervalUTxO validityInterval slot -> mconcat [ "kind" .= String "ExpiredUTxO" @@ -1426,7 +1484,7 @@ instance Conway.UtxoFailure utxoPredFail -> forMachine dtal utxoPredFail Conway.InvalidWitnessesUTXOW ws -> mconcat [ "kind" .= String "InvalidWitnessesUTXOW" - , "invalidWitnesses" .= map textShow ws + , "invalidWitnesses" .= map textShow (NonEmpty.toList ws) ] Conway.MissingVKeyWitnessesUTXOW ws -> mconcat [ "kind" .= String "MissingVKeyWitnessesUTXOW" @@ -1458,7 +1516,7 @@ instance ] Conway.ExtraneousScriptWitnessesUTXOW scripts -> mconcat [ "kind" .= String "InvalidWitnessesUTXOW" - , "extraneousScripts" .= Set.map renderScriptHash scripts + , "extraneousScripts" .= Set.map renderScriptHash (NonEmptySet.toSet scripts) ] Conway.MissingRedeemers scripts -> mconcat [ "kind" .= String "MissingRedeemers" @@ -1467,13 +1525,13 @@ instance Conway.MissingRequiredDatums required received -> mconcat [ "kind" .= String "MissingRequiredDatums" , "required" .= map (Crypto.hashToTextAsHex . Hashes.extractHash) - (Set.toList required) + (NonEmptySet.toList required) , "received" .= map (Crypto.hashToTextAsHex . Hashes.extractHash) (Set.toList received) ] Conway.NotAllowedSupplementalDatums disallowed acceptable -> mconcat [ "kind" .= String "NotAllowedSupplementalDatums" - , "disallowed" .= Set.toList disallowed + , "disallowed" .= NonEmptySet.toList disallowed , "acceptable" .= Set.toList acceptable ] Conway.PPViewHashesDontMatch Mismatch {mismatchSupplied, mismatchExpected} -> @@ -1483,7 +1541,7 @@ instance ] Conway.UnspendableUTxONoDatumHash ins -> mconcat [ "kind" .= String "MissingRequiredSigners" - , "txins" .= Set.toList ins + , "txins" .= NonEmptySet.toList ins ] Conway.ExtraRedeemers rs -> Api.caseShelleyToMaryOrAlonzoEraOnwards @@ -1491,7 +1549,7 @@ instance (\alonzoOnwards -> mconcat [ "kind" .= String "ExtraRedeemers" - , "rdmrs" .= map (Api.toScriptIndex alonzoOnwards) rs + , "rdmrs" .= map (Api.toScriptIndex alonzoOnwards) (NonEmpty.toList rs) ] ) (Api.shelleyBasedEra :: Api.ShelleyBasedEra era) diff --git a/cardano-node/src/Cardano/Node/Tracing/Render.hs b/cardano-node/src/Cardano/Node/Tracing/Render.hs index 0c84e550b4b..686627899d9 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Render.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Render.hs @@ -28,6 +28,7 @@ module Cardano.Node.Tracing.Render , renderScriptIntegrityHash , renderScriptPurpose , renderMissingRedeemers + , renderIncompleteWithdrawals ) where import qualified Cardano.Api as Api @@ -50,6 +51,7 @@ import Ouroboros.Consensus.Storage.ImmutableDB.Chunks.Internal (ChunkN import Ouroboros.Consensus.Util.Condense (Condense, condense) import Ouroboros.Network.Block (ChainHash (..), HeaderHash, StandardHash, Tip, getTipPoint) +import Cardano.Ledger.BaseTypes (Mismatch(..), Relation(..)) import Data.Aeson ((.=)) import qualified Data.Aeson as Aeson @@ -60,6 +62,11 @@ import Data.Proxy (Proxy (..)) import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text +import qualified Data.List.NonEmpty as NonEmpty +import Data.List.NonEmpty (NonEmpty) +import qualified Data.Map.NonEmpty as NonEmptyMap +import Data.Map.NonEmpty (NonEmptyMap) + condenseT :: Condense a => a -> Text condenseT = Text.pack . condense @@ -184,9 +191,9 @@ renderScriptIntegrityHash Nothing = Aeson.Null renderMissingRedeemers :: forall era. () => Api.ShelleyBasedEra era - -> [(PlutusPurpose AsItem (Api.ShelleyLedgerEra era), Ledger.ScriptHash)] + -> NonEmpty (PlutusPurpose AsItem (Api.ShelleyLedgerEra era), Ledger.ScriptHash) -> Aeson.Value -renderMissingRedeemers sbe scripts = Aeson.object $ map renderTuple scripts +renderMissingRedeemers sbe scripts = Aeson.object $ NonEmpty.toList $ NonEmpty.map renderTuple scripts where renderTuple :: () => (PlutusPurpose AsItem (Api.ShelleyLedgerEra era), Ledger.ScriptHash) @@ -194,6 +201,16 @@ renderMissingRedeemers sbe scripts = Aeson.object $ map renderTuple scripts renderTuple (scriptPurpose, sHash) = Aeson.fromText (renderScriptHash sHash) .= renderScriptPurpose sbe scriptPurpose +renderIncompleteWithdrawals :: forall payload. Show payload + => NonEmptyMap Ledger.AccountAddress (Mismatch RelEQ payload) + -> Aeson.Value +renderIncompleteWithdrawals payload = + Aeson.object $ map renderTuple $ NonEmptyMap.toList payload + where + renderTuple :: (Ledger.AccountAddress, Mismatch RelEQ payload) -> Aeson.Pair + renderTuple (address, mismatch) = + Aeson.fromText (Api.serialiseAddress $ Api.fromShelleyStakeAddr address) .= show mismatch + renderScriptHash :: Ledger.ScriptHash -> Text renderScriptHash = Api.serialiseToRawBytesHexText . Api.fromShelleyScriptHash diff --git a/cardano-node/src/Cardano/Node/Tracing/StateRep.hs b/cardano-node/src/Cardano/Node/Tracing/StateRep.hs index 4563ee4d819..019408164cc 100644 --- a/cardano-node/src/Cardano/Node/Tracing/StateRep.hs +++ b/cardano-node/src/Cardano/Node/Tracing/StateRep.hs @@ -298,7 +298,7 @@ traceNodeStateChainDB _scp tr ev = _ -> return () ChainDB.TraceAddBlockEvent ev' -> case ev' of - ChainDB.AddedToCurrentChain _ (ChainDB.SelectionChangedInfo currentTip ntEpoch sInEpoch _ _ _) _ _ -> do + ChainDB.AddedToCurrentChain _ (ChainDB.SelectionChangedInfo currentTip ntEpoch sInEpoch _ _ _) _ _ _ -> do -- The slot of the latest block consumed (our progress). let RP.RealPoint ourSlotSinceSystemStart _ = currentTip -- The slot corresponding to the latest wall-clock time (our target). diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers.hs index 485d28e71f0..f81340f475b 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers.hs @@ -18,6 +18,8 @@ module Cardano.Node.Tracing.Tracers import Cardano.Logging import qualified Cardano.Network.Diffusion as Cardano.Diffusion +import Cardano.Network.NodeToClient (LocalAddress) +import Cardano.Network.NodeToNode (RemoteAddress) import Cardano.Node.Protocol.Types (SomeConsensusProtocol) import Cardano.Node.Queries (NodeKernelData) import Cardano.Node.TraceConstraints @@ -28,14 +30,12 @@ import qualified Cardano.Node.Tracing.StateRep as SR import Cardano.Node.Tracing.Tracers.BlockReplayProgress import Cardano.Node.Tracing.Tracers.ChainDB import Cardano.Node.Tracing.Tracers.Consensus -import Cardano.Node.Tracing.Tracers.Diffusion () import Cardano.Node.Tracing.Tracers.ForgingStats (calcForgeStats) import Cardano.Node.Tracing.Tracers.KESInfo import Cardano.Node.Tracing.Tracers.LedgerMetrics () import Cardano.Node.Tracing.Tracers.NodeToClient () import Cardano.Node.Tracing.Tracers.NodeToNode () import Cardano.Node.Tracing.Tracers.NodeVersion (getNodeVersion) -import Cardano.Node.Tracing.Tracers.P2P () import Cardano.Node.Tracing.Tracers.Shutdown () import Cardano.Node.Tracing.Tracers.Startup () import Ouroboros.Consensus.Ledger.Inspect (LedgerEvent) @@ -53,14 +53,15 @@ import Ouroboros.Network.Block import qualified Ouroboros.Network.BlockFetch.ClientState as BlockFetch import Ouroboros.Network.ConnectionId (ConnectionId) import qualified Ouroboros.Network.Diffusion as Diffusion -import Ouroboros.Network.NodeToClient (LocalAddress) -import Ouroboros.Network.NodeToNode (RemoteAddress) import Codec.CBOR.Read (DeserialiseFailure) import Control.Monad (unless) import "contra-tracer" Control.Tracer (Tracer (..)) +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. -- @@ -74,6 +75,7 @@ mkDispatchTracers (ConnectionId RemoteAddress) (TraceChainSyncClientEvent blk)) , LogFormatting (TraceGsmEvent (Tip blk)) , MetaTrace (TraceGsmEvent (Tip blk)) + , ToJSON (HeaderHash blk) ) => NodeKernelData blk -> Trace IO FormattedMessage @@ -192,6 +194,7 @@ mkConsensusTracers :: forall blk. (ConnectionId RemoteAddress) (TraceChainSyncClientEvent blk)) , LogFormatting (TraceGsmEvent (Tip blk)) , MetaTrace (TraceGsmEvent (Tip blk)) + , ToJSON (HeaderHash blk) ) => ConfigReflection -> Trace IO FormattedMessage @@ -333,6 +336,16 @@ mkConsensusTracers configReflection trBase trForward mbTrEKG _trDataPoint trConf ["Consensus", "DevotedBlockFetch"] configureTracers configReflection trConfig [consensusDbfTr] + !txLogicTracer <- mkCardanoTracer + trBase trForward mbTrEKG + ["txLogic", "Remote"] + configureTracers configReflection trConfig [txLogicTracer] + + !txCountersTracer <- mkCardanoTracer + trBase trForward mbTrEKG + ["txCounters", "Remote"] + configureTracers configReflection trConfig [txCountersTracer] + pure $ Consensus.Tracers { Consensus.chainSyncClientTracer = Tracer $ traceWith chainSyncClientTr @@ -381,6 +394,10 @@ mkConsensusTracers configReflection trBase trForward mbTrEKG _trDataPoint trConf traceWith consensusDbfTr , Consensus.kesAgentTracer = Tracer $ traceWith consensusKesAgentTr + , Consensus.txLogicTracer = Tracer $ + traceWith txLogicTracer + , Consensus.txCountersTracer = Tracer $ + traceWith txCountersTracer } mkNodeToClientTracers :: forall blk. @@ -475,6 +492,11 @@ mkNodeToNodeTracers configReflection trBase trForward mbTrEKG _trDataPoint trCon ["PeerSharing", "Remote"] configureTracers configReflection trConfig [peerSharingTracer] + !txLogicTracer <- mkCardanoTracer + trBase trForward mbTrEKG + ["txLogic", "Remote"] + configureTracers configReflection trConfig [txLogicTracer] + pure $ NtN.Tracers { NtN.tChainSyncTracer = Tracer $ traceWith chainSyncTracer @@ -490,16 +512,24 @@ mkNodeToNodeTracers configReflection trBase trForward mbTrEKG _trDataPoint trCon traceWith keepAliveTracer , NtN.tPeerSharingTracer = Tracer $ traceWith peerSharingTracer + , NtN.tTxLogicTracer = Tracer $ + traceWith txLogicTracer } -mkDiffusionTracers - :: ConfigReflection - -> Trace IO FormattedMessage - -> Trace IO FormattedMessage - -> Maybe (Trace IO FormattedMessage) - -> Trace IO DataPoint - -> TraceConfig - -> IO (Cardano.Diffusion.CardanoTracers IO) +mkDiffusionTracers :: + ( LogFormatting + ( Mux.WithBearer + (ConnectionId RemoteAddress) + Mux.Trace + ) + ) => + ConfigReflection -> + Trace IO FormattedMessage -> + Trace IO FormattedMessage -> + Maybe (Trace IO FormattedMessage) -> + Trace IO DataPoint -> + TraceConfig -> + IO (Cardano.Diffusion.CardanoTracers IO) mkDiffusionTracers configReflection trBase trForward mbTrEKG _trDataPoint trConfig = do !dtMuxTr <- mkCardanoTracer @@ -567,21 +597,11 @@ mkDiffusionTracers configReflection trBase trForward mbTrEKG _trDataPoint trConf ["Net", "PeerSelection", "Initiator"] configureTracers configReflection trConfig [debugPeerSelectionTr] - !debugPeerSelectionResponderTr <- mkCardanoTracer - trBase trForward mbTrEKG - ["Net", "PeerSelection", "Responder"] - configureTracers configReflection trConfig [debugPeerSelectionResponderTr] - !peerSelectionCountersTr <- mkCardanoTracer trBase trForward mbTrEKG ["Net", "PeerSelection"] configureTracers configReflection trConfig [peerSelectionCountersTr] - !churnCountersTr <- mkCardanoTracer - trBase trForward mbTrEKG - ["Net", "Churn"] - configureTracers configReflection trConfig [churnCountersTr] - !peerSelectionActionsTr <- mkCardanoTracer trBase trForward mbTrEKG ["Net", "PeerSelection", "Actions"] @@ -662,14 +682,10 @@ mkDiffusionTracers configReflection trBase trForward mbTrEKG _trDataPoint trConf traceWith publicRootPeersTr , Diffusion.dtTracePeerSelectionTracer = Tracer $ traceWith peerSelectionTr - , Diffusion.dtDebugPeerSelectionInitiatorTracer = Tracer $ + , Diffusion.dtDebugPeerSelectionTracer = Tracer $ traceWith debugPeerSelectionTr - , Diffusion.dtDebugPeerSelectionInitiatorResponderTracer = Tracer $ - traceWith debugPeerSelectionResponderTr , Diffusion.dtTracePeerSelectionCounters = Tracer $ traceWith peerSelectionCountersTr - , Diffusion.dtTraceChurnCounters = Tracer $ - traceWith churnCountersTr , Diffusion.dtPeerSelectionActionsTracer = Tracer $ traceWith peerSelectionActionsTr , Diffusion.dtConnectionManagerTracer = Tracer $ diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/ChainDB.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/ChainDB.hs index a8b5f32dcf5..e06f4f08e89 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/ChainDB.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/ChainDB.hs @@ -22,13 +22,19 @@ import Cardano.Node.Tracing.Render 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 +import Ouroboros.Consensus.HardFork.Combinator.Info +import Ouroboros.Consensus.HardFork.Combinator.Protocol.ChainSel import Ouroboros.Consensus.HeaderValidation (HeaderEnvelopeError (..), HeaderError (..), OtherHeaderEnvelopeError) import Ouroboros.Consensus.Ledger.Abstract (LedgerError) +import Ouroboros.Consensus.Peras.SelectView +import Ouroboros.Consensus.Protocol.Praos.Common import Ouroboros.Consensus.Ledger.Extended (ExtValidationError (..)) import Ouroboros.Consensus.Ledger.Inspect (InspectLedger, LedgerEvent (..)) import Ouroboros.Consensus.Ledger.SupportsProtocol (LedgerSupportsProtocol) -import Ouroboros.Consensus.Protocol.Abstract (SelectView, ValidationErr) +import Ouroboros.Consensus.Protocol.Abstract (ValidationErr, SelectViewReasonForSwitch(..), Comparing(..), ReasonForSwitch, TiebreakerView) import qualified Ouroboros.Consensus.Protocol.PBFT as PBFT import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB import qualified Ouroboros.Consensus.Storage.ImmutableDB as ImmDB @@ -37,19 +43,27 @@ import qualified Ouroboros.Consensus.Storage.ImmutableDB.Impl.Types as ImmDB import qualified Ouroboros.Consensus.Storage.LedgerDB as LedgerDB import qualified Ouroboros.Consensus.Storage.LedgerDB.Snapshots as LedgerDB import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore as V1 -import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.Args as V2 +import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.Impl.LMDB as LMDB +import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.Backend as V2 +import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.InMemory as InMemory +import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.LSM as LSM +import qualified Ouroboros.Consensus.Storage.PerasCertDB.Impl as PerasCertDB import qualified Ouroboros.Consensus.Storage.VolatileDB as VolDB +import Ouroboros.Consensus.TypeFamilyWrappers import Ouroboros.Consensus.Util.Condense (condense) import Ouroboros.Consensus.Util.Enclose import qualified Ouroboros.Network.AnchoredFragment as AF import Ouroboros.Network.Block (MaxSlotNo (..)) -import Data.Aeson (Value (String), object, toJSON, (.=)) +import Data.Aeson (Value (String), object, toJSON, (.=), Object) import qualified Data.ByteString.Base16 as B16 import Data.Int (Int64) +import Data.SOP (K (..), hcmap, hcollapse, All) import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text +import Data.Typeable (Typeable, cast) +import Data.Void (absurd) import Data.Word (Word64) import Numeric (showFFloat) @@ -65,7 +79,7 @@ withAddedToCurrentChainEmptyLimited tr = do where selecting ltr - (ChainDB.TraceAddBlockEvent (ChainDB.AddedToCurrentChain events _ _ _)) = + (ChainDB.TraceAddBlockEvent (ChainDB.AddedToCurrentChain events _ _ _ _)) = if null events then pure ltr else pure tr @@ -79,12 +93,14 @@ withAddedToCurrentChainEmptyLimited tr = do instance ( LogFormatting (Header blk) , LogFormatting (LedgerEvent blk) , LogFormatting (RealPoint blk) - , LogFormatting (SelectView (BlockProtocol blk)) + , LogFormatting (WeightedSelectView (BlockProtocol blk)) , ConvertRawHash blk , ConvertRawHash (Header blk) , LedgerSupportsProtocol 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" @@ -103,6 +119,8 @@ instance ( LogFormatting (Header blk) "Chain Selection was starved." ChainDB.ChainSelStarvation (FallingEdgeWith pt) -> "Chain Selection was unstarved by " <> renderRealPoint pt + forHuman (ChainDB.TracePerasCertDbEvent ev) = forHuman ev + forHuman (ChainDB.TraceAddPerasCertEvent ev) = forHuman ev forMachine _ ChainDB.TraceLastShutdownUnclean = mconcat [ "kind" .= String "LastShutdownUnclean" ] @@ -132,6 +150,11 @@ instance ( LogFormatting (Header blk) forMachine details v forMachine details (ChainDB.TraceVolatileDBEvent v) = forMachine details v + forMachine details (ChainDB.TracePerasCertDbEvent v) = + forMachine details v + forMachine details (ChainDB.TraceAddPerasCertEvent v) = + forMachine details v + asMetrics ChainDB.TraceLastShutdownUnclean = [] asMetrics (ChainDB.TraceChainSelStarvationEvent _) = [] @@ -145,6 +168,8 @@ instance ( LogFormatting (Header blk) asMetrics (ChainDB.TraceLedgerDBEvent v) = asMetrics v asMetrics (ChainDB.TraceImmutableDBEvent v) = asMetrics v asMetrics (ChainDB.TraceVolatileDBEvent v) = asMetrics v + asMetrics (ChainDB.TracePerasCertDbEvent v) = asMetrics v + asMetrics (ChainDB.TraceAddPerasCertEvent v) = asMetrics v instance MetaTrace (ChainDB.TraceEvent blk) where @@ -172,6 +197,10 @@ instance MetaTrace (ChainDB.TraceEvent blk) where nsPrependInner "ImmDbEvent" (namespaceFor ev) namespaceFor (ChainDB.TraceVolatileDBEvent ev) = nsPrependInner "VolatileDbEvent" (namespaceFor ev) + namespaceFor (ChainDB.TracePerasCertDbEvent ev) = + nsPrependInner "PerasCertDbEvent" (namespaceFor ev) + namespaceFor (ChainDB.TraceAddPerasCertEvent ev) = + nsPrependInner "AddPerasCertEvent" (namespaceFor ev) severityFor (Namespace _ ["LastShutdownUnclean"]) _ = Just Info severityFor (Namespace _ ["ChainSelStarvationEvent"]) _ = Just Debug @@ -215,6 +244,14 @@ instance MetaTrace (ChainDB.TraceEvent blk) where severityFor (Namespace out tl) (Just ev') severityFor (Namespace out ("VolatileDbEvent" : tl)) Nothing = severityFor (Namespace out tl :: Namespace (VolDB.TraceEvent blk)) Nothing + severityFor (Namespace out ("PerasCertDbEvent" : tl)) (Just (ChainDB.TracePerasCertDbEvent ev')) = + severityFor (Namespace out tl) (Just ev') + severityFor (Namespace out ("PerasCertDbEvent" : tl)) Nothing = + severityFor (Namespace out tl :: Namespace (PerasCertDB.TraceEvent blk)) Nothing + severityFor (Namespace out ("AddPerasCertEvent" : tl)) (Just (ChainDB.TraceAddPerasCertEvent ev')) = + severityFor (Namespace out tl) (Just ev') + severityFor (Namespace out ("AddPerasCertEvent" : tl)) Nothing = + severityFor (Namespace out tl :: Namespace (ChainDB.TraceAddPerasCertEvent blk)) Nothing severityFor _ns _ = Nothing privacyFor (Namespace _ ["LastShutdownUnclean"]) _ = Just Public @@ -259,6 +296,14 @@ instance MetaTrace (ChainDB.TraceEvent blk) where privacyFor (Namespace out tl) (Just ev') privacyFor (Namespace out ("VolatileDbEvent" : tl)) Nothing = privacyFor (Namespace out tl :: Namespace (VolDB.TraceEvent blk)) Nothing + privacyFor (Namespace out ("PerasCertDbEvent" : tl)) (Just (ChainDB.TracePerasCertDbEvent ev')) = + privacyFor (Namespace out tl) (Just ev') + privacyFor (Namespace out ("PerasCertDbEvent" : tl)) Nothing = + privacyFor (Namespace out tl :: Namespace (PerasCertDB.TraceEvent blk)) Nothing + privacyFor (Namespace out ("AddPerasCertEvent" : tl)) (Just (ChainDB.TraceAddPerasCertEvent ev')) = + privacyFor (Namespace out tl) (Just ev') + privacyFor (Namespace out ("AddPerasCertEvent" : tl)) Nothing = + privacyFor (Namespace out tl :: Namespace (ChainDB.TraceAddPerasCertEvent blk)) Nothing privacyFor _ _ = Nothing detailsFor (Namespace _ ["LastShutdownUnclean"]) _ = Just DNormal @@ -303,6 +348,14 @@ instance MetaTrace (ChainDB.TraceEvent blk) where detailsFor (Namespace out tl) (Just ev') detailsFor (Namespace out ("VolatileDbEvent" : tl)) Nothing = detailsFor (Namespace out tl :: (Namespace (VolDB.TraceEvent blk))) Nothing + detailsFor (Namespace out ("PerasCertDbEvent" : tl)) (Just (ChainDB.TracePerasCertDbEvent ev')) = + detailsFor (Namespace out tl) (Just ev') + detailsFor (Namespace out ("PerasCertDbEvent" : tl)) Nothing = + detailsFor (Namespace out tl :: Namespace (PerasCertDB.TraceEvent blk)) Nothing + detailsFor (Namespace out ("AddPerasCertEvent" : tl)) (Just (ChainDB.TraceAddPerasCertEvent ev')) = + detailsFor (Namespace out tl) (Just ev') + detailsFor (Namespace out ("AddPerasCertEvent" : tl)) Nothing = + detailsFor (Namespace out tl :: Namespace (ChainDB.TraceAddPerasCertEvent blk)) Nothing detailsFor _ _ = Nothing metricsDocFor (Namespace out ("AddBlockEvent" : tl)) = @@ -356,6 +409,10 @@ instance MetaTrace (ChainDB.TraceEvent blk) where documentFor (Namespace out tl :: Namespace (ImmDB.TraceEvent blk)) documentFor (Namespace out ("VolatileDbEvent" : tl)) = documentFor (Namespace out tl :: Namespace (VolDB.TraceEvent blk)) + documentFor (Namespace out ("PerasCertDbEvent" : tl)) = + documentFor (Namespace out tl :: Namespace (PerasCertDB.TraceEvent blk)) + documentFor (Namespace out ("AddPerasCertEvent" : tl)) = + documentFor (Namespace out tl :: Namespace (ChainDB.TraceAddPerasCertEvent blk)) documentFor _ = Nothing allNamespaces = @@ -381,6 +438,10 @@ instance MetaTrace (ChainDB.TraceEvent blk) where (allNamespaces :: [Namespace (ImmDB.TraceEvent blk)]) ++ map (nsPrependInner "VolatileDbEvent") (allNamespaces :: [Namespace (VolDB.TraceEvent blk)]) + ++ map (nsPrependInner "PerasCertDbEvent") + (allNamespaces :: [Namespace (PerasCertDB.TraceEvent blk)]) + ++ map (nsPrependInner "AddPerasCertEvent") + (allNamespaces :: [Namespace (ChainDB.TraceAddPerasCertEvent blk)]) ) @@ -388,11 +449,63 @@ instance MetaTrace (ChainDB.TraceEvent blk) where -- AddBlockEvent -------------------------------------------------------------------------------- +instance LogFormatting (PraosReasonForSwitch c) where + forHuman (HigherOCert (Comparing ref cand)) = + "candidate has higher OCert (" <> showT cand <> ") than our selection (" <> showT ref <> ")" + forHuman (VRFTiebreak (Comparing ref cand)) = + "candidate has lower VRF (" <> showT cand <> ") than our selection (" <> showT ref <> ")" + forMachine _dtal (HigherOCert (Comparing ref cand)) = + mconcat [ "reason" .= String "HigherOCert", "our" .= String (showT ref), "candidate" .= String (showT cand) ] + forMachine _dtal (VRFTiebreak (Comparing ref cand)) = + mconcat [ "reason" .= String "VRFTiebreak", "our" .= String (showT ref), "candidate" .= String (showT cand) ] + +class (LogFormatting (ReasonForSwitch (TiebreakerView (BlockProtocol a))), SingleEraBlock a) => LFTBV a +instance (LogFormatting (ReasonForSwitch (TiebreakerView (BlockProtocol a))), SingleEraBlock a) => LFTBV a + +instance (All LFTBV xs, CanHardFork xs) => LogFormatting (OneEraReasonForSwitch xs) where + forHuman (OneEraReasonForSwitch ns) = + hcollapse $ hcmap (Proxy @LFTBV) msg ns + where + msg :: forall era. LFTBV era => WrapReasonForSwitch era -> K Text era + msg (WrapReasonForSwitch rs) = K $ + "in era " <> singleEraName (singleEraInfo (Proxy @era)) <> ": " <> forHuman rs + forMachine dtal (OneEraReasonForSwitch ns) = + hcollapse $ hcmap (Proxy @LFTBV) msg ns + where + msg :: forall era. LFTBV era => WrapReasonForSwitch era -> K Object era + msg (WrapReasonForSwitch rs) = K $ + forMachine dtal rs <> mconcat [ "era" .= String (singleEraName (singleEraInfo (Proxy @era))) ] + +instance LogFormatting (ReasonForSwitch (TiebreakerView proto)) => + LogFormatting (WeightedSelectViewReasonForSwitch proto) where + forHuman (Heavier (Comparing ref cand)) = + "candidate is heavier (" <> showT cand <> ") than our selection (" <> showT ref <> ")" + forHuman (WeightedSelectViewTiebreak reason) = forHuman reason + forMachine _dtal (Heavier (Comparing ref cand)) = + mconcat [ "reason" .= String "HigherOCert", "our" .= String (showT ref), "candidate" .= String (showT cand) ] + forMachine dtal (WeightedSelectViewTiebreak reason) = + forMachine dtal reason + +instance LogFormatting (ReasonForSwitch (TiebreakerView proto)) => + LogFormatting (Either (WithEmptyFragmentReasonForSwitch + (WeightedSelectView proto)) (SelectViewReasonForSwitch proto)) where + forHuman (Left CandidateIsNonEmpty) = "candidate is an extension of our selection" + forHuman (Left (BothAreNonEmpty a)) = forHuman a + forHuman (Right (Longer (Comparing ref cand))) = + "candidate is longer (" <> showT cand <> ") than our selection (" <> showT ref <> ")" + forHuman (Right (SelectViewTiebreak a)) = forHuman a + forMachine _dtal (Left CandidateIsNonEmpty) = + mconcat [ "reason" .= String "extension" ] + forMachine dtal (Left (BothAreNonEmpty a)) = forMachine dtal a + forMachine _dtal (Right (Longer (Comparing ref cand))) = + mconcat [ "reason" .= String "Longer", "our" .= String (showT ref), "candidate" .= String (showT cand) ] + forMachine dtal (Right (SelectViewTiebreak a)) = forMachine dtal a instance ( LogFormatting (Header blk) , LogFormatting (LedgerEvent blk) , LogFormatting (RealPoint blk) - , LogFormatting (SelectView (BlockProtocol blk)) + , LogFormatting (WeightedSelectView (BlockProtocol blk)) + , LogFormatting (Either (WithEmptyFragmentReasonForSwitch (WeightedSelectView (BlockProtocol blk))) (SelectViewReasonForSwitch (BlockProtocol blk))) , ConvertRawHash blk , ConvertRawHash (Header blk) , LedgerSupportsProtocol blk @@ -423,12 +536,13 @@ instance ( LogFormatting (Header blk) "Block fits onto some fork: " <> renderRealPointAsPhrase pt forHuman (ChainDB.ChangingSelection pt) = "Changing selection to: " <> renderPointAsPhrase pt - forHuman (ChainDB.AddedToCurrentChain es _ _ c) = + forHuman (ChainDB.AddedToCurrentChain es _ _ c _) = "Chain extended, new tip: " <> renderPointAsPhrase (AF.headPoint c) <> Text.concat [ "\nEvent: " <> showT e | e <- es ] - forHuman (ChainDB.SwitchedToAFork es _ _ c) = + forHuman (ChainDB.SwitchedToAFork es _ _ c reasonForSwitch) = "Switched to a fork, new tip: " <> renderPointAsPhrase (AF.headPoint c) <> - Text.concat [ "\nEvent: " <> showT e | e <- es ] + Text.concat [ "\nEvent: " <> showT e | e <- es ] <> + "\nReason: " <> forHuman reasonForSwitch forHuman (ChainDB.AddBlockValidation ev') = forHuman ev' forHuman (ChainDB.AddedBlockToVolatileDB pt _ _ enclosing) = case enclosing of @@ -480,7 +594,7 @@ instance ( LogFormatting (Header blk) mconcat [ "kind" .= String "TraceAddBlockEvent.ChangingSelection" , "block" .= forMachine dtal pt ] - forMachine DDetailed (ChainDB.AddedToCurrentChain events selChangedInfo base extended) = + forMachine DDetailed (ChainDB.AddedToCurrentChain events selChangedInfo base extended _) = let ChainInformation { .. } = chainInformation selChangedInfo base extended 0 tipBlockIssuerVkHashText :: Text tipBlockIssuerVkHashText = @@ -491,10 +605,10 @@ instance ( LogFormatting (Header blk) in mconcat $ [ "kind" .= String "AddedToCurrentChain" , "newtip" .= renderPointForDetails DDetailed (AF.headPoint extended) - , "newTipSelectView" .= forMachine DDetailed (ChainDB.newTipSelectView selChangedInfo) + , "newSuffixSelectView" .= forMachine DDetailed (ChainDB.newSuffixSelectView selChangedInfo) ] - ++ [ "oldTipSelectView" .= forMachine DDetailed oldTipSelectView - | Just oldTipSelectView <- [ChainDB.oldTipSelectView selChangedInfo] + ++ [ "oldSuffixSelectView" .= forMachine DDetailed oldSuffixSelectView + | Just oldSuffixSelectView <- [ChainDB.oldSuffixSelectView selChangedInfo] ] ++ [ "headers" .= toJSON (forMachine DDetailed `map` addedHdrsNewChain base extended) ] @@ -503,19 +617,18 @@ instance ( LogFormatting (Header blk) ++ [ "tipBlockHash" .= tipBlockHash , "tipBlockParentHash" .= tipBlockParentHash , "tipBlockIssuerVKeyHash" .= tipBlockIssuerVkHashText] - forMachine dtal (ChainDB.AddedToCurrentChain events selChangedInfo _base extended) = + forMachine dtal (ChainDB.AddedToCurrentChain events selChangedInfo _base extended _) = mconcat $ [ "kind" .= String "AddedToCurrentChain" , "newtip" .= renderPointForDetails dtal (AF.headPoint extended) - , "newTipSelectView" .= forMachine dtal (ChainDB.newTipSelectView selChangedInfo) + , "newSuffixSelectView" .= forMachine dtal (ChainDB.newSuffixSelectView selChangedInfo) ] - ++ [ "oldTipSelectView" .= forMachine dtal oldTipSelectView - | Just oldTipSelectView <- [ChainDB.oldTipSelectView selChangedInfo] + ++ [ "oldSuffixSelectView" .= forMachine dtal oldSuffixSelectView + | Just oldSuffixSelectView <- [ChainDB.oldSuffixSelectView selChangedInfo] ] ++ [ "events" .= toJSON (map (forMachine dtal) events) | not (null events) ] - - forMachine DDetailed (ChainDB.SwitchedToAFork events selChangedInfo old new) = + forMachine DDetailed (ChainDB.SwitchedToAFork events selChangedInfo old new reasonForSwitch) = let ChainInformation { .. } = chainInformation selChangedInfo old new 0 tipBlockIssuerVkHashText :: Text tipBlockIssuerVkHashText = @@ -526,10 +639,10 @@ instance ( LogFormatting (Header blk) in mconcat $ [ "kind" .= String "TraceAddBlockEvent.SwitchedToAFork" , "newtip" .= renderPointForDetails DDetailed (AF.headPoint new) - , "newTipSelectView" .= forMachine DDetailed (ChainDB.newTipSelectView selChangedInfo) + , "newSuffixSelectView" .= forMachine DDetailed (ChainDB.newSuffixSelectView selChangedInfo) ] - ++ [ "oldTipSelectView" .= forMachine DDetailed oldTipSelectView - | Just oldTipSelectView <- [ChainDB.oldTipSelectView selChangedInfo] + ++ [ "oldSuffixSelectView" .= forMachine DDetailed oldSuffixSelectView + | Just oldSuffixSelectView <- [ChainDB.oldSuffixSelectView selChangedInfo] ] ++ [ "headers" .= toJSON (forMachine DDetailed `map` addedHdrsNewChain old new) ] @@ -538,17 +651,19 @@ instance ( LogFormatting (Header blk) ++ [ "tipBlockHash" .= tipBlockHash , "tipBlockParentHash" .= tipBlockParentHash , "tipBlockIssuerVKeyHash" .= tipBlockIssuerVkHashText] - forMachine dtal (ChainDB.SwitchedToAFork events selChangedInfo _old new) = + ++ [ "reason" .= forMachine DDetailed reasonForSwitch ] + forMachine dtal (ChainDB.SwitchedToAFork events selChangedInfo _old new reasonForSwitch) = mconcat $ [ "kind" .= String "TraceAddBlockEvent.SwitchedToAFork" , "newtip" .= renderPointForDetails dtal (AF.headPoint new) - , "newTipSelectView" .= forMachine dtal (ChainDB.newTipSelectView selChangedInfo) + , "newSuffixSelectView" .= forMachine dtal (ChainDB.newSuffixSelectView selChangedInfo) ] - ++ [ "oldTipSelectView" .= forMachine dtal oldTipSelectView - | Just oldTipSelectView <- [ChainDB.oldTipSelectView selChangedInfo] + ++ [ "oldSuffixSelectView" .= forMachine dtal oldSuffixSelectView + | Just oldSuffixSelectView <- [ChainDB.oldSuffixSelectView selChangedInfo] ] ++ [ "events" .= toJSON (map (forMachine dtal) events) | not (null events) ] + ++ [ "reason" .= forMachine dtal reasonForSwitch ] forMachine dtal (ChainDB.AddBlockValidation ev') = forMachine dtal ev' @@ -585,7 +700,7 @@ instance ( LogFormatting (Header blk) ] - asMetrics (ChainDB.SwitchedToAFork _warnings selChangedInfo oldChain newChain) = + asMetrics (ChainDB.SwitchedToAFork _warnings selChangedInfo oldChain newChain _) = let forkIt = not $ AF.withinFragmentBounds (AF.headPoint oldChain) newChain ChainInformation { .. } = chainInformation selChangedInfo oldChain newChain 0 @@ -604,7 +719,7 @@ instance ( LogFormatting (Header blk) ,("parent_hash",tipBlockParentHash) ,("issuer_VKey_hash", tipBlockIssuerVkHashText)] ] - asMetrics (ChainDB.AddedToCurrentChain _warnings selChangedInfo oldChain newChain) = + asMetrics (ChainDB.AddedToCurrentChain _warnings selChangedInfo oldChain newChain _) = let ChainInformation { .. } = chainInformation selChangedInfo oldChain newChain 0 tipBlockIssuerVkHashText = @@ -674,11 +789,11 @@ instance MetaTrace (ChainDB.TraceAddBlockEvent blk) where severityFor (Namespace _ ["StoreButDontChange"]) _ = Just Debug severityFor (Namespace _ ["ChangingSelection"]) _ = Just Debug severityFor (Namespace _ ["AddedToCurrentChain"]) - (Just (ChainDB.AddedToCurrentChain events _ _ _)) = + (Just (ChainDB.AddedToCurrentChain events _ _ _ _)) = Just $ maximumDef Notice (map sevLedgerEvent events) severityFor (Namespace _ ["AddedToCurrentChain"]) Nothing = Just Notice severityFor (Namespace _ ["SwitchedToAFork"]) - (Just (ChainDB.SwitchedToAFork events _ _ _)) = + (Just (ChainDB.SwitchedToAFork events _ _ _ _)) = Just $ maximumDef Notice (map sevLedgerEvent events) severityFor (Namespace _ ["SwitchedToAFork"]) _ = Just Notice @@ -1822,29 +1937,43 @@ instance LogFormatting LedgerDB.TraceForkerEventWithKey where "Forker " <> showT k <> ": " <> forHuman ev instance LogFormatting LedgerDB.TraceForkerEvent where - forMachine _dtals LedgerDB.ForkerOpen = mempty - forMachine _dtals LedgerDB.ForkerCloseUncommitted = mempty - forMachine _dtals LedgerDB.ForkerCloseCommitted = mempty - forMachine _dtals LedgerDB.ForkerReadTablesStart = mempty - forMachine _dtals LedgerDB.ForkerReadTablesEnd = mempty - forMachine _dtals LedgerDB.ForkerRangeReadTablesStart = mempty - forMachine _dtals LedgerDB.ForkerRangeReadTablesEnd = mempty + forMachine _dtals LedgerDB.ForkerOpen = + mconcat [ "kind" .= String "ForkerOpen" ] + forMachine _dtals (LedgerDB.ForkerReadTables e) = + mconcat [ "kind" .= String "ForkerReadTables" + , "edge" .= case e of + RisingEdge -> String "RisingEdge" + FallingEdgeWith t -> toJSON t + ] + forMachine _dtals (LedgerDB.ForkerRangeReadTables e) = + mconcat [ "kind" .= String "ForkerRangeReadTables" + , "edge" .= case e of + RisingEdge -> String "RisingEdge" + FallingEdgeWith t -> toJSON t + ] forMachine _dtals LedgerDB.ForkerReadStatistics = mempty - forMachine _dtals LedgerDB.ForkerPushStart = mempty - forMachine _dtals LedgerDB.ForkerPushEnd = mempty - forMachine _dtals LedgerDB.DanglingForkerClosed = mempty + forMachine _dtals (LedgerDB.ForkerPush e) = + mconcat [ "kind" .= String "ForkerPush" + , "edge" .= case e of + RisingEdge -> String "RisingEdge" + FallingEdgeWith t -> toJSON t + ] + forMachine _dtals (LedgerDB.ForkerClose wc) = + mconcat [ "kind" .= String "ForkerClose" + , "wasCommitted" .= toJSON (wc == LedgerDB.ForkerWasCommitted) + ] forHuman LedgerDB.ForkerOpen = "Opened forker" - forHuman LedgerDB.ForkerCloseUncommitted = "Forker closed without committing" - forHuman LedgerDB.ForkerCloseCommitted = "Forker closed after committing" - forHuman LedgerDB.ForkerReadTablesStart = "Started to read tables" - forHuman LedgerDB.ForkerReadTablesEnd = "Finish reading tables" - forHuman LedgerDB.ForkerRangeReadTablesStart = "Started to range read tables" - forHuman LedgerDB.ForkerRangeReadTablesEnd = "Finish range reading tables" - forHuman LedgerDB.ForkerReadStatistics = "Gathering statistics" - forHuman LedgerDB.ForkerPushStart = "Started to push" - forHuman LedgerDB.ForkerPushEnd = "Pushed" - forHuman LedgerDB.DanglingForkerClosed = "Closed dangling forker" + forHuman (LedgerDB.ForkerReadTables RisingEdge) = "Forker reading tables" + forHuman (LedgerDB.ForkerReadTables (FallingEdgeWith t)) = "Forker read tables, took " <> showT t + forHuman (LedgerDB.ForkerRangeReadTables RisingEdge) = "Forker range reading tables" + forHuman (LedgerDB.ForkerRangeReadTables (FallingEdgeWith t)) = "Forker range read tables, took " <> showT t + forHuman LedgerDB.ForkerReadStatistics = "Forker gathering statistics" + forHuman (LedgerDB.ForkerPush RisingEdge) = "Forker pushing" + forHuman (LedgerDB.ForkerPush (FallingEdgeWith t)) = "Forker pushed, took " <> showT t + forHuman (LedgerDB.ForkerClose wc) = "Closed forker, " <> case wc of + LedgerDB.ForkerWasCommitted -> "was committed" + LedgerDB.ForkerWasUncommitted -> "was discarded" instance MetaTrace LedgerDB.TraceForkerEventWithKey where namespaceFor (LedgerDB.TraceForkerEventWithKey _ ev) = @@ -1858,48 +1987,29 @@ instance MetaTrace LedgerDB.TraceForkerEventWithKey where instance MetaTrace LedgerDB.TraceForkerEvent where namespaceFor LedgerDB.ForkerOpen = Namespace [] ["Open"] - namespaceFor LedgerDB.ForkerCloseUncommitted = Namespace [] ["CloseUncommitted"] - namespaceFor LedgerDB.ForkerCloseCommitted = Namespace [] ["CloseCommitted"] - namespaceFor LedgerDB.ForkerReadTablesStart = Namespace [] ["StartRead"] - namespaceFor LedgerDB.ForkerReadTablesEnd = Namespace [] ["FinishRead"] - namespaceFor LedgerDB.ForkerRangeReadTablesStart = Namespace [] ["StartRangeRead"] - namespaceFor LedgerDB.ForkerRangeReadTablesEnd = Namespace [] ["FinishRangeRead"] + namespaceFor LedgerDB.ForkerReadTables{} = Namespace [] ["Read"] + namespaceFor LedgerDB.ForkerRangeReadTables{} = Namespace [] ["RangeRead"] namespaceFor LedgerDB.ForkerReadStatistics = Namespace [] ["Statistics"] - namespaceFor LedgerDB.ForkerPushStart = Namespace [] ["StartPush"] - namespaceFor LedgerDB.ForkerPushEnd = Namespace [] ["FinishPush"] - namespaceFor LedgerDB.DanglingForkerClosed = Namespace [] ["DanglingForkerClosed"] + namespaceFor LedgerDB.ForkerPush{} = Namespace [] ["Push"] + namespaceFor LedgerDB.ForkerClose{} = Namespace [] ["Close"] severityFor _ _ = Just Debug - documentFor (Namespace _ ("Open" : _tl)) = Just - "A forker is being opened" - documentFor (Namespace _ ("CloseUncommitted" : _tl)) = Just $ - mconcat [ "A forker was closed without being committed." - , " This is usually the case with forkers that are not opened for chain selection," - , " and for forkers on discarded forks"] - documentFor (Namespace _ ("CloseCommitted" : _tl)) = Just "A forker was committed (the LedgerDB was modified accordingly) and closed" - documentFor (Namespace _ ("StartRead" : _tl)) = Just "The process for reading ledger tables started" - documentFor (Namespace _ ("FinishRead" : _tl)) = Just "Values from the ledger tables were read" - documentFor (Namespace _ ("StartRangeRead" : _tl)) = Just "The process for range reading ledger tables started" - documentFor (Namespace _ ("FinishRangeRead" : _tl)) = Just "Values from the ledger tables were range-read" + documentFor (Namespace _ ("Open" : _tl)) = Just "A forker is being opened" + documentFor (Namespace _ ("Read" : _tl)) = Just "A forker is reading values" + documentFor (Namespace _ ("RangeRead" : _tl)) = Just "A forker is range reading values" documentFor (Namespace _ ("Statistics" : _tl)) = Just "Statistics were gathered from the forker" - documentFor (Namespace _ ("StartPush" : _tl)) = Just "A ledger state is going to be pushed to the forker" - documentFor (Namespace _ ("FinishPush" : _tl)) = Just "A ledger state was pushed to the forker" - documentFor (Namespace _ ("DanglingForkerClosed" : _tl)) = Just "A dangling forker was closed" + documentFor (Namespace _ ("Push" : _tl)) = Just "A forker is pushing a new ledger state" + documentFor (Namespace _ ("Close" : _tl)) = Just "A forker was closed" documentFor _ = Nothing allNamespaces = [ Namespace [] ["Open"] - , Namespace [] ["CloseUncommitted"] - , Namespace [] ["CloseCommitted"] - , Namespace [] ["StartRead"] - , Namespace [] ["FinishRead"] - , Namespace [] ["StartRangeRead"] - , Namespace [] ["FinishRangeRead"] + , Namespace [] ["Read"] + , Namespace [] ["RangeRead"] , Namespace [] ["Statistics"] - , Namespace [] ["StartPush"] - , Namespace [] ["FinishPush"] - , Namespace [] ["DanglingForkerClosed"] + , Namespace [] ["Push"] + , Namespace [] ["Close"] ] -------------------------------------------------------------------------------- @@ -1920,52 +2030,93 @@ instance MetaTrace LedgerDB.FlavorImplSpecificTrace where nsPrependInner "V2" (namespaceFor ev) severityFor (Namespace out ("V1" : tl)) Nothing = - severityFor (Namespace out tl :: Namespace V1.FlavorImplSpecificTrace) Nothing + severityFor (Namespace out tl :: Namespace V1.SomeBackendTrace) Nothing severityFor (Namespace out ("V1" : tl)) (Just (LedgerDB.FlavorImplSpecificTraceV1 ev)) = - severityFor (Namespace out tl :: Namespace V1.FlavorImplSpecificTrace) (Just ev) + severityFor (Namespace out tl :: Namespace V1.SomeBackendTrace) (Just ev) severityFor (Namespace out ("V2" : tl)) Nothing = - severityFor (Namespace out tl :: Namespace V2.FlavorImplSpecificTrace) Nothing + severityFor (Namespace out tl :: Namespace V2.LedgerDBV2Trace) Nothing severityFor (Namespace out ("V2" : tl)) (Just (LedgerDB.FlavorImplSpecificTraceV2 ev)) = - severityFor (Namespace out tl :: Namespace V2.FlavorImplSpecificTrace) (Just ev) + severityFor (Namespace out tl :: Namespace V2.LedgerDBV2Trace) (Just ev) severityFor _ _ = Nothing documentFor (Namespace out ("V1" : tl)) = - documentFor (Namespace out tl :: Namespace V1.FlavorImplSpecificTrace) + documentFor (Namespace out tl :: Namespace V1.SomeBackendTrace) documentFor (Namespace out ("V2" : tl)) = - documentFor (Namespace out tl :: Namespace V2.FlavorImplSpecificTrace) + documentFor (Namespace out tl :: Namespace V2.LedgerDBV2Trace) documentFor _ = Nothing allNamespaces = map (nsPrependInner "V1") - (allNamespaces :: [Namespace V1.FlavorImplSpecificTrace]) + (allNamespaces :: [Namespace V1.SomeBackendTrace]) ++ map (nsPrependInner "V2") - (allNamespaces :: [Namespace V2.FlavorImplSpecificTrace]) + (allNamespaces :: [Namespace V2.LedgerDBV2Trace]) -------------------------------------------------------------------------------- -- V1 -------------------------------------------------------------------------------- -instance LogFormatting V1.FlavorImplSpecificTrace where - forMachine dtal (V1.FlavorImplSpecificTraceInMemory ev) = forMachine dtal ev - forMachine dtal (V1.FlavorImplSpecificTraceOnDisk ev) = forMachine dtal ev +unwrapV1Trace :: forall a backend. Typeable backend => (V1.Trace LMDB.LMDB -> a) -> V1.Trace backend -> a +unwrapV1Trace g ev = + case cast @(V1.Trace backend) @(V1.Trace LMDB.LMDB) ev of + Just t -> g t + _ -> error "blah" - forHuman (V1.FlavorImplSpecificTraceInMemory ev) = forHuman ev - forHuman (V1.FlavorImplSpecificTraceOnDisk ev) = forHuman ev +instance LogFormatting V1.SomeBackendTrace where + forMachine dtal (V1.SomeBackendTrace ev) = + unwrapV1Trace (forMachine dtal) ev -instance LogFormatting V1.FlavorImplSpecificTraceInMemory where - forMachine _dtal V1.InMemoryBackingStoreInitialise = mempty - forMachine dtal (V1.InMemoryBackingStoreTrace ev) = forMachine dtal ev + forHuman (V1.SomeBackendTrace ev) = + unwrapV1Trace forHuman ev - forHuman V1.InMemoryBackingStoreInitialise = "Initializing in-memory backing store" - forHuman (V1.InMemoryBackingStoreTrace ev) = forHuman ev +instance MetaTrace V1.SomeBackendTrace where + namespaceFor (V1.SomeBackendTrace ev) = + unwrapV1Trace (nsPrependInner "LMDB" . namespaceFor) ev + + severityFor (Namespace out ("LMDB" : tl)) (Just (V1.SomeBackendTrace ev)) = + unwrapV1Trace (severityFor (Namespace out tl :: Namespace (V1.Trace LMDB.LMDB)) . Just) ev + severityFor (Namespace _ ("LMDB" : _)) Nothing = + Just Debug + severityFor _ _ = Nothing + + documentFor (Namespace _ ("LMDB" : _)) = + Just "An LMDB trace" + documentFor _ = Nothing + + allNamespaces = + map (nsPrependInner "LMDB") + (allNamespaces :: [Namespace (V1.Trace LMDB.LMDB)]) -instance LogFormatting V1.FlavorImplSpecificTraceOnDisk where - forMachine _dtal (V1.OnDiskBackingStoreInitialise limits) = - mconcat [ "limits" .= showT limits ] - forMachine dtal (V1.OnDiskBackingStoreTrace ev) = forMachine dtal ev +instance LogFormatting (V1.Trace LMDB.LMDB) where + forMachine _dtal (LMDB.OnDiskBackingStoreInitialise limits) = + mconcat [ "kind" .= String "LMDBBackingStoreInitialise", "limits" .= showT limits ] + forMachine dtal (LMDB.OnDiskBackingStoreTrace ev) = forMachine dtal ev - forHuman (V1.OnDiskBackingStoreInitialise limits) = "Initializing on-disk backing store with limits " <> showT limits - forHuman (V1.OnDiskBackingStoreTrace ev) = forHuman ev + forHuman (LMDB.OnDiskBackingStoreInitialise limits) = "Initializing LMDB backing store with limits " <> showT limits + forHuman (LMDB.OnDiskBackingStoreTrace ev) = forHuman ev + +instance MetaTrace (V1.Trace LMDB.LMDB) where + namespaceFor LMDB.OnDiskBackingStoreInitialise{} = + Namespace [] ["Initialise"] + namespaceFor (LMDB.OnDiskBackingStoreTrace ev) = + nsPrependInner "BackingStoreEvent" (namespaceFor ev) + + severityFor (Namespace _ ("Initialise" : _)) _ = Just Debug + severityFor (Namespace out ("BackingStoreEvent" : tl)) Nothing = + severityFor (Namespace out tl :: Namespace V1.BackingStoreTrace) Nothing + severityFor (Namespace out ("BackingStoreEvent" : tl)) (Just (LMDB.OnDiskBackingStoreTrace ev)) = + severityFor (Namespace out tl :: Namespace V1.BackingStoreTrace) (Just ev) + severityFor _ _ = Nothing + + documentFor (Namespace _ ("Initialise" : _)) = Just + "Backing store is being initialised" + documentFor (Namespace out ("BackingStoreEvent" : tl)) = + documentFor (Namespace out tl :: Namespace V1.BackingStoreTrace) + documentFor _ = Nothing + + allNamespaces = + Namespace [] ["Initialise"] + : map (nsPrependInner "BackingStoreEvent") + (allNamespaces :: [Namespace V1.BackingStoreTrace]) instance LogFormatting V1.BackingStoreTrace where forMachine _dtals V1.BSOpening = mempty @@ -2005,81 +2156,6 @@ instance LogFormatting V1.BackingStoreValueHandleTrace where forMachine _dtals V1.BSVHStatting = mempty forMachine _dtals V1.BSVHStatted = mempty -instance MetaTrace V1.FlavorImplSpecificTrace where - namespaceFor (V1.FlavorImplSpecificTraceInMemory ev) = - nsPrependInner "InMemory" (namespaceFor ev) - namespaceFor (V1.FlavorImplSpecificTraceOnDisk ev) = - nsPrependInner "OnDisk" (namespaceFor ev) - - severityFor (Namespace out ("InMemory" : tl)) Nothing = - severityFor (Namespace out tl :: Namespace V1.FlavorImplSpecificTraceInMemory) Nothing - severityFor (Namespace out ("InMemory" : tl)) (Just (V1.FlavorImplSpecificTraceInMemory ev)) = - severityFor (Namespace out tl :: Namespace V1.FlavorImplSpecificTraceInMemory) (Just ev) - severityFor (Namespace out ("OnDisk" : tl)) Nothing = - severityFor (Namespace out tl :: Namespace V1.FlavorImplSpecificTraceOnDisk) Nothing - severityFor (Namespace out ("OnDisk" : tl)) (Just (V1.FlavorImplSpecificTraceOnDisk ev)) = - severityFor (Namespace out tl :: Namespace V1.FlavorImplSpecificTraceOnDisk) (Just ev) - severityFor _ _ = Nothing - - documentFor (Namespace out ("InMemory" : tl)) = - documentFor (Namespace out tl :: Namespace V1.FlavorImplSpecificTraceInMemory) - documentFor (Namespace out ("OnDisk" : tl)) = - documentFor (Namespace out tl :: Namespace V1.FlavorImplSpecificTraceOnDisk) - documentFor _ = Nothing - - allNamespaces = - map (nsPrependInner "InMemory") - (allNamespaces :: [Namespace V1.FlavorImplSpecificTraceInMemory]) - ++ map (nsPrependInner "OnDisk") - (allNamespaces :: [Namespace V1.FlavorImplSpecificTraceOnDisk]) - -instance MetaTrace V1.FlavorImplSpecificTraceInMemory where - namespaceFor V1.InMemoryBackingStoreInitialise = Namespace [] ["Initialise"] - namespaceFor (V1.InMemoryBackingStoreTrace bsTrace) = - nsPrependInner "BackingStoreEvent" (namespaceFor bsTrace) - - severityFor (Namespace _ ("Initialise" : _)) _ = Just Debug - severityFor (Namespace out ("BackingStoreEvent" : tl)) Nothing = - severityFor (Namespace out tl :: Namespace V1.BackingStoreTrace) Nothing - severityFor (Namespace out ("BackingStoreEvent" : tl)) (Just (V1.InMemoryBackingStoreTrace ev)) = - severityFor (Namespace out tl :: Namespace V1.BackingStoreTrace) (Just ev) - severityFor _ _ = Nothing - - documentFor (Namespace _ ("Initialise" : _)) = Just - "Backing store is being initialised" - documentFor (Namespace out ("BackingStoreEvent" : tl)) = - documentFor (Namespace out tl :: Namespace V1.BackingStoreTrace) - documentFor _ = Nothing - - allNamespaces = - Namespace [] ["Initialise"] - : map (nsPrependInner "BackingStoreEvent") - (allNamespaces :: [Namespace V1.BackingStoreTrace]) - -instance MetaTrace V1.FlavorImplSpecificTraceOnDisk where - namespaceFor V1.OnDiskBackingStoreInitialise{} = - Namespace [] ["Initialise"] - namespaceFor (V1.OnDiskBackingStoreTrace ev) = - nsPrependInner "BackingStoreEvent" (namespaceFor ev) - - severityFor (Namespace _ ("Initialise" : _)) _ = Just Debug - severityFor (Namespace out ("BackingStoreEvent" : tl)) Nothing = - severityFor (Namespace out tl :: Namespace V1.BackingStoreTrace) Nothing - severityFor (Namespace out ("BackingStoreEvent" : tl)) (Just (V1.OnDiskBackingStoreTrace ev)) = - severityFor (Namespace out tl :: Namespace V1.BackingStoreTrace) (Just ev) - severityFor _ _ = Nothing - - documentFor (Namespace _ ("Initialise" : _)) = Just - "Backing store is being initialised" - documentFor (Namespace out ("BackingStoreEvent" : tl)) = - documentFor (Namespace out tl :: Namespace V1.BackingStoreTrace) - documentFor _ = Nothing - - allNamespaces = - Namespace [] ["Initialise"] - : map (nsPrependInner "BackingStoreEvent") - (allNamespaces :: [Namespace V1.BackingStoreTrace]) - instance MetaTrace V1.BackingStoreTrace where namespaceFor V1.BSOpening = Namespace [] ["Opening"] namespaceFor V1.BSOpened{} = Namespace [] ["Opened"] @@ -2238,43 +2314,158 @@ instance MetaTrace V1.BackingStoreValueHandleTrace where , Namespace [] ["Statted"] ] -instance LogFormatting V2.FlavorImplSpecificTrace where - forMachine _dtal V2.TraceLedgerTablesHandleCreate = - mconcat [ "kind" .= String "LedgerTablesHandleCreate" ] - forMachine _dtal V2.TraceLedgerTablesHandleClose = - mconcat [ "kind" .= String "LedgerTablesHandleClose" ] - - forHuman V2.TraceLedgerTablesHandleCreate = - "Created a new 'LedgerTablesHandle', potentially by duplicating an existing one" - forHuman V2.TraceLedgerTablesHandleClose = - "Closed a 'LedgerTablesHandle'" - -instance MetaTrace V2.FlavorImplSpecificTrace where - namespaceFor V2.TraceLedgerTablesHandleCreate = +{------------------------------------------------------------------------------- + V2 +-------------------------------------------------------------------------------} + +instance LogFormatting EnclosingTimed where + forMachine _dtal RisingEdge = mconcat [ "edge" .= String "Starting" ] + forMachine _dtal (FallingEdgeWith a) = mconcat [ "edge" .= toJSON a ] + + forHuman RisingEdge = "Starting" + forHuman (FallingEdgeWith a) = "Completed in " <> showT a <> " seconds" + +instance LogFormatting V2.LedgerDBV2Trace where + forMachine dtal (V2.TraceLedgerTablesHandleCreate enc) = + mconcat [ "kind" .= String "LedgerTablesHandleCreate", "enclosing" .= forMachine dtal enc ] + forMachine dtal (V2.TraceLedgerTablesHandleClose enc) = + mconcat [ "kind" .= String "LedgerTablesHandleClose", "enclosing" .= forMachine dtal enc ] + forMachine dtal (V2.BackendTrace ev) = forMachine dtal ev + forMachine dtal (V2.TraceLedgerTablesHandleRead enc) = + mconcat [ "kind" .= String "LedgerTablesHandleRead", "enclosing" .= forMachine dtal enc ] + forMachine dtal (V2.TraceLedgerTablesHandleDuplicate enc) = + mconcat [ "kind" .= String "LedgerTablesHandleDuplicate", "enclosing" .= forMachine dtal enc ] + forMachine dtal (V2.TraceLedgerTablesHandleCreateFirst enc) = + mconcat [ "kind" .= String "LedgerTablesHandleCreateFirst", "enclosing" .= forMachine dtal enc ] + forMachine dtal (V2.TraceLedgerTablesHandlePush enc) = + mconcat [ "kind" .= String "LedgerTablesHandlePush", "enclosing" .= forMachine dtal enc ] + + forHuman (V2.TraceLedgerTablesHandleCreate enc) = "Created a new 'LedgerTablesHandle': " <> forHuman enc + forHuman (V2.TraceLedgerTablesHandleClose enc) = "Closed a 'LedgerTablesHandle': " <> forHuman enc + forHuman (V2.BackendTrace ev) = forHuman ev + forHuman (V2.TraceLedgerTablesHandleRead enc) = "Read from a 'LedgerTablesHandle': " <> forHuman enc + forHuman (V2.TraceLedgerTablesHandleDuplicate enc) = "Duplicating a 'LedgerTablesHandle': " <> forHuman enc + forHuman (V2.TraceLedgerTablesHandleCreateFirst enc) = "Creating the first 'LedgerTablesHandle': " <> forHuman enc + forHuman (V2.TraceLedgerTablesHandlePush enc) = "Pushing to 'LedgerTablesHandle': " <> forHuman enc + +instance MetaTrace V2.LedgerDBV2Trace where + namespaceFor V2.TraceLedgerTablesHandleCreate{} = Namespace [] ["LedgerTablesHandleCreate"] - namespaceFor V2.TraceLedgerTablesHandleClose = + namespaceFor V2.TraceLedgerTablesHandleClose{} = Namespace [] ["LedgerTablesHandleClose"] + namespaceFor (V2.BackendTrace ev) = nsPrependInner "BackendTrace" (namespaceFor ev) + namespaceFor V2.TraceLedgerTablesHandleRead{} = Namespace [] ["LedgerTablesHandleRead"] + namespaceFor V2.TraceLedgerTablesHandleDuplicate{} = Namespace [] ["LedgerTablesHandleDuplicate"] + namespaceFor V2.TraceLedgerTablesHandleCreateFirst{} = Namespace [] ["LedgerTablesHandleCreateFirst"] + namespaceFor V2.TraceLedgerTablesHandlePush{} = Namespace [] ["LedgerTablesHandlePush"] severityFor (Namespace _ ["LedgerTablesHandleCreate"]) _ = Just Debug severityFor (Namespace _ ["LedgerTablesHandleClose"]) _ = Just Debug + severityFor (Namespace _ ["LedgerTablesHandleRead"]) _ = Just Debug + severityFor (Namespace _ ["LedgerTablesHandleDuplicate"]) _ = Just Debug + severityFor (Namespace _ ["LedgerTablesHandleCreateFirst"]) _ = Just Debug + severityFor (Namespace _ ["LedgerTablesHandlePush"]) _ = Just Debug + severityFor (Namespace _ ("BackendTrace":_)) _ = Just Debug severityFor _ _ = Nothing - -- suspicious - privacyFor (Namespace _ ["LedgerTablesHandleCreate"]) _ = Just Public - privacyFor (Namespace _ ["LedgerTablesHandleClose"]) _ = Just Public - privacyFor _ _ = Just Public - documentFor (Namespace _ ["LedgerTablesHandleCreate"]) = - Just "An in-memory backing store event" + Just "Created a ledger tables handle" documentFor (Namespace _ ["LedgerTablesHandleClose"]) = - Just "An on-disk backing store event" + Just "Closed a ledger tables handle" + documentFor (Namespace _ ["LedgerTablesHandleRead"]) = + Just "Reading from ledger tables handle" + documentFor (Namespace _ ["LedgerTablesHandlePush"]) = + Just "Pushing to a ledger tables handle" + documentFor (Namespace _ ["LedgerTablesHandleCreateFirst"]) = + Just "Creating the first ledger tables handle" + documentFor (Namespace _ ["LedgerTablesHandleDuplicate"]) = + Just "Duplicating a ledger tables handle" documentFor _ = Nothing allNamespaces = [ Namespace [] ["LedgerTablesHandleCreate"] , Namespace [] ["LedgerTablesHandleClose"] + , Namespace [] ["LedgerTablesHandleRead"] + , Namespace [] ["LedgerTablesHandleDuplicate"] + , Namespace [] ["LedgerTablesHandleCreateFirst"] + , Namespace [] ["LedgerTablesHandlePush"] + ] ++ map (nsPrependInner "BackendTrace") (allNamespaces :: [Namespace V2.SomeBackendTrace]) + +instance LogFormatting V2.SomeBackendTrace where + forMachine dtal (V2.SomeBackendTrace ev) = unwrapV2Trace (forMachine dtal) ev + + forHuman (V2.SomeBackendTrace ev) = unwrapV2Trace forHuman ev + +instance MetaTrace V2.SomeBackendTrace where + namespaceFor (V2.SomeBackendTrace ev) = + unwrapV2Trace (nsPrependInner "LSM" . namespaceFor) ev + + severityFor (Namespace _ ("LSM" : _)) _ = Just Debug + severityFor _ _ = Nothing + + documentFor (Namespace out ("LSM" : tl)) = documentFor @(V2.Trace LSM.LSM) (Namespace out tl) + documentFor _ = Nothing + + allNamespaces = + map (nsPrependInner "LSM") (allNamespaces :: [Namespace (V2.Trace LSM.LSM)]) + +instance LogFormatting (V2.Trace LSM.LSM) where + forMachine _dtal (LSM.LSMTreeTrace ev) = mconcat [ "kind" .= String "LSMTreeTrace", "content" .= showT ev] + forMachine dtal (LSM.LSMLookup enc) = mconcat [ "kind" .= String "LSMLookup", "enclosing" .= forMachine dtal enc] + forMachine dtal (LSM.LSMUpdate enc) = mconcat [ "kind" .= String "LSMUpdate", "enclosing" .= forMachine dtal enc] + forMachine dtal (LSM.LSMSnap enc) = mconcat [ "kind" .= String "LSMSnap", "enclosing" .= forMachine dtal enc] + forMachine dtal (LSM.LSMOpenSession enc) = mconcat [ "kind" .= String "LSMOpenSession", "enclosing" .= forMachine dtal enc] + + forHuman (LSM.LSMTreeTrace ev) = showT ev + forHuman (LSM.LSMLookup enc) = "Looking up in LSM database: " <> forHuman enc + forHuman (LSM.LSMUpdate enc) = "Updating the LSM database: " <> forHuman enc + forHuman (LSM.LSMSnap enc) = "Snapshotting the LSM database: " <> forHuman enc + forHuman (LSM.LSMOpenSession enc) = "Opening the LSM session: " <> forHuman enc + + +instance MetaTrace (V2.Trace LSM.LSM) where + namespaceFor LSM.LSMTreeTrace{} = Namespace [] ["LSMTrace"] + namespaceFor LSM.LSMLookup {} = Namespace [] ["LSMLookup"] + namespaceFor LSM.LSMUpdate {} = Namespace [] ["LSMUpdate"] + namespaceFor LSM.LSMSnap {} = Namespace [] ["LSMSnap"] + namespaceFor LSM.LSMOpenSession {} = Namespace [] ["LSMOpenSession"] + + severityFor (Namespace _ ["LSMTrace"]) _ = Just Debug + severityFor (Namespace _ ["LSMLookup"]) _ = Just Debug + severityFor (Namespace _ ["LSMUpdate"]) _ = Just Debug + severityFor (Namespace _ ["LSMSnap"]) _ = Just Debug + severityFor (Namespace _ ["LSMOpenSession"]) _ = Just Debug + severityFor _ _ = Nothing + + documentFor (Namespace _ ["LSMTrace"]) = + Just "A trace from the LSM-trees backend" + documentFor (Namespace _ ["LSMLookup"]) = + Just "Looking up in the LSM-trees backend" + documentFor (Namespace _ ["LSMUpdate"]) = + Just "Updating the LSM-trees backend" + documentFor (Namespace _ ["LSMSnap"]) = + Just "Snapshotting the LSM-trees backend" + documentFor (Namespace _ ["LSMOpenSession"]) = + Just "Opening the LSM-trees backend session" + documentFor _ = Nothing + + allNamespaces = + [ Namespace [] ["LSMTrace"] + , Namespace [] ["LSMLookup"] + , Namespace [] ["LSMUpdate"] + , Namespace [] ["LSMSnap"] + , Namespace [] ["LSMOpenSession"] ] +unwrapV2Trace :: forall a backend. Typeable backend => (V2.Trace LSM.LSM -> a) -> V2.Trace backend -> a +unwrapV2Trace g ev = + case cast @(V2.Trace backend) @(V2.Trace InMemory.Mem) ev of + Just (InMemory.NoTrace v) -> absurd v + Nothing -> + case cast @(V2.Trace backend) @(V2.Trace LSM.LSM) ev of + Just t -> g t + _ -> error "blah" + -------------------------------------------------------------------------------- -- ImmDB.TraceEvent -------------------------------------------------------------------------------- @@ -2889,3 +3080,186 @@ instance (Show (PBFT.PBftVerKeyHash c)) [ "kind" .= String "PBftCannotForgeThresholdExceeded" , "numForged" .= numForged ] + +-- PerasCertDB.TraceEvent instances +instance LogFormatting (PerasCertDB.TraceEvent blk) where + forHuman (PerasCertDB.AddedPerasCert _cert _peer) = "Added Peras certificate to database" + forHuman (PerasCertDB.IgnoredCertAlreadyInDB _cert _peer) = "Ignored Peras certificate already in database" + forHuman PerasCertDB.OpenedPerasCertDB = "Opened Peras certificate database" + forHuman PerasCertDB.ClosedPerasCertDB = "Closed Peras certificate database" + forHuman (PerasCertDB.AddingPerasCert _cert _peer) = "Adding Peras certificate to database" + + forMachine _dtal (PerasCertDB.AddedPerasCert cert _peer) = + mconcat ["kind" .= String "AddedPerasCert", + "cert" .= String (Text.pack $ show cert)] + forMachine _dtal (PerasCertDB.IgnoredCertAlreadyInDB cert _peer) = + mconcat ["kind" .= String "IgnoredCertAlreadyInDB", + "cert" .= String (Text.pack $ show cert)] + forMachine _dtal PerasCertDB.OpenedPerasCertDB = + mconcat ["kind" .= String "OpenedPerasCertDB"] + forMachine _dtal PerasCertDB.ClosedPerasCertDB = + mconcat ["kind" .= String "ClosedPerasCertDB"] + forMachine _dtal (PerasCertDB.AddingPerasCert cert _peer) = + mconcat ["kind" .= String "AddingPerasCert", + "cert" .= String (Text.pack $ show cert)] + + asMetrics _ = [] + +-- ChainDB.TraceAddPerasCertEvent instances +instance ConvertRawHash blk => LogFormatting (ChainDB.TraceAddPerasCertEvent blk) where + forHuman (ChainDB.AddedPerasCertToQueue roundNo boostedBlock _queueSize) = + "Added Peras certificate for round " <> Text.pack (show roundNo) <> + " boosting block " <> renderPoint boostedBlock <> " to queue" + forHuman (ChainDB.PoppedPerasCertFromQueue roundNo boostedBlock) = + "Popped Peras certificate for round " <> Text.pack (show roundNo) <> + " boosting block " <> renderPoint boostedBlock <> " from queue" + forHuman (ChainDB.IgnorePerasCertTooOld roundNo boostedBlock immutableSlot) = + "Ignored Peras certificate for round " <> Text.pack (show roundNo) <> + " boosting block " <> renderPoint boostedBlock <> + " (too old, immutable slot: " <> renderPoint (AF.anchorToPoint immutableSlot) <> ")" + forHuman (ChainDB.PerasCertBoostsCurrentChain roundNo boostedBlock) = + "Peras certificate for round " <> Text.pack (show roundNo) <> + " boosts current chain block " <> renderPoint boostedBlock + forHuman (ChainDB.PerasCertBoostsGenesis roundNo) = + "Peras certificate for round " <> Text.pack (show roundNo) <> " boosts Genesis" + forHuman (ChainDB.PerasCertBoostsBlockNotYetReceived roundNo boostedBlock) = + "Peras certificate for round " <> Text.pack (show roundNo) <> + " boosts block " <> renderPoint boostedBlock <> " not yet received" + forHuman (ChainDB.ChainSelectionForBoostedBlock roundNo boostedBlock) = + "Chain selection for block " <> renderPoint boostedBlock <> + " boosted by Peras certificate from round " <> Text.pack (show roundNo) + + forMachine _dtal (ChainDB.AddedPerasCertToQueue roundNo boostedBlock queueSize) = + mconcat ["kind" .= String "AddedPerasCertToQueue", + "round" .= String (Text.pack $ show roundNo), + "boostedBlock" .= String (renderPoint boostedBlock), + "queueSize" .= toJSON queueSize] + forMachine _dtal (ChainDB.PoppedPerasCertFromQueue roundNo boostedBlock) = + mconcat ["kind" .= String "PoppedPerasCertFromQueue", + "round" .= String (Text.pack $ show roundNo), + "boostedBlock" .= String (renderPoint boostedBlock)] + forMachine _dtal (ChainDB.IgnorePerasCertTooOld roundNo boostedBlock immutableSlot) = + mconcat ["kind" .= String "IgnorePerasCertTooOld", + "round" .= String (Text.pack $ show roundNo), + "boostedBlock" .= String (renderPoint boostedBlock), + "immutableSlot" .= String (renderPoint (AF.anchorToPoint immutableSlot))] + forMachine _dtal (ChainDB.PerasCertBoostsCurrentChain roundNo boostedBlock) = + mconcat ["kind" .= String "PerasCertBoostsCurrentChain", + "round" .= String (Text.pack $ show roundNo), + "boostedBlock" .= String (renderPoint boostedBlock)] + forMachine _dtal (ChainDB.PerasCertBoostsGenesis roundNo) = + mconcat ["kind" .= String "PerasCertBoostsGenesis", + "round" .= String (Text.pack $ show roundNo)] + forMachine _dtal (ChainDB.PerasCertBoostsBlockNotYetReceived roundNo boostedBlock) = + mconcat ["kind" .= String "PerasCertBoostsBlockNotYetReceived", + "round" .= String (Text.pack $ show roundNo), + "boostedBlock" .= String (renderPoint boostedBlock)] + forMachine _dtal (ChainDB.ChainSelectionForBoostedBlock roundNo boostedBlock) = + mconcat ["kind" .= String "ChainSelectionForBoostedBlock", + "round" .= String (Text.pack $ show roundNo), + "boostedBlock" .= String (renderPoint boostedBlock)] + + asMetrics _ = [] + +-- PerasCertDB.TraceEvent MetaTrace instance +instance MetaTrace (PerasCertDB.TraceEvent blk) where + namespaceFor (PerasCertDB.AddedPerasCert _ _) = + Namespace [] ["AddedPerasCert"] + namespaceFor (PerasCertDB.IgnoredCertAlreadyInDB _ _) = + Namespace [] ["IgnoredCertAlreadyInDB"] + namespaceFor PerasCertDB.OpenedPerasCertDB = + Namespace [] ["OpenedPerasCertDB"] + namespaceFor PerasCertDB.ClosedPerasCertDB = + Namespace [] ["ClosedPerasCertDB"] + namespaceFor (PerasCertDB.AddingPerasCert _ _) = + Namespace [] ["AddingPerasCert"] + + severityFor (Namespace _ ["AddedPerasCert"]) _ = Just Info + severityFor (Namespace _ ["IgnoredCertAlreadyInDB"]) _ = Just Info + severityFor (Namespace _ ["OpenedPerasCertDB"]) _ = Just Info + severityFor (Namespace _ ["ClosedPerasCertDB"]) _ = Just Info + severityFor (Namespace _ ["AddingPerasCert"]) _ = Just Debug + severityFor _ _ = Nothing + + privacyFor (Namespace _ ["AddedPerasCert"]) _ = Just Public + privacyFor (Namespace _ ["IgnoredCertAlreadyInDB"]) _ = Just Public + privacyFor (Namespace _ ["OpenedPerasCertDB"]) _ = Just Public + privacyFor (Namespace _ ["ClosedPerasCertDB"]) _ = Just Public + privacyFor (Namespace _ ["AddingPerasCert"]) _ = Just Public + privacyFor _ _ = Nothing + + detailsFor (Namespace _ ["AddedPerasCert"]) _ = Just DNormal + detailsFor (Namespace _ ["IgnoredCertAlreadyInDB"]) _ = Just DNormal + detailsFor (Namespace _ ["OpenedPerasCertDB"]) _ = Just DNormal + detailsFor (Namespace _ ["ClosedPerasCertDB"]) _ = Just DNormal + detailsFor (Namespace _ ["AddingPerasCert"]) _ = Just DDetailed + detailsFor _ _ = Nothing + + documentFor (Namespace _ ["AddedPerasCert"]) = Just "Certificate added to Peras certificate database" + documentFor (Namespace _ ["IgnoredCertAlreadyInDB"]) = Just "Certificate ignored as it was already in the database" + documentFor (Namespace _ ["OpenedPerasCertDB"]) = Just "Peras certificate database opened" + documentFor (Namespace _ ["ClosedPerasCertDB"]) = Just "Peras certificate database closed" + documentFor (Namespace _ ["AddingPerasCert"]) = Just "Adding certificate to Peras certificate database" + documentFor _ = Nothing + + allNamespaces = + [Namespace [] ["AddedPerasCert"], + Namespace [] ["IgnoredCertAlreadyInDB"], + Namespace [] ["OpenedPerasCertDB"], + Namespace [] ["ClosedPerasCertDB"], + Namespace [] ["AddingPerasCert"]] + +-- ChainDB.TraceAddPerasCertEvent MetaTrace instance +instance MetaTrace (ChainDB.TraceAddPerasCertEvent blk) where + namespaceFor ChainDB.AddedPerasCertToQueue{} = Namespace [] ["AddedPerasCertToQueue"] + namespaceFor (ChainDB.PoppedPerasCertFromQueue _ _) = Namespace [] ["PoppedPerasCertFromQueue"] + namespaceFor ChainDB.IgnorePerasCertTooOld{} = Namespace [] ["IgnorePerasCertTooOld"] + namespaceFor (ChainDB.PerasCertBoostsCurrentChain _ _) = Namespace [] ["PerasCertBoostsCurrentChain"] + namespaceFor (ChainDB.PerasCertBoostsGenesis _) = Namespace [] ["PerasCertBoostsGenesis"] + namespaceFor (ChainDB.PerasCertBoostsBlockNotYetReceived _ _) = Namespace [] ["PerasCertBoostsBlockNotYetReceived"] + namespaceFor (ChainDB.ChainSelectionForBoostedBlock _ _) = Namespace [] ["ChainSelectionForBoostedBlock"] + + severityFor (Namespace _ ["AddedPerasCertToQueue"]) _ = Just Debug + severityFor (Namespace _ ["PoppedPerasCertFromQueue"]) _ = Just Debug + severityFor (Namespace _ ["IgnorePerasCertTooOld"]) _ = Just Info + severityFor (Namespace _ ["PerasCertBoostsCurrentChain"]) _ = Just Info + severityFor (Namespace _ ["PerasCertBoostsGenesis"]) _ = Just Info + severityFor (Namespace _ ["PerasCertBoostsBlockNotYetReceived"]) _ = Just Info + severityFor (Namespace _ ["ChainSelectionForBoostedBlock"]) _ = Just Info + severityFor _ _ = Nothing + + privacyFor (Namespace _ ["AddedPerasCertToQueue"]) _ = Just Public + privacyFor (Namespace _ ["PoppedPerasCertFromQueue"]) _ = Just Public + privacyFor (Namespace _ ["IgnorePerasCertTooOld"]) _ = Just Public + privacyFor (Namespace _ ["PerasCertBoostsCurrentChain"]) _ = Just Public + privacyFor (Namespace _ ["PerasCertBoostsGenesis"]) _ = Just Public + privacyFor (Namespace _ ["PerasCertBoostsBlockNotYetReceived"]) _ = Just Public + privacyFor (Namespace _ ["ChainSelectionForBoostedBlock"]) _ = Just Public + privacyFor _ _ = Nothing + + detailsFor (Namespace _ ["AddedPerasCertToQueue"]) _ = Just DDetailed + detailsFor (Namespace _ ["PoppedPerasCertFromQueue"]) _ = Just DDetailed + detailsFor (Namespace _ ["IgnorePerasCertTooOld"]) _ = Just DNormal + detailsFor (Namespace _ ["PerasCertBoostsCurrentChain"]) _ = Just DNormal + detailsFor (Namespace _ ["PerasCertBoostsGenesis"]) _ = Just DNormal + detailsFor (Namespace _ ["PerasCertBoostsBlockNotYetReceived"]) _ = Just DNormal + detailsFor (Namespace _ ["ChainSelectionForBoostedBlock"]) _ = Just DNormal + detailsFor _ _ = Nothing + + documentFor (Namespace _ ["AddedPerasCertToQueue"]) = Just "Peras certificate added to processing queue" + documentFor (Namespace _ ["PoppedPerasCertFromQueue"]) = Just "Peras certificate popped from processing queue" + documentFor (Namespace _ ["IgnorePerasCertTooOld"]) = Just "Peras certificate ignored as it is too old compared to immutable slot" + documentFor (Namespace _ ["PerasCertBoostsCurrentChain"]) = Just "Peras certificate boosts a block on the current selection" + documentFor (Namespace _ ["PerasCertBoostsGenesis"]) = Just "Peras certificate boosts the Genesis point" + documentFor (Namespace _ ["PerasCertBoostsBlockNotYetReceived"]) = Just "Peras certificate boosts a block not yet received" + documentFor (Namespace _ ["ChainSelectionForBoostedBlock"]) = Just "Perform chain selection for block boosted by Peras certificate" + documentFor _ = Nothing + + allNamespaces = + [Namespace [] ["AddedPerasCertToQueue"], + Namespace [] ["PoppedPerasCertFromQueue"], + Namespace [] ["IgnorePerasCertTooOld"], + Namespace [] ["PerasCertBoostsCurrentChain"], + Namespace [] ["PerasCertBoostsGenesis"], + Namespace [] ["PerasCertBoostsBlockNotYetReceived"], + Namespace [] ["ChainSelectionForBoostedBlock"]] diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/Consensus.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/Consensus.hs index 14bb1c02994..62eaeecef34 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/Consensus.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/Consensus.hs @@ -69,10 +69,7 @@ import Ouroboros.Network.BlockFetch.ClientState (TraceLabelPeer (..)) import qualified Ouroboros.Network.BlockFetch.ClientState as BlockFetch import Ouroboros.Network.BlockFetch.Decision import Ouroboros.Network.BlockFetch.Decision.Trace (TraceDecisionEvent (..)) -import Ouroboros.Network.ConnectionId (ConnectionId (..)) import Ouroboros.Network.SizeInBytes (SizeInBytes (..)) -import Ouroboros.Network.TxSubmission.Inbound hiding (txId) -import Ouroboros.Network.TxSubmission.Outbound import Control.Monad (guard) import Data.Aeson (ToJSON, Value (..), toJSON, (.=)) @@ -87,15 +84,6 @@ import Data.Time (NominalDiffTime) import Data.Word (Word32, Word64) import Network.TypedProtocol.Core -instance (LogFormatting adr, Show adr) => LogFormatting (ConnectionId adr) where - forMachine _dtal (ConnectionId local' remote) = - mconcat [ "connectionId" .= String (showT local' - <> " " - <> showT remote) - ] - forHuman (ConnectionId local' remote) = - "ConnectionId " <> showT local' <> " " <> showT remote - -------------------------------------------------------------------------------- -- TraceLabelCreds peer a -------------------------------------------------------------------------------- @@ -669,7 +657,7 @@ instance MetaTrace (TraceDecisionEvent peer (Header blk)) where allNamespaces = [ Namespace [] ["PeersFetch"], Namespace [] ["PeerStarvedUs"] ] -instance (Show peer, ToJSON peer, ConvertRawHash (Header blk), HasHeader blk) +instance (Show peer, ToJSON peer, ConvertRawHash (Header blk), HasHeader blk, ToJSON (HeaderHash blk)) => LogFormatting (TraceDecisionEvent peer (Header blk)) where forHuman = Text.pack . show @@ -694,7 +682,7 @@ instance (LogFormatting peer, Show peer) => , "peers" .= toJSON (List.foldl' (\acc x -> forMachine DDetailed x : acc) [] xs) ] - asMetrics peers = [IntM "connectedPeers" (fromIntegral (length peers))] + asMetrics _ = [] instance MetaTrace [TraceLabelPeer peer (FetchDecision [Point header])] where namespaceFor (a : _tl) = (nsCast . namespaceFor) a @@ -1063,157 +1051,6 @@ instance LogFormatting SanityCheckIssue where forHuman (InconsistentSecurityParam e) = "Configuration contains multiple security parameters: " <> Text.pack (show e) - - --------------------------------------------------------------------------------- --- TxInbound Tracer --------------------------------------------------------------------------------- - -instance LogFormatting (TraceTxSubmissionInbound txid tx) where - forMachine _dtal (TraceTxSubmissionCollected count) = - mconcat - [ "kind" .= String "TraceTxSubmissionCollected" - , "count" .= toJSON count - ] - forMachine _dtal (TraceTxSubmissionProcessed processed) = - mconcat - [ "kind" .= String "TraceTxSubmissionProcessed" - , "accepted" .= toJSON (ptxcAccepted processed) - , "rejected" .= toJSON (ptxcRejected processed) - ] - forMachine _dtal TraceTxInboundTerminated = - mconcat - [ "kind" .= String "TraceTxInboundTerminated" - ] - forMachine _dtal (TraceTxInboundCanRequestMoreTxs count) = - mconcat - [ "kind" .= String "TraceTxInboundCanRequestMoreTxs" - , "count" .= toJSON count - ] - forMachine _dtal (TraceTxInboundCannotRequestMoreTxs count) = - mconcat - [ "kind" .= String "TraceTxInboundCannotRequestMoreTxs" - , "count" .= toJSON count - ] - - asMetrics (TraceTxSubmissionCollected count)= - [CounterM "submissions.submitted" (Just count)] - asMetrics (TraceTxSubmissionProcessed processed) = - [ CounterM "submissions.accepted" - (Just (ptxcAccepted processed)) - , CounterM "submissions.rejected" - (Just (ptxcRejected processed)) - ] - asMetrics _ = [] - -instance MetaTrace (TraceTxSubmissionInbound txid tx) where - namespaceFor TraceTxSubmissionCollected {} = Namespace [] ["Collected"] - namespaceFor TraceTxSubmissionProcessed {} = Namespace [] ["Processed"] - namespaceFor TraceTxInboundTerminated {} = Namespace [] ["Terminated"] - namespaceFor TraceTxInboundCanRequestMoreTxs {} = Namespace [] ["CanRequestMoreTxs"] - namespaceFor TraceTxInboundCannotRequestMoreTxs {} = Namespace [] ["CannotRequestMoreTxs"] - - severityFor (Namespace _ ["Collected"]) _ = Just Debug - severityFor (Namespace _ ["Processed"]) _ = Just Debug - severityFor (Namespace _ ["Terminated"]) _ = Just Notice - severityFor (Namespace _ ["CanRequestMoreTxs"]) _ = Just Debug - severityFor (Namespace _ ["CannotRequestMoreTxs"]) _ = Just Debug - severityFor _ _ = Nothing - - metricsDocFor (Namespace _ ["Collected"]) = - [ ("submissions.submitted", "")] - metricsDocFor (Namespace _ ["Processed"]) = - [ ("submissions.accepted", "") - , ("submissions.rejected", "") - ] - metricsDocFor _ = [] - - documentFor (Namespace _ ["Collected"]) = Just - "Number of transactions just about to be inserted." - documentFor (Namespace _ ["Processed"]) = Just - "Just processed transaction pass/fail breakdown." - documentFor (Namespace _ ["Terminated"]) = Just - "Server received 'MsgDone'." - documentFor (Namespace _ ["CanRequestMoreTxs"]) = Just $ mconcat - [ "There are no replies in flight, but we do know some more txs we" - , " can ask for, so lets ask for them and more txids." - ] - documentFor (Namespace _ ["CannotRequestMoreTxs"]) = Just $ mconcat - [ "There's no replies in flight, and we have no more txs we can" - , " ask for so the only remaining thing to do is to ask for more" - , " txids. Since this is the only thing to do now, we make this a" - , " blocking call." - ] - documentFor _ = Nothing - - allNamespaces = [ - Namespace [] ["Collected"] - , Namespace [] ["Processed"] - , Namespace [] ["Terminated"] - , Namespace [] ["CanRequestMoreTxs"] - , Namespace [] ["CannotRequestMoreTxs"] - ] - --------------------------------------------------------------------------------- --- TxOutbound Tracer --------------------------------------------------------------------------------- - -instance (Show txid, Show tx) - => LogFormatting (TraceTxSubmissionOutbound txid tx) where - forMachine DDetailed (TraceTxSubmissionOutboundRecvMsgRequestTxs txids) = - mconcat - [ "kind" .= String "TraceTxSubmissionOutboundRecvMsgRequestTxs" - , "txIds" .= String (Text.pack $ show txids) - ] - forMachine _dtal (TraceTxSubmissionOutboundRecvMsgRequestTxs _txids) = - mconcat - [ "kind" .= String "TraceTxSubmissionOutboundRecvMsgRequestTxs" - ] - forMachine DDetailed (TraceTxSubmissionOutboundSendMsgReplyTxs txs) = - mconcat - [ "kind" .= String "TraceTxSubmissionOutboundSendMsgReplyTxs" - , "txs" .= String (Text.pack $ show txs) - ] - forMachine _dtal (TraceTxSubmissionOutboundSendMsgReplyTxs _txs) = - mconcat - [ "kind" .= String "TraceTxSubmissionOutboundSendMsgReplyTxs" - ] - forMachine _dtal (TraceControlMessage _msg) = - mconcat - [ "kind" .= String "TraceControlMessage" - ] - -instance MetaTrace (TraceTxSubmissionOutbound txid tx) where - namespaceFor TraceTxSubmissionOutboundRecvMsgRequestTxs {} = - Namespace [] ["RecvMsgRequest"] - namespaceFor TraceTxSubmissionOutboundSendMsgReplyTxs {} = - Namespace [] ["SendMsgReply"] - namespaceFor TraceControlMessage {} = - Namespace [] ["ControlMessage"] - - severityFor (Namespace _ ["RecvMsgRequest"]) _ = - Just Info - severityFor (Namespace _ ["SendMsgReply"]) _ = - Just Info - severityFor (Namespace _ ["ControlMessage"]) _ = - Just Info - severityFor _ _ = Nothing - - documentFor (Namespace _ ["RecvMsgRequest"]) = Just - "The IDs of the transactions requested." - documentFor (Namespace _ ["SendMsgReply"]) = Just - "The transactions to be sent in the response." - documentFor (Namespace _ ["ControlMessage"]) = Just - "" - documentFor _ = Nothing - - allNamespaces = - [ Namespace [] ["RecvMsgRequest"] - , Namespace [] ["SendMsgReply"] - , Namespace [] ["ControlMessage"] - ] - - -------------------------------------------------------------------------------- -- TxSubmissionServer Tracer -------------------------------------------------------------------------------- diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/Diffusion.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/Diffusion.hs deleted file mode 100644 index 840076510db..00000000000 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/Diffusion.hs +++ /dev/null @@ -1,993 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} - - - -{-# OPTIONS_GHC -Wno-orphans #-} - -module Cardano.Node.Tracing.Tracers.Diffusion - ( txsMempoolTimeoutHardCounterName - , impliesMempoolTimeoutHard - ) where - - -import Cardano.Logging -import Cardano.Node.Configuration.TopologyP2P () -import Control.Exception (fromException) -import Ouroboros.Consensus.Mempool.API (ExnMempoolTimeout) -import qualified Ouroboros.Network.Diffusion.Types as Diff -import Ouroboros.Network.PeerSelection.LedgerPeers (NumberOfPeers (..), PoolStake (..), - TraceLedgerPeers (..)) -import qualified Ouroboros.Network.Protocol.Handshake.Type as HS - -import Data.Aeson (Value (String), (.=)) -import qualified Data.List as List -import Data.Text (Text, pack) -import Data.Typeable -import Formatting - -import qualified Network.Mux as Mux -#ifdef linux_HOST_OS -import Network.Mux.TCPInfo (StructTCPInfo (..)) -#endif -import Network.Mux.Types (SDUHeader (..), unRemoteClockModel) -import Network.TypedProtocol.Codec (AnyMessage (..)) - --------------------------------------------------------------------------------- --- Mux Tracer --------------------------------------------------------------------------------- - -instance (LogFormatting peer, LogFormatting tr, Typeable tr) => - LogFormatting (Mux.WithBearer peer tr) where - forMachine dtal (Mux.WithBearer b ev) = - mconcat [ "kind" .= (show . typeOf $ ev) - , "bearer" .= forMachine dtal b - , "event" .= forMachine dtal ev ] - forHuman (Mux.WithBearer b ev) = "With mux bearer " <> forHuman b - <> ". " <> forHuman ev - -instance MetaTrace tr => MetaTrace (Mux.WithBearer peer tr) where - namespaceFor (Mux.WithBearer _peer obj) = (nsCast . namespaceFor) obj - severityFor ns Nothing = severityFor (nsCast ns :: Namespace tr) Nothing - severityFor ns (Just (Mux.WithBearer _peer obj)) = - severityFor (nsCast ns) (Just obj) - privacyFor ns Nothing = privacyFor (nsCast ns :: Namespace tr) Nothing - privacyFor ns (Just (Mux.WithBearer _peer obj)) = - privacyFor (nsCast ns) (Just obj) - detailsFor ns Nothing = detailsFor (nsCast ns :: Namespace tr) Nothing - detailsFor ns (Just (Mux.WithBearer _peer obj)) = - detailsFor (nsCast ns) (Just obj) - documentFor ns = documentFor (nsCast ns :: Namespace tr) - metricsDocFor ns = metricsDocFor (nsCast ns :: Namespace tr) - allNamespaces = map nsCast (allNamespaces :: [Namespace tr]) - -instance LogFormatting Mux.BearerTrace where - forMachine _dtal Mux.TraceRecvHeaderStart = mconcat - [ "kind" .= String "Mux.TraceRecvHeaderStart" - , "msg" .= String "Bearer Receive Header Start" - ] - forMachine _dtal (Mux.TraceRecvHeaderEnd SDUHeader { mhTimestamp, mhNum, mhDir, mhLength }) = mconcat - [ "kind" .= String "Mux.TraceRecvHeaderStart" - , "msg" .= String "Bearer Receive Header End" - , "timestamp" .= String (showTHex (unRemoteClockModel mhTimestamp)) - , "miniProtocolNum" .= String (showT mhNum) - , "miniProtocolDir" .= String (showT mhDir) - , "length" .= String (showT mhLength) - ] - forMachine _dtal (Mux.TraceRecvDeltaQObservation SDUHeader { mhTimestamp, mhLength } ts) = mconcat - [ "kind" .= String "Mux.TraceRecvDeltaQObservation" - , "msg" .= String "Bearer DeltaQ observation" - , "timeRemote" .= String (showT ts) - , "timeLocal" .= String (showTHex (unRemoteClockModel mhTimestamp)) - , "length" .= String (showT mhLength) - ] - forMachine _dtal (Mux.TraceRecvDeltaQSample d sp so dqs dqvm dqvs estR sdud) = mconcat - [ "kind" .= String "Mux.TraceRecvDeltaQSample" - , "msg" .= String "Bearer DeltaQ Sample" - , "duration" .= String (showT d) - , "packets" .= String (showT sp) - , "sumBytes" .= String (showT so) - , "DeltaQ_S" .= String (showT dqs) - , "DeltaQ_VMean" .= String (showT dqvm) - , "DeltaQ_VVar" .= String (showT dqvs) - , "DeltaQ_estR" .= String (showT estR) - , "sizeDist" .= String (showT sdud) - ] - forMachine _dtal (Mux.TraceRecvStart len) = mconcat - [ "kind" .= String "Mux.TraceRecvStart" - , "msg" .= String "Bearer Receive Start" - , "length" .= String (showT len) - ] - forMachine _dtal (Mux.TraceRecvRaw len) = mconcat - [ "kind" .= String "Mux.TraceRecvRaw" - , "msg" .= String "Bearer Receive Raw" - , "length" .= String (showT len) - ] - forMachine _dtal (Mux.TraceRecvEnd len) = mconcat - [ "kind" .= String "Mux.TraceRecvEnd" - , "msg" .= String "Bearer Receive End" - , "length" .= String (showT len) - ] - forMachine _dtal (Mux.TraceSendStart SDUHeader { mhTimestamp, mhNum, mhDir, mhLength }) = mconcat - [ "kind" .= String "Mux.TraceSendStart" - , "msg" .= String "Bearer Send Start" - , "timestamp" .= String (showTHex (unRemoteClockModel mhTimestamp)) - , "miniProtocolNum" .= String (showT mhNum) - , "miniProtocolDir" .= String (showT mhDir) - , "length" .= String (showT mhLength) - ] - forMachine _dtal Mux.TraceSendEnd = mconcat - [ "kind" .= String "Mux.TraceSendEnd" - , "msg" .= String "Bearer Send End" - ] - forMachine _dtal Mux.TraceSDUReadTimeoutException = mconcat - [ "kind" .= String "Mux.TraceSDUReadTimeoutException" - , "msg" .= String "Timed out reading SDU" - ] - forMachine _dtal Mux.TraceSDUWriteTimeoutException = mconcat - [ "kind" .= String "Mux.TraceSDUWriteTimeoutException" - , "msg" .= String "Timed out writing SDU" - ] - forMachine _dtal Mux.TraceEmitDeltaQ = mempty -#ifdef linux_HOST_OS - forMachine _dtal (Mux.TraceTCPInfo StructTCPInfo - { tcpi_snd_mss, tcpi_rcv_mss, tcpi_lost, tcpi_retrans - , tcpi_rtt, tcpi_rttvar, tcpi_snd_cwnd } - len) = mconcat - [ "kind" .= String "Mux.TraceTCPInfo" - , "msg" .= String "TCPInfo" - , "rtt" .= (fromIntegral tcpi_rtt :: Word) - , "rttvar" .= (fromIntegral tcpi_rttvar :: Word) - , "snd_cwnd" .= (fromIntegral tcpi_snd_cwnd :: Word) - , "snd_mss" .= (fromIntegral tcpi_snd_mss :: Word) - , "rcv_mss" .= (fromIntegral tcpi_rcv_mss :: Word) - , "lost" .= (fromIntegral tcpi_lost :: Word) - , "retrans" .= (fromIntegral tcpi_retrans :: Word) - , "length" .= len - ] -#else - forMachine _dtal (Mux.TraceTCPInfo _ len) = mconcat - [ "kind" .= String "Mux.TraceTCPInfo" - , "msg" .= String "TCPInfo" - , "len" .= String (showT len) - ] -#endif - - forHuman Mux.TraceRecvHeaderStart = - "Bearer Receive Header Start" - forHuman (Mux.TraceRecvHeaderEnd SDUHeader { mhTimestamp, mhNum, mhDir, mhLength }) = - sformat ("Bearer Receive Header End: ts:" % prefixHex % "(" % shown % ") " % shown % " len " % int) - (unRemoteClockModel mhTimestamp) mhNum mhDir mhLength - forHuman (Mux.TraceRecvDeltaQObservation SDUHeader { mhTimestamp, mhLength } ts) = - sformat ("Bearer DeltaQ observation: remote ts" % int % " local ts " % shown % " length " % int) - (unRemoteClockModel mhTimestamp) ts mhLength - forHuman (Mux.TraceRecvDeltaQSample d sp so dqs dqvm dqvs estR sdud) = - sformat ("Bearer DeltaQ Sample: duration " % fixed 3 % " packets " % int % " sumBytes " - % int % " DeltaQ_S " % fixed 3 % " DeltaQ_VMean " % fixed 3 % "DeltaQ_VVar " % fixed 3 - % " DeltaQ_estR " % fixed 3 % " sizeDist " % string) - d sp so dqs dqvm dqvs estR sdud - forHuman (Mux.TraceRecvStart len) = - sformat ("Bearer Receive Start: length " % int) len - forHuman (Mux.TraceRecvRaw len) = - sformat ("Bearer Receive Raw: length " % int) len - forHuman (Mux.TraceRecvEnd len) = - sformat ("Bearer Receive End: length " % int) len - forHuman (Mux.TraceSendStart SDUHeader { mhTimestamp, mhNum, mhDir, mhLength }) = - sformat ("Bearer Send Start: ts: " % prefixHex % " (" % shown % ") " % shown % " length " % int) - (unRemoteClockModel mhTimestamp) mhNum mhDir mhLength - forHuman Mux.TraceSendEnd = - "Bearer Send End" - forHuman Mux.TraceSDUReadTimeoutException = - "Timed out reading SDU" - forHuman Mux.TraceSDUWriteTimeoutException = - "Timed out writing SDU" - forHuman Mux.TraceEmitDeltaQ = mempty -#ifdef linux_HOST_OS - forHuman (Mux.TraceTCPInfo StructTCPInfo - { tcpi_snd_mss, tcpi_rcv_mss, tcpi_lost, tcpi_retrans - , tcpi_rtt, tcpi_rttvar, tcpi_snd_cwnd } - len) = - sformat ("TCPInfo rtt " % int % " rttvar " % int % " snd_cwnd " % int % - " snd_mss " % int % " rcv_mss " % int % " lost " % int % - " retrans " % int % " len " % int) - (fromIntegral tcpi_rtt :: Word) - (fromIntegral tcpi_rttvar :: Word) - (fromIntegral tcpi_snd_cwnd :: Word) - (fromIntegral tcpi_snd_mss :: Word) - (fromIntegral tcpi_rcv_mss :: Word) - (fromIntegral tcpi_lost :: Word) - (fromIntegral tcpi_retrans :: Word) - len -#else - forHuman (Mux.TraceTCPInfo _ len) = sformat ("TCPInfo len " % int) len -#endif - -instance MetaTrace Mux.BearerTrace where - namespaceFor Mux.TraceRecvHeaderStart {} = - Namespace [] ["RecvHeaderStart"] - namespaceFor Mux.TraceRecvHeaderEnd {} = - Namespace [] ["RecvHeaderEnd"] - namespaceFor Mux.TraceRecvStart {} = - Namespace [] ["RecvStart"] - namespaceFor Mux.TraceRecvRaw {} = - Namespace [] ["RecvRaw"] - namespaceFor Mux.TraceRecvEnd {} = - Namespace [] ["RecvEnd"] - namespaceFor Mux.TraceSendStart {} = - Namespace [] ["SendStart"] - namespaceFor Mux.TraceSendEnd = - Namespace [] ["SendEnd"] - namespaceFor Mux.TraceRecvDeltaQObservation {} = - Namespace [] ["RecvDeltaQObservation"] - namespaceFor Mux.TraceRecvDeltaQSample {} = - Namespace [] ["RecvDeltaQSample"] - namespaceFor Mux.TraceSDUReadTimeoutException = - Namespace [] ["SDUReadTimeoutException"] - namespaceFor Mux.TraceSDUWriteTimeoutException = - Namespace [] ["SDUWriteTimeoutException"] - namespaceFor Mux.TraceEmitDeltaQ = - Namespace [] ["TraceEmitDeltaQ"] - namespaceFor Mux.TraceTCPInfo {} = - Namespace [] ["TCPInfo"] - - severityFor (Namespace _ ["RecvHeaderStart"]) _ = Just Debug - severityFor (Namespace _ ["RecvRaw"]) _ = Just Debug - severityFor (Namespace _ ["RecvHeaderEnd"]) _ = Just Debug - severityFor (Namespace _ ["RecvStart"]) _ = Just Debug - severityFor (Namespace _ ["RecvEnd"]) _ = Just Debug - severityFor (Namespace _ ["SendStart"]) _ = Just Debug - severityFor (Namespace _ ["SendEnd"]) _ = Just Debug - severityFor (Namespace _ ["RecvDeltaQObservation"]) _ = Just Debug - severityFor (Namespace _ ["RecvDeltaQSample"]) _ = Just Debug - severityFor (Namespace _ ["SDUReadTimeoutException"]) _ = Just Notice - severityFor (Namespace _ ["SDUWriteTimeoutException"]) _ = Just Notice - severityFor (Namespace _ ["TCPInfo"]) _ = Just Debug - severityFor (Namespace _ ["TraceEmitDeltaQ"]) _ = Nothing - severityFor _ _ = Nothing - - documentFor (Namespace _ ["RecvHeaderStart"]) = Just - "Bearer receive header start." - documentFor (Namespace _ ["RecvRaw"]) = Just - "Bearer receive raw." - documentFor (Namespace _ ["RecvHeaderEnd"]) = Just - "Bearer receive header end." - documentFor (Namespace _ ["RecvStart"]) = Just - "Bearer receive start." - documentFor (Namespace _ ["RecvEnd"]) = Just - "Bearer receive end." - documentFor (Namespace _ ["SendStart"]) = Just - "Bearer send start." - documentFor (Namespace _ ["SendEnd"]) = Just - "Bearer send end." - documentFor (Namespace _ ["RecvDeltaQObservation"]) = Just - "Bearer DeltaQ observation." - documentFor (Namespace _ ["RecvDeltaQSample"]) = Just - "Bearer DeltaQ sample." - documentFor (Namespace _ ["SDUReadTimeoutException"]) = Just - "Timed out reading SDU." - documentFor (Namespace _ ["SDUWriteTimeoutException"]) = Just - "Timed out writing SDU." - documentFor (Namespace _ ["TraceEmitDeltaQ"]) = Nothing - documentFor (Namespace _ ["TCPInfo"]) = Just - "TCPInfo." - documentFor _ = Nothing - - allNamespaces = [ - Namespace [] ["RecvHeaderStart"] - , Namespace [] ["RecvRaw"] - , Namespace [] ["RecvHeaderEnd"] - , Namespace [] ["RecvStart"] - , Namespace [] ["RecvEnd"] - , Namespace [] ["SendStart"] - , Namespace [] ["SendEnd"] - , Namespace [] ["RecvDeltaQObservation"] - , Namespace [] ["RecvDeltaQSample"] - , Namespace [] ["SDUReadTimeoutException"] - , Namespace [] ["SDUWriteTimeoutException"] - , Namespace [] ["TraceEmitDeltaQ"] - , Namespace [] ["TCPInfo"] - ] - -instance LogFormatting Mux.ChannelTrace where - forMachine _dtal (Mux.TraceChannelRecvStart mid) = mconcat - [ "kind" .= String "Mux.TraceChannelRecvStart" - , "msg" .= String "Channel Receive Start" - , "miniProtocolNum" .= String (showT mid) - ] - forMachine _dtal (Mux.TraceChannelRecvEnd mid len) = mconcat - [ "kind" .= String "Mux.TraceChannelRecvEnd" - , "msg" .= String "Channel Receive End" - , "miniProtocolNum" .= String (showT mid) - , "length" .= String (showT len) - ] - forMachine _dtal (Mux.TraceChannelSendStart mid len) = mconcat - [ "kind" .= String "Mux.TraceChannelSendStart" - , "msg" .= String "Channel Send Start" - , "miniProtocolNum" .= String (showT mid) - , "length" .= String (showT len) - ] - forMachine _dtal (Mux.TraceChannelSendEnd mid) = mconcat - [ "kind" .= String "Mux.TraceChannelSendEnd" - , "msg" .= String "Channel Send End" - , "miniProtocolNum" .= String (showT mid) - ] - - forHuman (Mux.TraceChannelRecvStart mid) = - sformat ("Channel Receive Start on " % shown) mid - forHuman (Mux.TraceChannelRecvEnd mid len) = - sformat ("Channel Receive End on (" % shown % ") " % int) mid len - forHuman (Mux.TraceChannelSendStart mid len) = - sformat ("Channel Send Start on (" % shown % ") " % int) mid len - forHuman (Mux.TraceChannelSendEnd mid) = - sformat ("Channel Send End on " % shown) mid - -instance MetaTrace Mux.ChannelTrace where - namespaceFor Mux.TraceChannelRecvStart {} = - Namespace [] ["ChannelRecvStart"] - namespaceFor Mux.TraceChannelRecvEnd {} = - Namespace [] ["ChannelRecvEnd"] - namespaceFor Mux.TraceChannelSendStart {} = - Namespace [] ["ChannelSendStart"] - namespaceFor Mux.TraceChannelSendEnd {} = - Namespace [] ["ChannelSendEnd"] - - severityFor (Namespace _ ["ChannelRecvStart"]) _ = Just Debug - severityFor (Namespace _ ["ChannelRecvEnd"]) _ = Just Debug - severityFor (Namespace _ ["ChannelSendStart"]) _ = Just Debug - severityFor (Namespace _ ["ChannelSendEnd"]) _ = Just Debug - severityFor _ _ = Nothing - - documentFor (Namespace _ ["ChannelRecvStart"]) = Just - "Channel receive start." - documentFor (Namespace _ ["ChannelRecvEnd"]) = Just - "Channel receive end." - documentFor (Namespace _ ["ChannelSendStart"]) = Just - "Channel send start." - documentFor (Namespace _ ["ChannelSendEnd"]) = Just - "Channel send end." - documentFor _ = Nothing - - allNamespaces = [ - Namespace [] ["ChannelRecvStart"] - , Namespace [] ["ChannelRecvEnd"] - , Namespace [] ["ChannelSendStart"] - , Namespace [] ["ChannelSendEnd"] - ] - -txsMempoolTimeoutHardCounterName :: Text -txsMempoolTimeoutHardCounterName = "txsMempoolTimeoutHard" - -impliesMempoolTimeoutHard :: Mux.Trace -> Bool -impliesMempoolTimeoutHard = \case - Mux.TraceExceptionExit _mid _dir e - | Just _ <- fromException @ExnMempoolTimeout e - -> True - _ -> False - -instance LogFormatting Mux.Trace where - forMachine _dtal (Mux.TraceState new) = mconcat - [ "kind" .= String "Mux.TraceState" - , "msg" .= String "MuxState" - , "state" .= String (showT new) - ] - forMachine _dtal (Mux.TraceCleanExit mid dir) = mconcat - [ "kind" .= String "Mux.TraceCleanExit" - , "msg" .= String "Miniprotocol terminated cleanly" - , "miniProtocolNum" .= String (showT mid) - , "miniProtocolDir" .= String (showT dir) - ] - forMachine _dtal (Mux.TraceExceptionExit mid dir exc) = mconcat - [ "kind" .= String "Mux.TraceExceptionExit" - , "msg" .= String "Miniprotocol terminated with exception" - , "miniProtocolNum" .= String (showT mid) - , "miniProtocolDir" .= String (showT dir) - , "exception" .= String (showT exc) - ] - forMachine _dtal (Mux.TraceStartEagerly mid dir) = mconcat - [ "kind" .= String "Mux.TraceStartEagerly" - , "msg" .= String "Eagerly started" - , "miniProtocolNum" .= String (showT mid) - , "miniProtocolDir" .= String (showT dir) - ] - forMachine _dtal (Mux.TraceStartOnDemand mid dir) = mconcat - [ "kind" .= String "Mux.TraceStartOnDemand" - , "msg" .= String "Preparing to start" - , "miniProtocolNum" .= String (showT mid) - , "miniProtocolDir" .= String (showT dir) - ] - forMachine _dtal (Mux.TraceStartOnDemandAny mid dir) = mconcat - [ "kind" .= String "Mux.TraceStartOnDemandAny" - , "msg" .= String "Preparing to start" - , "miniProtocolNum" .= String (showT mid) - , "miniProtocolDir" .= String (showT dir) - ] - forMachine _dtal (Mux.TraceStartedOnDemand mid dir) = mconcat - [ "kind" .= String "Mux.TraceStartedOnDemand" - , "msg" .= String "Started on demand" - , "miniProtocolNum" .= String (showT mid) - , "miniProtocolDir" .= String (showT dir) - ] - forMachine _dtal (Mux.TraceTerminating mid dir) = mconcat - [ "kind" .= String "Mux.TraceTerminating" - , "msg" .= String "Terminating" - , "miniProtocolNum" .= String (showT mid) - , "miniProtocolDir" .= String (showT dir) - ] - forMachine _dtal Mux.TraceStopping = mconcat - [ "kind" .= String "Mux.TraceStopping" - , "msg" .= String "Mux stopping" - ] - forMachine _dtal Mux.TraceStopped = mconcat - [ "kind" .= String "Mux.TraceStopped" - , "msg" .= String "Mux stoppped" - ] - - forHuman (Mux.TraceState new) = - sformat ("State: " % shown) new - forHuman (Mux.TraceCleanExit mid dir) = - sformat ("Miniprotocol (" % shown % ") " % shown % " terminated cleanly") - mid dir - forHuman (Mux.TraceExceptionExit mid dir e) = - sformat ("Miniprotocol (" % shown % ") " % shown % - " terminated with exception " % shown) mid dir e - forHuman (Mux.TraceStartEagerly mid dir) = - sformat ("Eagerly started (" % shown % ") in " % shown) mid dir - forHuman (Mux.TraceStartOnDemand mid dir) = - sformat ("Preparing to start (" % shown % ") in " % shown) mid dir - forHuman (Mux.TraceStartOnDemandAny mid dir) = - sformat ("Preparing to start (" % shown % ") in " % shown) mid dir - forHuman (Mux.TraceStartedOnDemand mid dir) = - sformat ("Started on demand (" % shown % ") in " % shown) mid dir - forHuman (Mux.TraceTerminating mid dir) = - sformat ("Terminating (" % shown % ") in " % shown) mid dir - forHuman Mux.TraceStopping = "Mux stopping" - forHuman Mux.TraceStopped = "Mux stoppped" - - asMetrics = \case - Mux.TraceState{} -> [] - Mux.TraceCleanExit{} -> [] - ev@Mux.TraceExceptionExit{} -> - -- Somewhat awkward to "catch" this Consensus exception here, but - -- Diffusion Layer is indeed the ultimate manager of the per-peer - -- threads. - [ CounterM txsMempoolTimeoutHardCounterName Nothing - | impliesMempoolTimeoutHard ev - ] - Mux.TraceStartEagerly{} -> [] - Mux.TraceStartOnDemand{} -> [] - Mux.TraceStartOnDemandAny{} -> [] - Mux.TraceStartedOnDemand{} -> [] - Mux.TraceTerminating{} -> [] - Mux.TraceStopping{} -> [] - Mux.TraceStopped{} -> [] - -instance MetaTrace Mux.Trace where - namespaceFor Mux.TraceState {} = - Namespace [] ["State"] - namespaceFor Mux.TraceCleanExit {} = - Namespace [] ["CleanExit"] - namespaceFor Mux.TraceExceptionExit {} = - Namespace [] ["ExceptionExit"] - namespaceFor Mux.TraceStartEagerly {} = - Namespace [] ["StartEagerly"] - namespaceFor Mux.TraceStartOnDemand {} = - Namespace [] ["StartOnDemand"] - namespaceFor Mux.TraceStartOnDemandAny {} = - Namespace [] ["StartOnDemandAny"] - namespaceFor Mux.TraceStartedOnDemand {} = - Namespace [] ["StartedOnDemand"] - namespaceFor Mux.TraceTerminating {} = - Namespace [] ["Terminating"] - namespaceFor Mux.TraceStopping = - Namespace [] ["Stopping"] - namespaceFor Mux.TraceStopped = - Namespace [] ["Stopped"] - - severityFor (Namespace _ ["State"]) _ = Just Info - severityFor (Namespace _ ["CleanExit"]) _ = Just Notice - severityFor (Namespace _ ["ExceptionExit"]) _ = Just Notice - severityFor (Namespace _ ["StartEagerly"]) _ = Just Debug - severityFor (Namespace _ ["StartOnDemand"]) _ = Just Debug - severityFor (Namespace _ ["StartOnDemandAny"]) _ = Just Debug - severityFor (Namespace _ ["StartedOnDemand"]) _ = Just Debug - severityFor (Namespace _ ["Terminating"]) _ = Just Debug - severityFor (Namespace _ ["Stopping"]) _ = Just Debug - severityFor (Namespace _ ["Stopped"]) _ = Just Debug - severityFor _ _ = Nothing - - documentFor (Namespace _ ["State"]) = Just - "State." - documentFor (Namespace _ ["CleanExit"]) = Just - "Miniprotocol terminated cleanly." - documentFor (Namespace _ ["ExceptionExit"]) = Just - "Miniprotocol terminated with exception." - documentFor (Namespace _ ["StartEagerly"]) = Just - "Eagerly started." - documentFor (Namespace _ ["StartOnDemand"]) = Just - "Preparing to start." - documentFor (Namespace _ ["StartedOnDemand"]) = Just - "Started on demand." - documentFor (Namespace _ ["StartOnDemandAny"]) = Just - "Start whenever any other protocol has started." - documentFor (Namespace _ ["Terminating"]) = Just - "Terminating." - documentFor (Namespace _ ["Stopping"]) = Just - "Mux shutdown." - documentFor (Namespace _ ["Stopped"]) = Just - "Mux shutdown." - documentFor _ = Nothing - - metricsDocFor (Namespace _ ["State"]) = [] - metricsDocFor (Namespace _ ["CleanExit"]) = [] - metricsDocFor (Namespace _ ["ExceptionExit"]) = - [ (txsMempoolTimeoutHardCounterName, "Transactions that hard timed out in mempool") - ] - metricsDocFor (Namespace _ ["StartEagerly"]) = [] - metricsDocFor (Namespace _ ["StartOnDemand"]) = [] - metricsDocFor (Namespace _ ["StartedOnDemand"]) = [] - metricsDocFor (Namespace _ ["StartOnDemandAny"]) = [] - metricsDocFor (Namespace _ ["Terminating"]) = [] - metricsDocFor (Namespace _ ["Stopping"]) = [] - metricsDocFor (Namespace _ ["Stopped"]) = [] - metricsDocFor _ = [] - - allNamespaces = [ - Namespace [] ["State"] - , Namespace [] ["CleanExit"] - , Namespace [] ["ExceptionExit"] - , Namespace [] ["StartEagerly"] - , Namespace [] ["StartOnDemand"] - , Namespace [] ["StartOnDemandAny"] - , Namespace [] ["StartedOnDemand"] - , Namespace [] ["Terminating"] - , Namespace [] ["Stopping"] - , Namespace [] ["Stopped"] - ] - - --------------------------------------------------------------------------------- --- Handshake Tracer --------------------------------------------------------------------------------- - -instance (Show term, Show ntcVersion) => - LogFormatting (AnyMessage (HS.Handshake ntcVersion term)) where - forMachine _dtal (AnyMessageAndAgency stok msg) = - mconcat [ "kind" .= String kind - , "msg" .= (String . showT $ msg) - , "agency" .= String (pack $ show stok) - ] - where - kind = case msg of - HS.MsgProposeVersions {} -> "ProposeVersions" - HS.MsgReplyVersions {} -> "ReplyVersions" - HS.MsgQueryReply {} -> "QueryReply" - HS.MsgAcceptVersion {} -> "AcceptVersion" - HS.MsgRefuse {} -> "Refuse" - - forHuman (AnyMessageAndAgency stok msg) = - "Handshake (agency, message) = " <> "(" <> showT stok <> "," <> showT msg <> ")" - -instance MetaTrace (AnyMessage (HS.Handshake a b)) where - namespaceFor (AnyMessage msg) = Namespace [] $ case msg of - HS.MsgProposeVersions {} -> ["ProposeVersions"] - HS.MsgReplyVersions {} -> ["ReplyVersions"] - HS.MsgQueryReply {} -> ["QueryReply"] - HS.MsgAcceptVersion {} -> ["AcceptVersion"] - HS.MsgRefuse {} -> ["Refuse"] - - severityFor (Namespace _ [sym]) _ = case sym of - "ProposeVersions" -> Just Debug - "ReplyVersions" -> Just Debug - "QueryReply" -> Just Debug - "AcceptVersion" -> Just Debug - "Refuse" -> Just Debug - _otherwise -> Nothing - severityFor _ _ = Nothing - - documentFor (Namespace _ sym) = wrap . mconcat $ case sym of - ["ProposeVersions"] -> - [ "Propose versions together with version parameters. It must be" - , " encoded to a sorted list.." - ] - ["ReplyVersions"] -> - [ "`MsgReplyVersions` received as a response to 'MsgProposeVersions'. It" - , " is not supported to explicitly send this message. It can only be" - , " received as a copy of 'MsgProposeVersions' in a simultaneous open" - , " scenario." - ] - ["QueryReply"] -> - [ "`MsgQueryReply` received as a response to a handshake query in " - , " 'MsgProposeVersions' and lists the supported versions." - ] - ["AcceptVersion"] -> - [ "The remote end decides which version to use and sends chosen version." - , "The server is allowed to modify version parameters." - ] - ["Refuse"] -> ["It refuses to run any version."] - _otherwise -> [] :: [Text] - where - wrap it = case it of - "" -> Nothing - it' -> Just it' - - allNamespaces = [ - Namespace [] ["ProposeVersions"] - , Namespace [] ["ReplyVersions"] - , Namespace [] ["QueryReply"] - , Namespace [] ["AcceptVersion"] - , Namespace [] ["Refuse"] - ] - - --------------------------------------------------------------------------------- --- DiffusionInit Tracer --------------------------------------------------------------------------------- - -instance (Show ntnAddr, Show ntcAddr) => - LogFormatting (Diff.DiffusionTracer ntnAddr ntcAddr) where - forMachine _dtal (Diff.RunServer sockAddr) = mconcat - [ "kind" .= String "RunServer" - , "socketAddress" .= String (pack (show sockAddr)) - ] - - forMachine _dtal (Diff.RunLocalServer localAddress) = mconcat - [ "kind" .= String "RunLocalServer" - , "localAddress" .= String (pack (show localAddress)) - ] - forMachine _dtal (Diff.UsingSystemdSocket localAddress) = mconcat - [ "kind" .= String "UsingSystemdSocket" - , "path" .= String (pack . show $ localAddress) - ] - - forMachine _dtal (Diff.CreateSystemdSocketForSnocketPath localAddress) = mconcat - [ "kind" .= String "CreateSystemdSocketForSnocketPath" - , "path" .= String (pack . show $ localAddress) - ] - forMachine _dtal (Diff.CreatedLocalSocket localAddress) = mconcat - [ "kind" .= String "CreatedLocalSocket" - , "path" .= String (pack . show $ localAddress) - ] - forMachine _dtal (Diff.ConfiguringLocalSocket localAddress socket) = mconcat - [ "kind" .= String "ConfiguringLocalSocket" - , "path" .= String (pack . show $ localAddress) - , "socket" .= String (pack (show socket)) - ] - forMachine _dtal (Diff.ListeningLocalSocket localAddress socket) = mconcat - [ "kind" .= String "ListeningLocalSocket" - , "path" .= String (pack . show $ localAddress) - , "socket" .= String (pack (show socket)) - ] - forMachine _dtal (Diff.LocalSocketUp localAddress fd) = mconcat - [ "kind" .= String "LocalSocketUp" - , "path" .= String (pack . show $ localAddress) - , "socket" .= String (pack (show fd)) - ] - forMachine _dtal (Diff.CreatingServerSocket socket) = mconcat - [ "kind" .= String "CreatingServerSocket" - , "socket" .= String (pack (show socket)) - ] - forMachine _dtal (Diff.ListeningServerSocket socket) = mconcat - [ "kind" .= String "ListeningServerSocket" - , "socket" .= String (pack (show socket)) - ] - forMachine _dtal (Diff.ServerSocketUp socket) = mconcat - [ "kind" .= String "ServerSocketUp" - , "socket" .= String (pack (show socket)) - ] - forMachine _dtal (Diff.ConfiguringServerSocket socket) = mconcat - [ "kind" .= String "ConfiguringServerSocket" - , "socket" .= String (pack (show socket)) - ] - forMachine _dtal (Diff.UnsupportedLocalSystemdSocket path) = mconcat - [ "kind" .= String "UnsupportedLocalSystemdSocket" - , "path" .= String (pack (show path)) - ] - forMachine _dtal Diff.UnsupportedReadySocketCase = mconcat - [ "kind" .= String "UnsupportedReadySocketCase" - ] - forMachine _dtal (Diff.DiffusionErrored exception) = mconcat - [ "kind" .= String "DiffusionErrored" - , "error" .= String (pack (show exception)) - ] - forMachine _dtal (Diff.SystemdSocketConfiguration config) = mconcat - [ "kind" .= String "SystemdSocketConfiguration" - , "path" .= String (pack (show config)) - ] - -instance MetaTrace (Diff.DiffusionTracer ntnAddr ntcAddr) where - namespaceFor Diff.RunServer {} = - Namespace [] ["RunServer"] - namespaceFor Diff.RunLocalServer {} = - Namespace [] ["RunLocalServer"] - namespaceFor Diff.UsingSystemdSocket {} = - Namespace [] ["UsingSystemdSocket"] - namespaceFor Diff.CreateSystemdSocketForSnocketPath {} = - Namespace [] ["CreateSystemdSocketForSnocketPath"] - namespaceFor Diff.CreatedLocalSocket {} = - Namespace [] ["CreatedLocalSocket"] - namespaceFor Diff.ConfiguringLocalSocket {} = - Namespace [] ["ConfiguringLocalSocket"] - namespaceFor Diff.ListeningLocalSocket {} = - Namespace [] ["ListeningLocalSocket"] - namespaceFor Diff.LocalSocketUp {} = - Namespace [] ["LocalSocketUp"] - namespaceFor Diff.CreatingServerSocket {} = - Namespace [] ["CreatingServerSocket"] - namespaceFor Diff.ListeningServerSocket {} = - Namespace [] ["ListeningServerSocket"] - namespaceFor Diff.ServerSocketUp {} = - Namespace [] ["ServerSocketUp"] - namespaceFor Diff.ConfiguringServerSocket {} = - Namespace [] ["ConfiguringServerSocket"] - namespaceFor Diff.UnsupportedLocalSystemdSocket {} = - Namespace [] ["UnsupportedLocalSystemdSocket"] - namespaceFor Diff.UnsupportedReadySocketCase {} = - Namespace [] ["UnsupportedReadySocketCase"] - namespaceFor Diff.DiffusionErrored {} = - Namespace [] ["DiffusionErrored"] - namespaceFor Diff.SystemdSocketConfiguration {} = - Namespace [] ["SystemdSocketConfiguration"] - - severityFor (Namespace _ ["RunServer"]) _ = Just Info - severityFor (Namespace _ ["RunLocalServer"]) _ = Just Info - severityFor (Namespace _ ["UsingSystemdSocket"]) _ = Just Info - severityFor (Namespace _ ["CreateSystemdSocketForSnocketPath"]) _ = Just Info - severityFor (Namespace _ ["CreatedLocalSocket"]) _ = Just Info - severityFor (Namespace _ ["ConfiguringLocalSocket"]) _ = Just Info - severityFor (Namespace _ ["ListeningLocalSocket"]) _ = Just Info - severityFor (Namespace _ ["LocalSocketUp"]) _ = Just Info - severityFor (Namespace _ ["CreatingServerSocket"]) _ = Just Info - severityFor (Namespace _ ["ListeningServerSocket"]) _ = Just Info - severityFor (Namespace _ ["ServerSocketUp"]) _ = Just Info - severityFor (Namespace _ ["ConfiguringServerSocket"]) _ = Just Info - severityFor (Namespace _ ["UnsupportedLocalSystemdSocket"]) _ = Just Warning - severityFor (Namespace _ ["UnsupportedReadySocketCase"]) _ = Just Info - severityFor (Namespace _ ["DiffusionErrored"]) _ = Just Critical - severityFor (Namespace _ ["SystemdSocketConfiguration"]) _ = Just Warning - severityFor _ _ = Nothing - - documentFor (Namespace _ ["RunServer"]) = Just - "RunServer" - documentFor (Namespace _ ["RunLocalServer"]) = Just - "RunLocalServer" - documentFor (Namespace _ ["UsingSystemdSocket"]) = Just - "UsingSystemdSocket" - documentFor (Namespace _ ["CreateSystemdSocketForSnocketPath"]) = Just - "CreateSystemdSocketForSnocketPath" - documentFor (Namespace _ ["CreatedLocalSocket"]) = Just - "CreatedLocalSocket" - documentFor (Namespace _ ["ConfiguringLocalSocket"]) = Just - "ConfiguringLocalSocket" - documentFor (Namespace _ ["ListeningLocalSocket"]) = Just - "ListeningLocalSocket" - documentFor (Namespace _ ["LocalSocketUp"]) = Just - "LocalSocketUp" - documentFor (Namespace _ ["CreatingServerSocket"]) = Just - "CreatingServerSocket" - documentFor (Namespace _ ["ListeningServerSocket"]) = Just - "ListeningServerSocket" - documentFor (Namespace _ ["ServerSocketUp"]) = Just - "ServerSocketUp" - documentFor (Namespace _ ["ConfiguringServerSocket"]) = Just - "ConfiguringServerSocket" - documentFor (Namespace _ ["UnsupportedLocalSystemdSocket"]) = Just - "UnsupportedLocalSystemdSocket" - documentFor (Namespace _ ["UnsupportedReadySocketCase"]) = Just - "UnsupportedReadySocketCase" - documentFor (Namespace _ ["DiffusionErrored"]) = Just - "DiffusionErrored" - documentFor (Namespace _ ["SystemdSocketConfiguration"]) = Just - "SystemdSocketConfiguration" - documentFor _ = Nothing - - allNamespaces = [ - Namespace [] ["RunServer"] - , Namespace [] ["RunLocalServer"] - , Namespace [] ["UsingSystemdSocket"] - , Namespace [] ["CreateSystemdSocketForSnocketPath"] - , Namespace [] ["CreatedLocalSocket"] - , Namespace [] ["ConfiguringLocalSocket"] - , Namespace [] ["ListeningLocalSocket"] - , Namespace [] ["LocalSocketUp"] - , Namespace [] ["CreatingServerSocket"] - , Namespace [] ["ListeningServerSocket"] - , Namespace [] ["ServerSocketUp"] - , Namespace [] ["ConfiguringServerSocket"] - , Namespace [] ["UnsupportedLocalSystemdSocket"] - , Namespace [] ["UnsupportedReadySocketCase"] - , Namespace [] ["DiffusionErrored"] - , Namespace [] ["SystemdSocketConfiguration"] - ] - --------------------------------------------------------------------------------- --- LedgerPeers Tracer --------------------------------------------------------------------------------- - -instance LogFormatting TraceLedgerPeers where - forMachine _dtal (PickedLedgerPeer addr _ackStake stake) = - mconcat - [ "kind" .= String "PickedLedgerPeer" - , "address" .= show addr - , "relativeStake" .= (realToFrac (unPoolStake stake) :: Double) - ] - forMachine _dtal (PickedLedgerPeers (NumberOfPeers n) addrs) = - mconcat - [ "kind" .= String "PickedLedgerPeers" - , "desiredCount" .= n - , "count" .= List.length addrs - , "addresses" .= show addrs - ] - forMachine _dtal (PickedBigLedgerPeer addr _ackStake stake) = - mconcat - [ "kind" .= String "PickedBigLedgerPeer" - , "address" .= show addr - , "relativeStake" .= (realToFrac (unPoolStake stake) :: Double) - ] - forMachine _dtal (PickedBigLedgerPeers (NumberOfPeers n) addrs) = - mconcat - [ "kind" .= String "PickedBigLedgerPeers" - , "desiredCount" .= n - , "count" .= List.length addrs - , "addresses" .= show addrs - ] - forMachine _dtal (FetchingNewLedgerState cnt bigCnt) = - mconcat - [ "kind" .= String "FetchingNewLedgerState" - , "numberOfLedgerPeers" .= cnt - , "numberOfBigLedgerPeers" .= bigCnt - ] - forMachine _dtal DisabledLedgerPeers = - mconcat - [ "kind" .= String "DisabledLedgerPeers" - ] - forMachine _dtal (TraceUseLedgerPeers ulp) = - mconcat - [ "kind" .= String "UseLedgerPeers" - , "useLedgerPeers" .= ulp - ] - forMachine _dtal WaitingOnRequest = - mconcat - [ "kind" .= String "WaitingOnRequest" - ] - forMachine _dtal (RequestForPeers (NumberOfPeers np)) = - mconcat - [ "kind" .= String "RequestForPeers" - , "numberOfPeers" .= np - ] - forMachine _dtal (ReusingLedgerState cnt age) = - mconcat - [ "kind" .= String "ReusingLedgerState" - , "numberOfPools" .= cnt - , "ledgerStateAge" .= age - ] - forMachine _dtal FallingBackToPublicRootPeers = - mconcat - [ "kind" .= String "FallingBackToPublicRootPeers" - ] - forMachine _dtal (NotEnoughLedgerPeers (NumberOfPeers target) numOfLedgerPeers) = - mconcat - [ "kind" .= String "NotEnoughLedgerPeers" - , "target" .= target - , "numOfLedgerPeers" .= numOfLedgerPeers - ] - forMachine _dtal (NotEnoughBigLedgerPeers (NumberOfPeers target) numOfBigLedgerPeers) = - mconcat - [ "kind" .= String "NotEnoughBigLedgerPeers" - , "target" .= target - , "numOfBigLedgerPeers" .= numOfBigLedgerPeers - ] - forMachine _dtal (TraceLedgerPeersDomains daps) = - mconcat - [ "kind" .= String "TraceLedgerPeersDomains" - , "domainAccessPoints" .= daps - ] - forMachine _dtal UsingBigLedgerPeerSnapshot = - mconcat - [ "kind" .= String "UsingBigLedgerPeerSnapshot" - ] - -instance MetaTrace TraceLedgerPeers where - namespaceFor PickedLedgerPeer {} = - Namespace [] ["PickedLedgerPeer"] - namespaceFor PickedLedgerPeers {} = - Namespace [] ["PickedLedgerPeers"] - namespaceFor PickedBigLedgerPeer {} = - Namespace [] ["PickedBigLedgerPeer"] - namespaceFor PickedBigLedgerPeers {} = - Namespace [] ["PickedBigLedgerPeers"] - namespaceFor FetchingNewLedgerState {} = - Namespace [] ["FetchingNewLedgerState"] - namespaceFor DisabledLedgerPeers {} = - Namespace [] ["DisabledLedgerPeers"] - namespaceFor TraceUseLedgerPeers {} = - Namespace [] ["TraceUseLedgerPeers"] - namespaceFor WaitingOnRequest {} = - Namespace [] ["WaitingOnRequest"] - namespaceFor RequestForPeers {} = - Namespace [] ["RequestForPeers"] - namespaceFor ReusingLedgerState {} = - Namespace [] ["ReusingLedgerState"] - namespaceFor FallingBackToPublicRootPeers {} = - Namespace [] ["FallingBackToPublicRootPeers"] - namespaceFor NotEnoughLedgerPeers {} = - Namespace [] ["NotEnoughLedgerPeers"] - namespaceFor NotEnoughBigLedgerPeers {} = - Namespace [] ["NotEnoughBigLedgerPeers"] - namespaceFor TraceLedgerPeersDomains {} = - Namespace [] ["TraceLedgerPeersDomains"] - namespaceFor UsingBigLedgerPeerSnapshot {} = - Namespace [] ["UsingBigLedgerPeerSnapshot"] - - severityFor (Namespace _ ["PickedLedgerPeer"]) _ = Just Debug - severityFor (Namespace _ ["PickedLedgerPeers"]) _ = Just Info - severityFor (Namespace _ ["PickedBigLedgerPeer"]) _ = Just Debug - severityFor (Namespace _ ["PickedBigLedgerPeers"]) _ = Just Info - severityFor (Namespace _ ["FetchingNewLedgerState"]) _ = Just Info - severityFor (Namespace _ ["DisabledLedgerPeers"]) _ = Just Info - severityFor (Namespace _ ["TraceUseLedgerAfter"]) _ = Just Info - severityFor (Namespace _ ["WaitingOnRequest"]) _ = Just Debug - severityFor (Namespace _ ["RequestForPeers"]) _ = Just Debug - severityFor (Namespace _ ["ReusingLedgerState"]) _ = Just Debug - severityFor (Namespace _ ["FallingBackToPublicRootPeers"]) _ = Just Info - severityFor (Namespace _ ["NotEnoughLedgerPeers"]) _ = Just Warning - severityFor (Namespace _ ["NotEnoughBigLedgerPeers"]) _ = Just Warning - severityFor (Namespace _ ["TraceLedgerPeersDomains"]) _ = Just Debug - severityFor (Namespace _ ["UsingBigLedgerPeerSnapshot"]) _ = Just Debug - severityFor _ _ = Nothing - - documentFor (Namespace _ ["PickedLedgerPeer"]) = Just - "Trace for a peer picked with accumulated and relative stake of its pool." - documentFor (Namespace _ ["PickedLedgerPeers"]) = Just - "Trace for the number of peers we wanted to pick and the list of peers picked." - documentFor (Namespace _ ["PickedBigLedgerPeer"]) = Just - "Trace for a big ledger peer picked with accumulated and relative stake of its pool." - documentFor (Namespace _ ["PickedBigLedgerPeers"]) = Just - "Trace for the number of big ledger peers we wanted to pick and the list of peers picked." - documentFor (Namespace _ ["FetchingNewLedgerState"]) = Just $ mconcat - [ "Trace for fetching a new list of peers from the ledger. Int is the number of peers" - , " returned." - ] - documentFor (Namespace _ ["DisabledLedgerPeers"]) = Just - "Trace for when getting peers from the ledger is disabled, that is DontUseLedger." - documentFor (Namespace _ ["TraceUseLedgerAfter"]) = Just - "Trace UseLedgerAfter value." - documentFor (Namespace _ ["WaitingOnRequest"]) = Just - "" - documentFor (Namespace _ ["RequestForPeers"]) = Just - "RequestForPeers (NumberOfPeers 1)" - documentFor (Namespace _ ["ReusingLedgerState"]) = Just - "" - documentFor (Namespace _ ["FallingBackToPublicRootPeers"]) = Just - "" - documentFor (Namespace _ ["TraceLedgerPeersDomains"]) = Just - "" - documentFor (Namespace _ ["UsingBigLedgerPeerSnapshot"]) = Just $ mconcat - [ "Trace for when a request for big ledger peers is fulfilled from the snapshot file" - , " specified in the topology file."] - documentFor _ = Nothing - - allNamespaces = [ - Namespace [] ["PickedLedgerPeer"] - , Namespace [] ["PickedLedgerPeers"] - , Namespace [] ["PickedBigLedgerPeer"] - , Namespace [] ["PickedBigLedgerPeers"] - , Namespace [] ["FetchingNewLedgerState"] - , Namespace [] ["DisabledLedgerPeers"] - , Namespace [] ["TraceUseLedgerAfter"] - , Namespace [] ["WaitingOnRequest"] - , Namespace [] ["RequestForPeers"] - , Namespace [] ["ReusingLedgerState"] - , Namespace [] ["FallingBackToPublicRootPeers"] - , Namespace [] ["NotEnoughLedgerPeers"] - , Namespace [] ["NotEnoughBigLedgerPeers"] - , Namespace [] ["TraceLedgerPeersDomains"] - , Namespace [] ["UsingBigLedgerPeerSnapshot"] - ] diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/LedgerMetrics.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/LedgerMetrics.hs index dc97441f6fc..6f2e0820ff4 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/LedgerMetrics.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/LedgerMetrics.hs @@ -105,7 +105,7 @@ traceLedgerMetrics nodeKern slotNo tracer = do query <- mapNodeKernelDataIO (\nk -> (,,) -- (,,,,) - <$> fmap (maybe 0 LedgerDB.ledgerTableSize) (ChainDB.getStatistics $ getChainDB nk) + <$> ChainDB.getStatistics (getChainDB nk) <*> nkQueryLedger (ledgerDelegMapSize . ledgerState) nk <*> nkQueryChain fragmentChainDensity nk {- see Note [GovMetrics] @@ -116,10 +116,10 @@ traceLedgerMetrics nodeKern slotNo tracer = do nodeKern case query of SNothing -> pure () - SJust (utxoSize, delegMapSize, {- drepCount, drepMapSize, -} chainDensity) -> + SJust (ledgerStatistics, delegMapSize, {- drepCount, drepMapSize, -} chainDensity) -> let msg = LedgerMetrics slotNo - utxoSize + (LedgerDB.ledgerTableSize ledgerStatistics) delegMapSize {- see Note [GovMetrics] drepCount diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/NodeToClient.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/NodeToClient.hs index e6ddcb3e180..ff105fbc036 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/NodeToClient.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/NodeToClient.hs @@ -12,12 +12,11 @@ module Cardano.Node.Tracing.Tracers.NodeToClient () where import Cardano.Logging import Ouroboros.Consensus.Ledger.Query (Query) -import qualified Ouroboros.Network.Driver.Simple as Simple -import qualified Ouroboros.Network.Driver.Stateful as Stateful import Ouroboros.Network.Protocol.ChainSync.Type as ChainSync import qualified Ouroboros.Network.Protocol.LocalStateQuery.Type as LSQ import qualified Ouroboros.Network.Protocol.LocalTxMonitor.Type as LTM import qualified Ouroboros.Network.Protocol.LocalTxSubmission.Type as LTS +import Ouroboros.Network.Tracing () import Data.Aeson (Value (String), (.=)) import Data.Text (Text, pack) @@ -26,140 +25,6 @@ import qualified Network.TypedProtocol.Stateful.Codec as Stateful {-# ANN module ("HLint: ignore Redundant bracket" :: Text) #-} -instance LogFormatting (Simple.AnyMessage ps) - => LogFormatting (Simple.TraceSendRecv ps) where - forMachine dtal (Simple.TraceSendMsg m) = mconcat - [ "kind" .= String "Send" , "msg" .= forMachine dtal m ] - forMachine dtal (Simple.TraceRecvMsg m) = mconcat - [ "kind" .= String "Recv" , "msg" .= forMachine dtal m ] - - forHuman (Simple.TraceSendMsg m) = "Send: " <> forHuman m - forHuman (Simple.TraceRecvMsg m) = "Receive: " <> forHuman m - - asMetrics (Simple.TraceSendMsg m) = asMetrics m - asMetrics (Simple.TraceRecvMsg m) = asMetrics m - -instance LogFormatting (Stateful.AnyMessage ps f) - => LogFormatting (Stateful.TraceSendRecv ps f) where - forMachine dtal (Stateful.TraceSendMsg m) = mconcat - [ "kind" .= String "Send" , "msg" .= forMachine dtal m ] - forMachine dtal (Stateful.TraceRecvMsg m) = mconcat - [ "kind" .= String "Recv" , "msg" .= forMachine dtal m ] - - forHuman (Stateful.TraceSendMsg m) = "Send: " <> forHuman m - forHuman (Stateful.TraceRecvMsg m) = "Receive: " <> forHuman m - - asMetrics (Stateful.TraceSendMsg m) = asMetrics m - asMetrics (Stateful.TraceRecvMsg m) = asMetrics m - -instance MetaTrace (Simple.AnyMessage ps) => - MetaTrace (Simple.TraceSendRecv ps) where - namespaceFor (Simple.TraceSendMsg msg) = - nsPrependInner "Send" (namespaceFor msg) - namespaceFor (Simple.TraceRecvMsg msg) = - nsPrependInner "Receive" (namespaceFor msg) - - severityFor (Namespace out ("Send" : tl)) (Just (Simple.TraceSendMsg msg)) = - severityFor (Namespace out tl) (Just msg) - severityFor (Namespace out ("Send" : tl)) Nothing = - severityFor (Namespace out tl :: Namespace (Simple.AnyMessage ps)) Nothing - severityFor (Namespace out ("Receive" : tl)) (Just (Simple.TraceSendMsg msg)) = - severityFor (Namespace out tl) (Just msg) - severityFor (Namespace out ("Receive" : tl)) Nothing = - severityFor (Namespace out tl :: Namespace (Simple.AnyMessage ps)) Nothing - severityFor _ _ = Nothing - - privacyFor (Namespace out ("Send" : tl)) (Just (Simple.TraceSendMsg msg)) = - privacyFor (Namespace out tl) (Just msg) - privacyFor (Namespace out ("Send" : tl)) Nothing = - privacyFor (Namespace out tl :: Namespace (Simple.AnyMessage ps)) Nothing - privacyFor (Namespace out ("Receive" : tl)) (Just (Simple.TraceSendMsg msg)) = - privacyFor (Namespace out tl) (Just msg) - privacyFor (Namespace out ("Receive" : tl)) Nothing = - privacyFor (Namespace out tl :: Namespace (Simple.AnyMessage ps)) Nothing - privacyFor _ _ = Nothing - - detailsFor (Namespace out ("Send" : tl)) (Just (Simple.TraceSendMsg msg)) = - detailsFor (Namespace out tl) (Just msg) - detailsFor (Namespace out ("Send" : tl)) Nothing = - detailsFor (Namespace out tl :: Namespace (Simple.AnyMessage ps)) Nothing - detailsFor (Namespace out ("Receive" : tl)) (Just (Simple.TraceSendMsg msg)) = - detailsFor (Namespace out tl) (Just msg) - detailsFor (Namespace out ("Receive" : tl)) Nothing = - detailsFor (Namespace out tl :: Namespace (Simple.AnyMessage ps)) Nothing - detailsFor _ _ = Nothing - - metricsDocFor (Namespace out ("Send" : tl)) = - metricsDocFor (nsCast (Namespace out tl) :: Namespace (Simple.AnyMessage ps)) - metricsDocFor (Namespace out ("Receive" : tl)) = - metricsDocFor (nsCast (Namespace out tl) :: Namespace (Simple.AnyMessage ps)) - metricsDocFor _ = [] - - documentFor (Namespace out ("Send" : tl)) = - documentFor (nsCast (Namespace out tl) :: Namespace (Simple.AnyMessage ps)) - documentFor (Namespace out ("Receive" : tl)) = - documentFor (nsCast (Namespace out tl) :: Namespace (Simple.AnyMessage ps)) - documentFor _ = Nothing - - allNamespaces = - let cn = allNamespaces :: [Namespace (Simple.AnyMessage ps)] - in fmap (nsPrependInner "Send") cn ++ fmap (nsPrependInner "Receive") cn - -instance MetaTrace (Stateful.AnyMessage ps f) => - MetaTrace (Stateful.TraceSendRecv ps f) where - namespaceFor (Stateful.TraceSendMsg msg) = - nsPrependInner "Send" (namespaceFor msg) - namespaceFor (Stateful.TraceRecvMsg msg) = - nsPrependInner "Receive" (namespaceFor msg) - - severityFor (Namespace out ("Send" : tl)) (Just (Stateful.TraceSendMsg msg)) = - severityFor (Namespace out tl) (Just msg) - severityFor (Namespace out ("Send" : tl)) Nothing = - severityFor (Namespace out tl :: Namespace (Stateful.AnyMessage ps f)) Nothing - - severityFor (Namespace out ("Receive" : tl)) (Just (Stateful.TraceSendMsg msg)) = - severityFor (Namespace out tl) (Just msg) - severityFor (Namespace out ("Receive" : tl)) Nothing = - severityFor (Namespace out tl :: Namespace (Stateful.AnyMessage ps f)) Nothing - severityFor _ _ = Nothing - - privacyFor (Namespace out ("Send" : tl)) (Just (Stateful.TraceSendMsg msg)) = - privacyFor (Namespace out tl) (Just msg) - privacyFor (Namespace out ("Send" : tl)) Nothing = - privacyFor (Namespace out tl :: Namespace (Stateful.AnyMessage ps f)) Nothing - privacyFor (Namespace out ("Receive" : tl)) (Just (Stateful.TraceSendMsg msg)) = - privacyFor (Namespace out tl) (Just msg) - privacyFor (Namespace out ("Receive" : tl)) Nothing = - privacyFor (Namespace out tl :: Namespace (Stateful.AnyMessage ps f)) Nothing - privacyFor _ _ = Nothing - - detailsFor (Namespace out ("Send" : tl)) (Just (Stateful.TraceSendMsg msg)) = - detailsFor (Namespace out tl) (Just msg) - detailsFor (Namespace out ("Send" : tl)) Nothing = - detailsFor (Namespace out tl :: Namespace (Stateful.AnyMessage ps f)) Nothing - detailsFor (Namespace out ("Receive" : tl)) (Just (Stateful.TraceSendMsg msg)) = - detailsFor (Namespace out tl) (Just msg) - detailsFor (Namespace out ("Receive" : tl)) Nothing = - detailsFor (Namespace out tl :: Namespace (Stateful.AnyMessage ps f)) Nothing - detailsFor _ _ = Nothing - - metricsDocFor (Namespace out ("Send" : tl)) = - metricsDocFor (nsCast (Namespace out tl) :: Namespace (Stateful.AnyMessage ps f)) - metricsDocFor (Namespace out ("Receive" : tl)) = - metricsDocFor (nsCast (Namespace out tl) :: Namespace (Stateful.AnyMessage ps f)) - metricsDocFor _ = [] - - documentFor (Namespace out ("Send" : tl)) = - documentFor (nsCast (Namespace out tl) :: Namespace (Stateful.AnyMessage ps f)) - documentFor (Namespace out ("Receive" : tl)) = - documentFor (nsCast (Namespace out tl) :: Namespace (Stateful.AnyMessage ps f)) - documentFor _ = Nothing - - allNamespaces = - let cn = allNamespaces :: [Namespace (Stateful.AnyMessage ps f)] - in fmap (nsPrependInner "Send") cn ++ fmap (nsPrependInner "Receive") cn - - -- -------------------------------------------------------------------------------- -- -- TChainSync Tracer -- -------------------------------------------------------------------------------- diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/NodeToNode.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/NodeToNode.hs index 0e35639178b..18f8d2f76ed 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/NodeToNode.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/NodeToNode.hs @@ -26,7 +26,6 @@ import Ouroboros.Network.Protocol.BlockFetch.Type (BlockFetch (..), Me import qualified Ouroboros.Network.Protocol.TxSubmission2.Type as STX import qualified Ouroboros.Network.Protocol.KeepAlive.Type as KA import qualified Ouroboros.Network.Protocol.PeerSharing.Type as PS -import Ouroboros.Network.SizeInBytes (SizeInBytes (..)) import Control.Monad.Class.MonadTime.SI (Time (..)) import Data.Aeson (ToJSON (..), Value (String), (.=)) @@ -87,9 +86,6 @@ instance ( ConvertTxId blk ] -instance ToJSON SizeInBytes where - toJSON (SizeInBytes s) = toJSON s - instance MetaTrace (AnyMessage (BlockFetch blk1 (Point blk2))) where namespaceFor (AnyMessageAndAgency _stok MsgRequestRange{}) = Namespace [] ["RequestRange"] diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/P2P.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/P2P.hs deleted file mode 100644 index 709beae76b4..00000000000 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/P2P.hs +++ /dev/null @@ -1,2104 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} - -{-# OPTIONS_GHC -Wno-orphans #-} - -module Cardano.Node.Tracing.Tracers.P2P - () where - -import Cardano.Logging -import Cardano.Network.Diffusion.Types -import qualified Cardano.Network.PeerSelection.ExtraRootPeers as Cardano.PublicRootPeers -import qualified Cardano.Network.PeerSelection.Governor.Types as Cardano -import Cardano.Node.Configuration.TopologyP2P () -import Cardano.Node.Tracing.Tracers.NodeToNode () -import Cardano.Tracing.OrphanInstances.Network () -import Ouroboros.Network.ConnectionHandler (ConnectionHandlerTrace (..)) -import Ouroboros.Network.ConnectionId (ConnectionId (..)) -import Ouroboros.Network.ConnectionManager.ConnMap (ConnMap (..)) -import Ouroboros.Network.ConnectionManager.Core as ConnectionManager (Trace (..)) -import Ouroboros.Network.ConnectionManager.Types (ConnectionManagerCounters (..)) -import qualified Ouroboros.Network.ConnectionManager.Types as ConnectionManager -import Ouroboros.Network.InboundGovernor as InboundGovernor (Trace (..)) -import qualified Ouroboros.Network.InboundGovernor as InboundGovernor -import Ouroboros.Network.InboundGovernor.State as InboundGovernor (Counters (..)) -import qualified Ouroboros.Network.NodeToNode as NtN -import Ouroboros.Network.OrphanInstances () -import Ouroboros.Network.PeerSelection.Churn (ChurnCounters (..)) -import Ouroboros.Network.PeerSelection.Governor (DebugPeerSelection (..), - DebugPeerSelectionState (..), PeerSelectionCounters, PeerSelectionState (..), - PeerSelectionTargets (..), PeerSelectionView (..), TracePeerSelection (..), - peerSelectionStateToCounters) -import Ouroboros.Network.PeerSelection.Governor.Types (DemotionTimeoutException) -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.PeerSelection.Types () -import Ouroboros.Network.Protocol.PeerSharing.Type (PeerSharingAmount (..)) -import Ouroboros.Network.RethrowPolicy (ErrorCommand (..)) -import Ouroboros.Network.Server as Server -import Ouroboros.Network.Snocket (LocalAddress (..)) - -import Control.Exception (displayException, fromException) -import Data.Aeson (Object, ToJSON, ToJSONKey, Value (..), object, toJSON, toJSONList, - (.=)) -import Data.Aeson.Types (listValue) -import Data.Bifunctor (Bifunctor (..)) -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 (pack) -import Network.Socket (SockAddr (..)) - - --------------------------------------------------------------------------------- --- Addresses --------------------------------------------------------------------------------- - -instance LogFormatting LocalAddress where - forMachine _dtal (LocalAddress path) = - mconcat ["path" .= path] - -instance LogFormatting NtN.RemoteAddress where - forMachine _dtal (SockAddrInet port addr) = - let ip = IP.fromHostAddress addr in - mconcat [ "addr" .= show ip - , "port" .= show port - ] - forMachine _dtal (SockAddrInet6 port _ addr _) = - let ip = IP.fromHostAddress6 addr in - mconcat [ "addr" .= show ip - , "port" .= show port - ] - forMachine _dtal (SockAddrUnix path) = - mconcat [ "path" .= show path ] - --------------------------------------------------------------------------------- --- LocalRootPeers Tracer --------------------------------------------------------------------------------- - -instance LogFormatting CardanoTraceLocalRootPeers where - forMachine _dtal (TraceLocalRootDomains groups) = - mconcat [ "kind" .= String "LocalRootDomains" - , "localRootDomains" .= toJSON groups - ] - forMachine _dtal (TraceLocalRootWaiting d dt) = - mconcat [ "kind" .= String "LocalRootWaiting" - , "domainAddress" .= toJSON d - , "diffTime" .= show dt - ] - forMachine _dtal (TraceLocalRootGroups groups) = - mconcat [ "kind" .= String "LocalRootGroups" - , "localRootGroups" .= toJSON groups - ] - forMachine _dtal (TraceLocalRootFailure d exception) = - mconcat [ "kind" .= String "LocalRootFailure" - , "domainAddress" .= toJSON d - , "reason" .= displayException exception - ] - forMachine _dtal (TraceLocalRootError d exception) = - mconcat [ "kind" .= String "LocalRootError" - , "domainAddress" .= String (pack . show $ d) - , "reason" .= displayException exception - ] - forMachine _dtal (TraceLocalRootReconfigured d exception) = - mconcat [ "kind" .= String "LocalRootReconfigured" - , "domainAddress" .= toJSON d - , "reason" .= show exception - ] - forMachine _dtal (TraceLocalRootDNSMap dnsMap) = - mconcat - [ "kind" .= String "TraceLocalRootDNSMap" - , "dnsMap" .= dnsMap - ] - forHuman = pack . show - -instance MetaTrace (TraceLocalRootPeers ntnAddr extraFlags) where - namespaceFor = \case - TraceLocalRootDomains {} -> Namespace [] ["LocalRootDomains"] - TraceLocalRootWaiting {} -> Namespace [] ["LocalRootWaiting"] - TraceLocalRootGroups {} -> Namespace [] ["LocalRootGroups"] - TraceLocalRootFailure {} -> Namespace [] ["LocalRootFailure"] - TraceLocalRootError {} -> Namespace [] ["LocalRootError"] - TraceLocalRootReconfigured {} -> Namespace [] ["LocalRootReconfigured"] - TraceLocalRootDNSMap {} -> Namespace [] ["LocalRootDNSMap"] - - severityFor (Namespace [] ["LocalRootDomains"]) _ = Just Info - severityFor (Namespace [] ["LocalRootWaiting"]) _ = Just Info - severityFor (Namespace [] ["LocalRootGroups"]) _ = Just Info - severityFor (Namespace [] ["LocalRootFailure"]) _ = Just Info - severityFor (Namespace [] ["LocalRootError"]) _ = Just Info - severityFor (Namespace [] ["LocalRootReconfigured"]) _ = Just Info - severityFor (Namespace [] ["LocalRootDNSMap"]) _ = Just Info - severityFor _ _ = Nothing - - documentFor (Namespace [] ["LocalRootDomains"]) = Just - "" - documentFor (Namespace [] ["LocalRootWaiting"]) = Just - "" - documentFor (Namespace [] ["LocalRootGroups"]) = Just - "" - documentFor (Namespace [] ["LocalRootFailure"]) = Just - "" - documentFor (Namespace [] ["LocalRootError"]) = Just - "" - documentFor (Namespace [] ["LocalRootReconfigured"]) = Just - "" - documentFor (Namespace [] ["LocalRootDNSMap"]) = Just - "" - documentFor _ = Nothing - - allNamespaces = - [ Namespace [] ["LocalRootDomains"] - , Namespace [] ["LocalRootWaiting"] - , Namespace [] ["LocalRootGroups"] - , Namespace [] ["LocalRootFailure"] - , Namespace [] ["LocalRootError"] - , Namespace [] ["LocalRootReconfigured"] - , Namespace [] ["LocalRootDNSMap"] - ] - --------------------------------------------------------------------------------- --- PublicRootPeers Tracer --------------------------------------------------------------------------------- - -instance LogFormatting TracePublicRootPeers where - forMachine _dtal (TracePublicRootRelayAccessPoint relays) = - mconcat [ "kind" .= String "PublicRootRelayAddresses" - , "relayAddresses" .= toJSON relays - ] - forMachine _dtal (TracePublicRootDomains domains) = - mconcat [ "kind" .= String "PublicRootDomains" - , "domainAddresses" .= toJSONList domains - ] - forHuman = pack . show - -instance MetaTrace TracePublicRootPeers where - namespaceFor TracePublicRootRelayAccessPoint {} = Namespace [] ["PublicRootRelayAccessPoint"] - namespaceFor TracePublicRootDomains {} = Namespace [] ["PublicRootDomains"] - - severityFor (Namespace [] ["PublicRootRelayAccessPoint"]) _ = Just Info - severityFor (Namespace [] ["PublicRootDomains"]) _ = Just Info - severityFor _ _ = Nothing - - documentFor (Namespace [] ["PublicRootRelayAccessPoint"]) = Just - "" - documentFor (Namespace [] ["PublicRootDomains"]) = Just - "" - documentFor _ = Nothing - - allNamespaces = [ - Namespace [] ["PublicRootRelayAccessPoint"] - , Namespace [] ["PublicRootDomains"] - ] - --------------------------------------------------------------------------------- --- PeerSelection Tracer --------------------------------------------------------------------------------- - -instance LogFormatting CardanoTracePeerSelection where - forMachine _dtal (TraceLocalRootPeersChanged lrp lrp') = - mconcat [ "kind" .= String "LocalRootPeersChanged" - , "previous" .= toJSON lrp - , "current" .= toJSON lrp' - ] - forMachine _dtal (TraceTargetsChanged pst pst') = - mconcat [ "kind" .= String "TargetsChanged" - , "previous" .= toJSON pst - , "current" .= toJSON pst' - ] - forMachine _dtal (TracePublicRootsRequest tRootPeers nRootPeers) = - mconcat [ "kind" .= String "PublicRootsRequest" - , "targetNumberOfRootPeers" .= tRootPeers - , "numberOfRootPeers" .= nRootPeers - ] - forMachine _dtal (TracePublicRootsResults res group dt) = - mconcat [ "kind" .= String "PublicRootsResults" - , "result" .= toJSON res - , "group" .= group - , "diffTime" .= dt - ] - forMachine _dtal (TracePublicRootsFailure err group dt) = - mconcat [ "kind" .= String "PublicRootsFailure" - , "reason" .= show err - , "group" .= group - , "diffTime" .= dt - ] - forMachine _dtal (TraceForgetColdPeers targetKnown actualKnown sp) = - mconcat [ "kind" .= String "ForgetColdPeers" - , "targetKnown" .= targetKnown - , "actualKnown" .= actualKnown - , "selectedPeers" .= toJSONList (toList sp) - ] - forMachine _dtal (TraceBigLedgerPeersRequest tRootPeers nRootPeers) = - mconcat [ "kind" .= String "BigLedgerPeersRequest" - , "targetNumberOfBigLedgerPeers" .= tRootPeers - , "numberOfBigLedgerPeers" .= nRootPeers - ] - forMachine _dtal (TraceBigLedgerPeersResults res group dt) = - mconcat [ "kind" .= String "BigLedgerPeersResults" - , "result" .= toJSONList (toList res) - , "group" .= group - , "diffTime" .= dt - ] - forMachine _dtal (TraceBigLedgerPeersFailure err group dt) = - mconcat [ "kind" .= String "BigLedgerPeersFailure" - , "reason" .= show err - , "group" .= group - , "diffTime" .= dt - ] - forMachine _dtal (TraceForgetBigLedgerPeers targetKnown actualKnown sp) = - mconcat [ "kind" .= String "ForgetColdBigLedgerPeers" - , "targetKnown" .= targetKnown - , "actualKnown" .= actualKnown - , "selectedPeers" .= toJSONList (toList sp) - ] - forMachine _dtal (TracePeerShareRequests targetKnown actualKnown (PeerSharingAmount numRequested) aps sps) = - mconcat [ "kind" .= String "PeerShareRequests" - , "targetKnown" .= targetKnown - , "actualKnown" .= actualKnown - , "numRequested" .= numRequested - , "availablePeers" .= toJSONList (toList aps) - , "selectedPeers" .= toJSONList (toList sps) - ] - forMachine _dtal (TracePeerShareResults res) = - mconcat [ "kind" .= String "PeerShareResults" - , "result" .= toJSONList (map (first show <$>) res) - ] - forMachine _dtal (TracePeerShareResultsFiltered res) = - mconcat [ "kind" .= String "PeerShareResultsFiltered" - , "result" .= toJSONList res - ] - forMachine _dtal (TracePromoteColdPeers targetKnown actualKnown sp) = - mconcat [ "kind" .= String "PromoteColdPeers" - , "targetEstablished" .= targetKnown - , "actualEstablished" .= actualKnown - , "selectedPeers" .= toJSONList (toList sp) - ] - forMachine _dtal (TracePromoteColdLocalPeers tLocalEst sp) = - mconcat [ "kind" .= String "PromoteColdLocalPeers" - , "targetLocalEstablished" .= tLocalEst - , "selectedPeers" .= toJSONList (toList sp) - ] - forMachine _dtal (TracePromoteColdFailed tEst aEst p d err) = - mconcat [ "kind" .= String "PromoteColdFailed" - , "targetEstablished" .= tEst - , "actualEstablished" .= aEst - , "peer" .= toJSON p - , "delay" .= toJSON d - , "reason" .= show err - ] - forMachine _dtal (TracePromoteColdDone tEst aEst p) = - mconcat [ "kind" .= String "PromoteColdDone" - , "targetEstablished" .= tEst - , "actualEstablished" .= aEst - , "peer" .= toJSON p - ] - forMachine _dtal (TracePromoteColdBigLedgerPeers targetKnown actualKnown sp) = - mconcat [ "kind" .= String "PromoteColdBigLedgerPeers" - , "targetEstablished" .= targetKnown - , "actualEstablished" .= actualKnown - , "selectedPeers" .= toJSONList (toList sp) - ] - forMachine _dtal (TracePromoteColdBigLedgerPeerFailed tEst aEst p d err) = - mconcat [ "kind" .= String "PromoteColdBigLedgerPeerFailed" - , "targetEstablished" .= tEst - , "actualEstablished" .= aEst - , "peer" .= toJSON p - , "delay" .= toJSON d - , "reason" .= show err - ] - forMachine _dtal (TracePromoteColdBigLedgerPeerDone tEst aEst p) = - mconcat [ "kind" .= String "PromoteColdBigLedgerPeerDone" - , "targetEstablished" .= tEst - , "actualEstablished" .= aEst - , "peer" .= toJSON p - ] - forMachine _dtal (TracePromoteWarmPeers tActive aActive sp) = - mconcat [ "kind" .= String "PromoteWarmPeers" - , "targetActive" .= tActive - , "actualActive" .= aActive - , "selectedPeers" .= toJSONList (toList sp) - ] - forMachine _dtal (TracePromoteWarmLocalPeers taa sp) = - mconcat [ "kind" .= String "PromoteWarmLocalPeers" - , "targetActualActive" .= toJSONList taa - , "selectedPeers" .= toJSONList (toList sp) - ] - forMachine _dtal (TracePromoteWarmFailed tActive aActive p err) = - mconcat [ "kind" .= String "PromoteWarmFailed" - , "targetActive" .= tActive - , "actualActive" .= aActive - , "peer" .= toJSON p - , "reason" .= show err - ] - forMachine _dtal (TracePromoteWarmDone tActive aActive p) = - mconcat [ "kind" .= String "PromoteWarmDone" - , "targetActive" .= tActive - , "actualActive" .= aActive - , "peer" .= toJSON p - ] - forMachine _dtal (TracePromoteWarmAborted tActive aActive p) = - mconcat [ "kind" .= String "PromoteWarmAborted" - , "targetActive" .= tActive - , "actualActive" .= aActive - , "peer" .= toJSON p - ] - forMachine _dtal (TracePromoteWarmBigLedgerPeers tActive aActive sp) = - mconcat [ "kind" .= String "PromoteWarmBigLedgerPeers" - , "targetActive" .= tActive - , "actualActive" .= aActive - , "selectedPeers" .= toJSONList (toList sp) - ] - forMachine _dtal (TracePromoteWarmBigLedgerPeerFailed tActive aActive p err) = - mconcat [ "kind" .= String "PromoteWarmBigLedgerPeerFailed" - , "targetActive" .= tActive - , "actualActive" .= aActive - , "peer" .= toJSON p - , "reason" .= show err - ] - forMachine _dtal (TracePromoteWarmBigLedgerPeerDone tActive aActive p) = - mconcat [ "kind" .= String "PromoteWarmBigLedgerPeerDone" - , "targetActive" .= tActive - , "actualActive" .= aActive - , "peer" .= toJSON p - ] - forMachine _dtal (TracePromoteWarmBigLedgerPeerAborted tActive aActive p) = - mconcat [ "kind" .= String "PromoteWarmBigLedgerPeerAborted" - , "targetActive" .= tActive - , "actualActive" .= aActive - , "peer" .= toJSON p - ] - forMachine _dtal (TraceDemoteWarmPeers tEst aEst sp) = - mconcat [ "kind" .= String "DemoteWarmPeers" - , "targetEstablished" .= tEst - , "actualEstablished" .= aEst - , "selectedPeers" .= toJSONList (toList sp) - ] - forMachine _dtal (TraceDemoteWarmFailed tEst aEst p err) = - mconcat [ "kind" .= String "DemoteWarmFailed" - , "targetEstablished" .= tEst - , "actualEstablished" .= aEst - , "peer" .= toJSON p - , "reason" .= show err - ] - forMachine _dtal (TraceDemoteWarmDone tEst aEst p) = - mconcat [ "kind" .= String "DemoteWarmDone" - , "targetEstablished" .= tEst - , "actualEstablished" .= aEst - , "peer" .= toJSON p - ] - forMachine _dtal (TraceDemoteWarmBigLedgerPeers tEst aEst sp) = - mconcat [ "kind" .= String "DemoteWarmBigLedgerPeers" - , "targetEstablished" .= tEst - , "actualEstablished" .= aEst - , "selectedPeers" .= toJSONList (toList sp) - ] - forMachine _dtal (TraceDemoteWarmBigLedgerPeerFailed tEst aEst p err) = - mconcat [ "kind" .= String "DemoteWarmBigLedgerPeerFailed" - , "targetEstablished" .= tEst - , "actualEstablished" .= aEst - , "peer" .= toJSON p - , "reason" .= show err - ] - forMachine _dtal (TraceDemoteWarmBigLedgerPeerDone tEst aEst p) = - mconcat [ "kind" .= String "DemoteWarmBigLedgerPeerDone" - , "targetEstablished" .= tEst - , "actualEstablished" .= aEst - , "peer" .= toJSON p - ] - forMachine _dtal (TraceDemoteHotPeers tActive aActive sp) = - mconcat [ "kind" .= String "DemoteHotPeers" - , "targetActive" .= tActive - , "actualActive" .= aActive - , "selectedPeers" .= toJSONList (toList sp) - ] - forMachine _dtal (TraceDemoteLocalHotPeers taa sp) = - mconcat [ "kind" .= String "DemoteLocalHotPeers" - , "targetActualActive" .= toJSONList taa - , "selectedPeers" .= toJSONList (toList sp) - ] - forMachine _dtal (TraceDemoteHotFailed tActive aActive p err) = - mconcat [ "kind" .= String "DemoteHotFailed" - , "targetActive" .= tActive - , "actualActive" .= aActive - , "peer" .= toJSON p - , "reason" .= show err - ] - forMachine _dtal (TraceDemoteHotDone tActive aActive p) = - mconcat [ "kind" .= String "DemoteHotDone" - , "targetActive" .= tActive - , "actualActive" .= aActive - , "peer" .= toJSON p - ] - forMachine _dtal (TraceDemoteHotBigLedgerPeers tActive aActive sp) = - mconcat [ "kind" .= String "DemoteHotBigLedgerPeers" - , "targetActive" .= tActive - , "actualActive" .= aActive - , "selectedPeers" .= toJSONList (toList sp) - ] - forMachine _dtal (TraceDemoteHotBigLedgerPeerFailed tActive aActive p err) = - mconcat [ "kind" .= String "DemoteHotBigLedgerPeerFailed" - , "targetActive" .= tActive - , "actualActive" .= aActive - , "peer" .= toJSON p - , "reason" .= show err - ] - forMachine _dtal (TraceDemoteHotBigLedgerPeerDone tActive aActive p) = - mconcat [ "kind" .= String "DemoteHotBigLedgerPeerDone" - , "targetActive" .= tActive - , "actualActive" .= aActive - , "peer" .= toJSON p - ] - forMachine _dtal (TraceDemoteAsynchronous msp) = - mconcat [ "kind" .= String "DemoteAsynchronous" - , "state" .= toJSON msp - ] - forMachine _dtal (TraceDemoteLocalAsynchronous msp) = - mconcat [ "kind" .= String "DemoteLocalAsynchronous" - , "state" .= toJSON msp - ] - forMachine _dtal (TraceDemoteBigLedgerPeersAsynchronous msp) = - mconcat [ "kind" .= String "DemoteBigLedgerPeerAsynchronous" - , "state" .= toJSON msp - ] - forMachine _dtal TraceGovernorWakeup = - mconcat [ "kind" .= String "GovernorWakeup" - ] - forMachine _dtal (TraceChurnWait dt) = - mconcat [ "kind" .= String "ChurnWait" - , "diffTime" .= toJSON dt - ] - forMachine _dtal (TracePickInboundPeers targetNumberOfKnownPeers numberOfKnownPeers selected available) = - mconcat [ "kind" .= String "PickInboundPeers" - , "targetKnown" .= targetNumberOfKnownPeers - , "actualKnown" .= numberOfKnownPeers - , "selected" .= selected - , "available" .= available - ] - forMachine _dtal (TraceLedgerStateJudgementChanged new) = - mconcat [ "kind" .= String "LedgerStateJudgementChanged" - , "new" .= show new ] - forMachine _dtal TraceOnlyBootstrapPeers = - mconcat [ "kind" .= String "LedgerStateJudgementChanged" ] - forMachine _dtal (TraceUseBootstrapPeersChanged ubp) = - mconcat [ "kind" .= String "UseBootstrapPeersChanged" - , "useBootstrapPeers" .= toJSON ubp ] - forMachine _dtal TraceBootstrapPeersFlagChangedWhilstInSensitiveState = - mconcat [ "kind" .= String "BootstrapPeersFlagChangedWhilstInSensitiveState" - ] - forMachine _dtal (TraceVerifyPeerSnapshot result) = - mconcat [ "kind" .= String "VerifyPeerSnapshot" - , "result" .= toJSON result ] - forMachine _dtal (TraceOutboundGovernorCriticalFailure err) = - mconcat [ "kind" .= String "OutboundGovernorCriticalFailure" - , "reason" .= show err - ] - forMachine _dtal (TraceChurnAction duration action counter) = - mconcat [ "kind" .= String "ChurnAction" - , "action" .= show action - , "counter" .= counter - , "duration" .= duration - ] - forMachine _dtal (TraceChurnTimeout duration action counter) = - mconcat [ "kind" .= String "ChurnTimeout" - , "action" .= show action - , "counter" .= counter - , "duration" .= duration - ] - forMachine _dtal (TraceDebugState mtime ds) = - mconcat [ "kind" .= String "DebugState" - , "monotonicTime" .= show 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 - ] - - forHuman = pack . show - - asMetrics (TraceChurnAction duration action _) = - [ DoubleM ("peerSelection.churn" <> pack (show action) <> ".duration") - (realToFrac duration) - ] - asMetrics _ = [] - -instance MetaTrace (TracePeerSelection extraDebugState extraFlags extraPeers SockAddr) where - namespaceFor TraceLocalRootPeersChanged {} = - Namespace [] ["LocalRootPeersChanged"] - namespaceFor TraceTargetsChanged {} = - Namespace [] ["TargetsChanged"] - namespaceFor TracePublicRootsRequest {} = - Namespace [] ["PublicRootsRequest"] - namespaceFor TracePublicRootsResults {} = - Namespace [] ["PublicRootsResults"] - namespaceFor TracePublicRootsFailure {} = - Namespace [] ["PublicRootsFailure"] - namespaceFor TraceForgetColdPeers {} = - Namespace [] ["ForgetColdPeers"] - namespaceFor TraceBigLedgerPeersRequest {} = - Namespace [] ["BigLedgerPeersRequest"] - namespaceFor TraceBigLedgerPeersResults {} = - Namespace [] ["BigLedgerPeersResults"] - namespaceFor TraceBigLedgerPeersFailure {} = - Namespace [] ["BigLedgerPeersFailure"] - namespaceFor TraceForgetBigLedgerPeers {} = - Namespace [] ["ForgetBigLedgerPeers"] - namespaceFor TracePeerShareRequests {} = - Namespace [] ["PeerShareRequests"] - namespaceFor TracePeerShareResults {} = - Namespace [] ["PeerShareResults"] - namespaceFor TracePeerShareResultsFiltered {} = - Namespace [] ["PeerShareResultsFiltered"] - namespaceFor TracePickInboundPeers {} = - Namespace [] ["PickInboundPeers"] - namespaceFor TracePromoteColdPeers {} = - Namespace [] ["PromoteColdPeers"] - namespaceFor TracePromoteColdLocalPeers {} = - Namespace [] ["PromoteColdLocalPeers"] - namespaceFor TracePromoteColdFailed {} = - Namespace [] ["PromoteColdFailed"] - namespaceFor TracePromoteColdDone {} = - Namespace [] ["PromoteColdDone"] - namespaceFor TracePromoteColdBigLedgerPeers {} = - Namespace [] ["PromoteColdBigLedgerPeers"] - namespaceFor TracePromoteColdBigLedgerPeerFailed {} = - Namespace [] ["PromoteColdBigLedgerPeerFailed"] - namespaceFor TracePromoteColdBigLedgerPeerDone {} = - Namespace [] ["PromoteColdBigLedgerPeerDone"] - namespaceFor TracePromoteWarmPeers {} = - Namespace [] ["PromoteWarmPeers"] - namespaceFor TracePromoteWarmLocalPeers {} = - Namespace [] ["PromoteWarmLocalPeers"] - namespaceFor TracePromoteWarmFailed {} = - Namespace [] ["PromoteWarmFailed"] - namespaceFor TracePromoteWarmDone {} = - Namespace [] ["PromoteWarmDone"] - namespaceFor TracePromoteWarmAborted {} = - Namespace [] ["PromoteWarmAborted"] - namespaceFor TracePromoteWarmBigLedgerPeers {} = - Namespace [] ["PromoteWarmBigLedgerPeers"] - namespaceFor TracePromoteWarmBigLedgerPeerFailed {} = - Namespace [] ["PromoteWarmBigLedgerPeerFailed"] - namespaceFor TracePromoteWarmBigLedgerPeerDone {} = - Namespace [] ["PromoteWarmBigLedgerPeerDone"] - namespaceFor TracePromoteWarmBigLedgerPeerAborted {} = - Namespace [] ["PromoteWarmBigLedgerPeerAborted"] - namespaceFor TraceDemoteWarmPeers {} = - Namespace [] ["DemoteWarmPeers"] - namespaceFor (TraceDemoteWarmFailed _ _ _ e) = - case fromException e :: Maybe DemotionTimeoutException of - Just _ -> Namespace [] ["DemoteWarmFailed", "CoolingToColdTimeout"] - Nothing -> Namespace [] ["DemoteWarmFailed"] - namespaceFor TraceDemoteWarmDone {} = - Namespace [] ["DemoteWarmDone"] - namespaceFor TraceDemoteWarmBigLedgerPeers {} = - Namespace [] ["DemoteWarmBigLedgerPeers"] - namespaceFor (TraceDemoteWarmBigLedgerPeerFailed _ _ _ e) = - case fromException e :: Maybe DemotionTimeoutException of - Just _ -> Namespace [] ["DemoteWarmBigLedgerPeerFailed", "CoolingToColdTimeout"] - Nothing -> Namespace [] ["DemoteWarmBigLedgerPeerFailed"] - namespaceFor TraceDemoteWarmBigLedgerPeerDone {} = - Namespace [] ["DemoteWarmBigLedgerPeerDone"] - namespaceFor TraceDemoteHotPeers {} = - Namespace [] ["DemoteHotPeers"] - namespaceFor TraceDemoteLocalHotPeers {} = - Namespace [] ["DemoteLocalHotPeers"] - namespaceFor (TraceDemoteHotFailed _ _ _ e) = - case fromException e :: Maybe DemotionTimeoutException of - Just _ -> Namespace [] ["DemoteHotFailed", "CoolingToColdTimeout"] - Nothing -> Namespace [] ["DemoteHotFailed"] - namespaceFor TraceDemoteHotDone {} = - Namespace [] ["DemoteHotDone"] - namespaceFor TraceDemoteHotBigLedgerPeers {} = - Namespace [] ["DemoteHotBigLedgerPeers"] - namespaceFor (TraceDemoteHotBigLedgerPeerFailed _ _ _ e) = - case fromException e :: Maybe DemotionTimeoutException of - Just _ -> Namespace [] ["DemoteHotBigLedgerPeerFailed", "CoolingToColdTimeout"] - Nothing -> Namespace [] ["DemoteHotBigLedgerPeerFailed"] - namespaceFor TraceDemoteHotBigLedgerPeerDone {} = - Namespace [] ["DemoteHotBigLedgerPeerDone"] - namespaceFor TraceDemoteAsynchronous {} = - Namespace [] ["DemoteAsynchronous"] - namespaceFor TraceDemoteLocalAsynchronous {} = - Namespace [] ["DemoteLocalAsynchronous"] - namespaceFor TraceDemoteBigLedgerPeersAsynchronous {} = - Namespace [] ["DemoteBigLedgerPeersAsynchronous"] - namespaceFor TraceGovernorWakeup {} = - Namespace [] ["GovernorWakeup"] - namespaceFor TraceChurnWait {} = - Namespace [] ["ChurnWait"] - namespaceFor TraceLedgerStateJudgementChanged {} = - Namespace [] ["LedgerStateJudgementChanged"] - namespaceFor TraceOnlyBootstrapPeers {} = - Namespace [] ["OnlyBootstrapPeers"] - namespaceFor TraceUseBootstrapPeersChanged {} = - Namespace [] ["UseBootstrapPeersChanged"] - namespaceFor TraceVerifyPeerSnapshot {} = - Namespace [] ["VerifyPeerSnapshot"] - namespaceFor TraceBootstrapPeersFlagChangedWhilstInSensitiveState = - Namespace [] ["BootstrapPeersFlagChangedWhilstInSensitiveState"] - namespaceFor TraceOutboundGovernorCriticalFailure {} = - Namespace [] ["OutboundGovernorCriticalFailure"] - namespaceFor TraceChurnAction {} = - Namespace [] ["ChurnAction"] - namespaceFor TraceChurnTimeout {} = - Namespace [] ["ChurnTimeout"] - namespaceFor TraceDebugState {} = - Namespace [] ["DebugState"] - - severityFor (Namespace [] ["LocalRootPeersChanged"]) _ = Just Notice - severityFor (Namespace [] ["TargetsChanged"]) _ = Just Notice - severityFor (Namespace [] ["PublicRootsRequest"]) _ = Just Info - severityFor (Namespace [] ["PublicRootsResults"]) _ = Just Info - severityFor (Namespace [] ["PublicRootsFailure"]) _ = Just Error - severityFor (Namespace [] ["ForgetColdPeers"]) _ = Just Info - severityFor (Namespace [] ["BigLedgerPeersRequest"]) _ = Just Info - severityFor (Namespace [] ["BigLedgerPeersResults"]) _ = Just Info - severityFor (Namespace [] ["BigLedgerPeersFailure"]) _ = Just Info - severityFor (Namespace [] ["ForgetBigLedgerPeers"]) _ = Just Info - severityFor (Namespace [] ["PeerShareRequests"]) _ = Just Debug - severityFor (Namespace [] ["PeerShareResults"]) _ = Just Debug - severityFor (Namespace [] ["PeerShareResultsFiltered"]) _ = Just Info - severityFor (Namespace [] ["PickInboundPeers"]) _ = Just Info - severityFor (Namespace [] ["PromoteColdPeers"]) _ = Just Info - severityFor (Namespace [] ["PromoteColdLocalPeers"]) _ = Just Info - severityFor (Namespace [] ["PromoteColdFailed"]) _ = Just Info - severityFor (Namespace [] ["PromoteColdDone"]) _ = Just Info - severityFor (Namespace [] ["PromoteColdBigLedgerPeers"]) _ = Just Info - severityFor (Namespace [] ["PromoteColdBigLedgerPeerFailed"]) _ = Just Info - severityFor (Namespace [] ["PromoteColdBigLedgerPeerDone"]) _ = Just Info - severityFor (Namespace [] ["PromoteWarmPeers"]) _ = Just Info - severityFor (Namespace [] ["PromoteWarmLocalPeers"]) _ = Just Info - severityFor (Namespace [] ["PromoteWarmFailed"]) _ = Just Info - severityFor (Namespace [] ["PromoteWarmDone"]) _ = Just Info - severityFor (Namespace [] ["PromoteWarmAborted"]) _ = Just Info - severityFor (Namespace [] ["PromoteWarmBigLedgerPeers"]) _ = Just Info - severityFor (Namespace [] ["PromoteWarmBigLedgerPeerFailed"]) _ = Just Info - severityFor (Namespace [] ["PromoteWarmBigLedgerPeerDone"]) _ = Just Info - severityFor (Namespace [] ["PromoteWarmBigLedgerPeerAborted"]) _ = Just Info - severityFor (Namespace [] ["DemoteWarmPeers"]) _ = Just Info - severityFor (Namespace [] ["DemoteWarmFailed"]) _ = Just Info - severityFor (Namespace [] ["DemoteWarmFailed", "CoolingToColdTimeout"]) _ = Just Error - severityFor (Namespace [] ["DemoteWarmDone"]) _ = Just Info - severityFor (Namespace [] ["DemoteWarmBigLedgerPeers"]) _ = Just Info - severityFor (Namespace [] ["DemoteWarmBigLedgerPeerFailed"]) _ = Just Info - severityFor (Namespace [] ["DemoteWarmBigLedgerPeerFailed", "CoolingToColdTimeout"]) _ = Just Error - severityFor (Namespace [] ["DemoteWarmBigLedgerPeerDone"]) _ = Just Info - severityFor (Namespace [] ["DemoteHotPeers"]) _ = Just Info - severityFor (Namespace [] ["DemoteLocalHotPeers"]) _ = Just Info - severityFor (Namespace [] ["DemoteHotFailed"]) _ = Just Info - severityFor (Namespace [] ["DemoteHotFailed", "CoolingToColdTimeout"]) _ = Just Error - severityFor (Namespace [] ["DemoteHotDone"]) _ = Just Info - severityFor (Namespace [] ["DemoteHotBigLedgerPeers"]) _ = Just Info - severityFor (Namespace [] ["DemoteHotBigLedgerPeerFailed"]) _ = Just Info - severityFor (Namespace [] ["DemoteHotBigLedgerPeerFailed", "CoolingToColdTimeout"]) _ = Just Error - severityFor (Namespace [] ["DemoteHotBigLedgerPeerDone"]) _ = Just Info - severityFor (Namespace [] ["DemoteAsynchronous"]) _ = Just Info - severityFor (Namespace [] ["DemoteLocalAsynchronous"]) _ = Just Warning - severityFor (Namespace [] ["DemoteBigLedgerPeersAsynchronous"]) _ = Just Info - severityFor (Namespace [] ["GovernorWakeup"]) _ = Just Info - severityFor (Namespace [] ["ChurnWait"]) _ = Just Info - severityFor (Namespace [] ["LedgerStateJudgementChanged"]) _ = Just Info - severityFor (Namespace [] ["OnlyBootstrapPeers"]) _ = Just Info - severityFor (Namespace [] ["UseBootstrapPeersChanged"]) _ = Just Notice - severityFor (Namespace [] ["VerifyPeerSnapshot"]) _ = Just Error - severityFor (Namespace [] ["BootstrapPeersFlagChangedWhilstInSensitiveState"]) _ = Just Warning - severityFor (Namespace [] ["OutboundGovernorCriticalFailure"]) _ = Just Error - severityFor (Namespace [] ["ChurnAction"]) _ = Just Info - severityFor (Namespace [] ["ChurnTimeout"]) _ = Just Notice - severityFor (Namespace [] ["DebugState"]) _ = Just Info - severityFor _ _ = Nothing - - documentFor (Namespace [] ["LocalRootPeersChanged"]) = Just "" - documentFor (Namespace [] ["TargetsChanged"]) = Just "" - documentFor (Namespace [] ["PublicRootsRequest"]) = Just "" - documentFor (Namespace [] ["PublicRootsResults"]) = Just "" - documentFor (Namespace [] ["PublicRootsFailure"]) = Just "" - documentFor (Namespace [] ["PeerShareRequests"]) = Just $ mconcat - [ "target known peers, actual known peers, peers available for gossip," - , " peers selected for gossip" - ] - documentFor (Namespace [] ["PeerShareResults"]) = Just "" - documentFor (Namespace [] ["ForgetColdPeers"]) = Just - "target known peers, actual known peers, selected peers" - documentFor (Namespace [] ["PromoteColdPeers"]) = Just - "target established, actual established, selected peers" - documentFor (Namespace [] ["PromoteColdLocalPeers"]) = Just - "target local established, actual local established, selected peers" - documentFor (Namespace [] ["PromoteColdFailed"]) = Just $ mconcat - [ "target established, actual established, peer, delay until next" - , " promotion, reason" - ] - documentFor (Namespace [] ["PromoteColdDone"]) = Just - "target active, actual active, selected peers" - documentFor (Namespace [] ["PromoteWarmPeers"]) = Just - "target active, actual active, selected peers" - documentFor (Namespace [] ["PromoteWarmLocalPeers"]) = Just - "local per-group (target active, actual active), selected peers" - documentFor (Namespace [] ["PromoteWarmFailed"]) = Just - "target active, actual active, peer, reason" - documentFor (Namespace [] ["PromoteWarmDone"]) = Just - "target active, actual active, peer" - documentFor (Namespace [] ["PromoteWarmAborted"]) = Just "" - documentFor (Namespace [] ["DemoteWarmPeers"]) = Just - "target established, actual established, selected peers" - documentFor (Namespace [] ["DemoteWarmFailed"]) = Just - "target established, actual established, peer, reason" - documentFor (Namespace [] ["DemoteWarmFailed", "CoolingToColdTimeout"]) = - Just "Impossible asynchronous demotion timeout" - documentFor (Namespace [] ["DemoteWarmBigLedgerPeerFailed", "CoolingToColdTimeout"]) = - Just "Impossible asynchronous demotion timeout" - documentFor (Namespace [] ["DemoteWarmDone"]) = Just - "target established, actual established, peer" - documentFor (Namespace [] ["DemoteHotPeers"]) = Just - "target active, actual active, selected peers" - documentFor (Namespace [] ["DemoteLocalHotPeers"]) = Just - "local per-group (target active, actual active), selected peers" - documentFor (Namespace [] ["DemoteHotFailed"]) = Just - "target active, actual active, peer, reason" - documentFor (Namespace [] ["DemoteHotFailed", "CoolingToColdTimeout"]) = - Just "Impossible asynchronous demotion timeout" - documentFor (Namespace [] ["DemoteHotBigLedgerPeerFailed", "CoolingToColdTimeout"]) = - Just "Impossible asynchronous demotion timeout" - documentFor (Namespace [] ["DemoteHotDone"]) = Just - "target active, actual active, peer" - documentFor (Namespace [] ["DemoteAsynchronous"]) = Just "" - documentFor (Namespace [] ["DemoteLocalAsynchronous"]) = Just "" - documentFor (Namespace [] ["GovernorWakeup"]) = Just "" - documentFor (Namespace [] ["ChurnWait"]) = Just "" - documentFor (Namespace [] ["PickInboundPeers"]) = Just - "An inbound connection was added to known set of outbound governor" - documentFor (Namespace [] ["OutboundGovernorCriticalFailure"]) = Just - "Outbound Governor was killed unexpectedly" - documentFor (Namespace [] ["DebugState"]) = Just - "peer selection internal state" - documentFor (Namespace [] ["VerifyPeerSnapshot"]) = Just - "Verification outcome of big ledger peer snapshot" - documentFor _ = Nothing - - metricsDocFor (Namespace [] ["ChurnAction"]) = - [ ("peerSelection.churn.DecreasedActivePeers.duration", "") - , ("peerSelection.churn.DecreasedActiveBigLedgerPeers.duration", "") - , ("peerSelection.churn.DecreasedEstablishedPeers.duration", "") - , ("peerSelection.churn.DecreasedEstablishedBigLedgerPeers.duration", "") - , ("peerSelection.churn.DecreasedKnownPeers.duration", "") - , ("peerSelection.churn.DecreasedKnownBigLedgerPeers.duration", "") - ] - metricsDocFor _ = [] - - allNamespaces = [ - Namespace [] ["LocalRootPeersChanged"] - , Namespace [] ["TargetsChanged"] - , Namespace [] ["PublicRootsRequest"] - , Namespace [] ["PublicRootsResults"] - , Namespace [] ["PublicRootsFailure"] - , Namespace [] ["ForgetColdPeers"] - , Namespace [] ["BigLedgerPeersRequest"] - , Namespace [] ["BigLedgerPeersResults"] - , Namespace [] ["BigLedgerPeersFailure"] - , Namespace [] ["ForgetBigLedgerPeers"] - , Namespace [] ["PeerShareRequests"] - , Namespace [] ["PeerShareResults"] - , Namespace [] ["PeerShareResultsFiltered"] - , Namespace [] ["PickInboundPeers"] - , Namespace [] ["PromoteColdPeers"] - , Namespace [] ["PromoteColdLocalPeers"] - , Namespace [] ["PromoteColdFailed"] - , Namespace [] ["PromoteColdDone"] - , Namespace [] ["PromoteColdBigLedgerPeers"] - , Namespace [] ["PromoteColdBigLedgerPeerFailed"] - , Namespace [] ["PromoteColdBigLedgerPeerDone"] - , Namespace [] ["PromoteWarmPeers"] - , Namespace [] ["PromoteWarmLocalPeers"] - , Namespace [] ["PromoteWarmFailed"] - , Namespace [] ["PromoteWarmDone"] - , Namespace [] ["PromoteWarmAborted"] - , Namespace [] ["PromoteWarmBigLedgerPeers"] - , Namespace [] ["PromoteWarmBigLedgerPeerFailed"] - , Namespace [] ["PromoteWarmBigLedgerPeerDone"] - , Namespace [] ["PromoteWarmBigLedgerPeerAborted"] - , Namespace [] ["DemoteWarmPeers"] - , Namespace [] ["DemoteWarmFailed"] - , Namespace [] ["DemoteWarmFailed", "CoolingToColdTimeout"] - , Namespace [] ["DemoteWarmDone"] - , Namespace [] ["DemoteWarmBigLedgerPeers"] - , Namespace [] ["DemoteWarmBigLedgerPeerFailed"] - , Namespace [] ["DemoteWarmBigLedgerPeerFailed", "CoolingToColdTimeout"] - , Namespace [] ["DemoteWarmBigLedgerPeerDone"] - , Namespace [] ["DemoteHotPeers"] - , Namespace [] ["DemoteLocalHotPeers"] - , Namespace [] ["DemoteHotFailed"] - , Namespace [] ["DemoteHotFailed", "CoolingToColdTimeout"] - , Namespace [] ["DemoteHotDone"] - , Namespace [] ["DemoteHotBigLedgerPeers"] - , Namespace [] ["DemoteHotBigLedgerPeerFailed"] - , Namespace [] ["DemoteHotBigLedgerPeerFailed", "CoolingToColdTimeout"] - , Namespace [] ["DemoteHotBigLedgerPeerDone"] - , Namespace [] ["DemoteAsynchronous"] - , Namespace [] ["DemoteLocalAsynchronous"] - , Namespace [] ["DemoteBigLedgerPeersAsynchronous"] - , Namespace [] ["GovernorWakeup"] - , Namespace [] ["ChurnWait"] - , Namespace [] ["ChurnAction"] - , Namespace [] ["ChurnTimeout"] - , Namespace [] ["LedgerStateJudgementChanged"] - , Namespace [] ["OnlyBootstrapPeers"] - , Namespace [] ["BootstrapPeersFlagChangedWhilstInSensitiveState"] - , Namespace [] ["UseBootstrapPeersChanged"] - , Namespace [] ["VerifyPeerSnapshot"] - , Namespace [] ["OutboundGovernorCriticalFailure"] - , Namespace [] ["DebugState"] - ] - --------------------------------------------------------------------------------- --- DebugPeerSelection Tracer --------------------------------------------------------------------------------- - -instance LogFormatting CardanoDebugPeerSelection where - forMachine dtal@DNormal (TraceGovernorState blockedAt wakeupAfter - st@PeerSelectionState { targets }) = - mconcat [ "kind" .= String "DebugPeerSelection" - , "blockedAt" .= String (pack $ show blockedAt) - , "wakeupAfter" .= String (pack $ show wakeupAfter) - , "targets" .= peerSelectionTargetsToObject targets - , "counters" .= forMachine dtal (peerSelectionStateToCounters Cardano.PublicRootPeers.toSet Cardano.cardanoPeerSelectionStatetoCounters st) - ] - forMachine _ (TraceGovernorState blockedAt wakeupAfter ev) = - mconcat [ "kind" .= String "DebugPeerSelection" - , "blockedAt" .= String (pack $ show blockedAt) - , "wakeupAfter" .= String (pack $ show wakeupAfter) - , "peerSelectionState" .= String (pack $ show ev) - ] - forHuman = pack . show - -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 MetaTrace (DebugPeerSelection extraState extraFlags extraPeers SockAddr) where - namespaceFor TraceGovernorState {} = Namespace [] ["GovernorState"] - - severityFor (Namespace _ ["GovernorState"]) _ = Just Debug - severityFor _ _ = Nothing - - documentFor (Namespace _ ["GovernorState"]) = Just "" - documentFor _ = Nothing - - allNamespaces = [ - Namespace [] ["GovernorState"] - ] - - --------------------------------------------------------------------------------- --- PeerSelectionCounters --------------------------------------------------------------------------------- - -instance LogFormatting (PeerSelectionCounters (Cardano.ExtraPeerSelectionSetsWithSizes addr)) where - forMachine _dtal 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) - ] - asMetrics psc = - case psc of - PeerSelectionCountersHWC {..} -> - -- Deprecated metrics; they will be removed in a future version. - [ IntM - "peerSelection.Cold" - (fromIntegral numberOfColdPeers) - , IntM - "peerSelection.Warm" - (fromIntegral numberOfWarmPeers) - , IntM - "peerSelection.Hot" - (fromIntegral numberOfHotPeers) - , IntM - "peerSelection.ColdBigLedgerPeers" - (fromIntegral numberOfColdBigLedgerPeers) - , IntM - "peerSelection.WarmBigLedgerPeers" - (fromIntegral numberOfWarmBigLedgerPeers) - , IntM - "peerSelection.HotBigLedgerPeers" - (fromIntegral numberOfHotBigLedgerPeers) - - , IntM - "peerSelection.WarmLocalRoots" - (fromIntegral $ numberOfActiveLocalRootPeers psc) - , IntM - "peerSelection.HotLocalRoots" - (fromIntegral $ numberOfEstablishedLocalRootPeers psc - - numberOfActiveLocalRootPeers psc) - ] - ++ - case psc of - PeerSelectionCounters {..} -> - [ IntM "peerSelection.RootPeers" (fromIntegral numberOfRootPeers) - - , IntM "peerSelection.KnownPeers" (fromIntegral numberOfKnownPeers) - , IntM "peerSelection.ColdPeersPromotions" (fromIntegral numberOfColdPeersPromotions) - , IntM "peerSelection.EstablishedPeers" (fromIntegral numberOfEstablishedPeers) - , IntM "peerSelection.WarmPeersDemotions" (fromIntegral numberOfWarmPeersDemotions) - , IntM "peerSelection.WarmPeersPromotions" (fromIntegral numberOfWarmPeersPromotions) - , IntM "peerSelection.ActivePeers" (fromIntegral numberOfActivePeers) - , IntM "peerSelection.ActivePeersDemotions" (fromIntegral numberOfActivePeersDemotions) - - , IntM "peerSelection.KnownBigLedgerPeers" (fromIntegral numberOfKnownBigLedgerPeers) - , IntM "peerSelection.ColdBigLedgerPeersPromotions" (fromIntegral numberOfColdBigLedgerPeersPromotions) - , IntM "peerSelection.EstablishedBigLedgerPeers" (fromIntegral numberOfEstablishedBigLedgerPeers) - , IntM "peerSelection.WarmBigLedgerPeersDemotions" (fromIntegral numberOfWarmBigLedgerPeersDemotions) - , IntM "peerSelection.WarmBigLedgerPeersPromotions" (fromIntegral numberOfWarmBigLedgerPeersPromotions) - , IntM "peerSelection.ActiveBigLedgerPeers" (fromIntegral numberOfActiveBigLedgerPeers) - , IntM "peerSelection.ActiveBigLedgerPeersDemotions" (fromIntegral numberOfActiveBigLedgerPeersDemotions) - - , IntM "peerSelection.KnownLocalRootPeers" (fromIntegral numberOfKnownLocalRootPeers) - , IntM "peerSelection.EstablishedLocalRootPeers" (fromIntegral numberOfEstablishedLocalRootPeers) - , IntM "peerSelection.WarmLocalRootPeersPromotions" (fromIntegral numberOfWarmLocalRootPeersPromotions) - , IntM "peerSelection.ActiveLocalRootPeers" (fromIntegral numberOfActiveLocalRootPeers) - , IntM "peerSelection.ActiveLocalRootPeersDemotions" (fromIntegral numberOfActiveLocalRootPeersDemotions) - - - , IntM "peerSelection.KnownNonRootPeers" (fromIntegral numberOfKnownNonRootPeers) - , IntM "peerSelection.ColdNonRootPeersPromotions" (fromIntegral numberOfColdNonRootPeersPromotions) - , IntM "peerSelection.EstablishedNonRootPeers" (fromIntegral numberOfEstablishedNonRootPeers) - , IntM "peerSelection.WarmNonRootPeersDemotions" (fromIntegral numberOfWarmNonRootPeersDemotions) - , IntM "peerSelection.WarmNonRootPeersPromotions" (fromIntegral numberOfWarmNonRootPeersPromotions) - , IntM "peerSelection.ActiveNonRootPeers" (fromIntegral numberOfActiveNonRootPeers) - , IntM "peerSelection.ActiveNonRootPeersDemotions" (fromIntegral numberOfActiveNonRootPeersDemotions) - - , IntM "peerSelection.KnownBootstrapPeers" (fromIntegral $ snd $ Cardano.viewKnownBootstrapPeers extraCounters) - , IntM "peerSelection.ColdBootstrapPeersPromotions" (fromIntegral $ snd $ Cardano.viewColdBootstrapPeersPromotions extraCounters) - , IntM "peerSelection.EstablishedBootstrapPeers" (fromIntegral $ snd $ Cardano.viewEstablishedBootstrapPeers extraCounters) - , IntM "peerSelection.WarmBootstrapPeersDemotions" (fromIntegral $ snd $ Cardano.viewWarmBootstrapPeersDemotions extraCounters) - , IntM "peerSelection.WarmBootstrapPeersPromotions" (fromIntegral $ snd $ Cardano.viewWarmBootstrapPeersPromotions extraCounters) - , IntM "peerSelection.ActiveBootstrapPeers" (fromIntegral $ snd $ Cardano.viewActiveBootstrapPeers extraCounters) - , IntM "peerSelection.ActiveBootstrapPeersDemotions" (fromIntegral $ snd $ Cardano.viewActiveBootstrapPeersDemotions extraCounters) - ] - -instance MetaTrace (PeerSelectionCounters extraCounters) where - namespaceFor PeerSelectionCounters {} = Namespace [] ["Counters"] - - severityFor (Namespace _ ["Counters"]) _ = Just Debug - severityFor _ _ = Nothing - - documentFor (Namespace _ ["Counters"]) = Just - "Counters of selected peers" - documentFor _ = Nothing - - metricsDocFor (Namespace _ ["Counters"]) = - [ ("peerSelection.Cold", "Number of cold peers") - , ("peerSelection.Warm", "Number of warm peers") - , ("peerSelection.Hot", "Number of hot peers") - , ("peerSelection.ColdBigLedgerPeers", "Number of cold big ledger peers") - , ("peerSelection.WarmBigLedgerPeers", "Number of warm big ledger peers") - , ("peerSelection.HotBigLedgerPeers", "Number of hot big ledger peers") - , ("peerSelection.LocalRoots", "Numbers of warm & hot local roots") - - , ("peerSelection.RootPeers", "Number of root peers") - , ("peerSelection.KnownPeers", "Number of known peers") - , ("peerSelection.ColdPeersPromotions", "Number of cold peers promotions") - , ("peerSelection.EstablishedPeers", "Number of established peers") - , ("peerSelection.WarmPeersDemotions", "Number of warm peers demotions") - , ("peerSelection.WarmPeersPromotions", "Number of warm peers promotions") - , ("peerSelection.ActivePeers", "Number of active peers") - , ("peerSelection.ActivePeersDemotions", "Number of active peers demotions") - - , ("peerSelection.KnownBigLedgerPeers", "Number of known big ledger peers") - , ("peerSelection.ColdBigLedgerPeersPromotions", "Number of cold big ledger peers promotions") - , ("peerSelection.EstablishedBigLedgerPeers", "Number of established big ledger peers") - , ("peerSelection.WarmBigLedgerPeersDemotions", "Number of warm big ledger peers demotions") - , ("peerSelection.WarmBigLedgerPeersPromotions", "Number of warm big ledger peers promotions") - , ("peerSelection.ActiveBigLedgerPeers", "Number of active big ledger peers") - , ("peerSelection.ActiveBigLedgerPeersDemotions", "Number of active big ledger peers demotions") - - , ("peerSelection.KnownLocalRootPeers", "Number of known local root peers") - , ("peerSelection.EstablishedLocalRootPeers", "Number of established local root peers") - , ("peerSelection.WarmLocalRootPeersPromotions", "Number of warm local root peers promotions") - , ("peerSelection.ActiveLocalRootPeers", "Number of active local root peers") - , ("peerSelection.ActiveLocalRootPeersDemotions", "Number of active local root peers demotions") - - , ("peerSelection.KnownNonRootPeers", "Number of known non root peers") - , ("peerSelection.ColdNonRootPeersPromotions", "Number of cold non root peers promotions") - , ("peerSelection.EstablishedNonRootPeers", "Number of established non root peers") - , ("peerSelection.WarmNonRootPeersDemotions", "Number of warm non root peers demotions") - , ("peerSelection.WarmNonRootPeersPromotions", "Number of warm non root peers promotions") - , ("peerSelection.ActiveNonRootPeers", "Number of active non root peers") - , ("peerSelection.ActiveNonRootPeersDemotions", "Number of active non root peers demotions") - - , ("peerSelection.KnownBootstrapPeers", "Number of known bootstrap peers") - , ("peerSelection.ColdBootstrapPeersPromotions", "Number of cold bootstrap peers promotions") - , ("peerSelection.EstablishedBootstrapPeers", "Number of established bootstrap peers") - , ("peerSelection.WarmBootstrapPeersDemotions", "Number of warm bootstrap peers demotions") - , ("peerSelection.WarmBootstrapPeersPromotions", "Number of warm bootstrap peers promotions") - , ("peerSelection.ActiveBootstrapPeers", "Number of active bootstrap peers") - , ("peerSelection.ActiveBootstrapPeersDemotions", "Number of active bootstrap peers demotions") - - ] - metricsDocFor _ = [] - - allNamespaces =[ - Namespace [] ["Counters"] - ] - - --------------------------------------------------------------------------------- --- ChurnCounters Tracer --------------------------------------------------------------------------------- - - -instance LogFormatting ChurnCounters where - forMachine _dtal (ChurnCounter action c) = - mconcat [ "kind" .= String "ChurnCounter" - , "action" .= String (pack $ show action) - , "counter" .= c - ] - asMetrics (ChurnCounter action c) = - [ IntM - ("peerSelection.churn." <> pack (show action)) - (fromIntegral c) - ] - -instance MetaTrace ChurnCounters where - namespaceFor ChurnCounter {} = Namespace [] ["ChurnCounters"] - - severityFor (Namespace _ ["ChurnCounters"]) _ = Just Info - severityFor _ _ = Nothing - - documentFor (Namespace _ ["ChurnCounters"]) = Just - "churn counters" - documentFor _ = Nothing - - metricsDocFor (Namespace _ ["ChurnCounters"]) = - [ ("peerSelection.churn.DecreasedActivePeers", "number of decreased active peers") - , ("peerSelection.churn.IncreasedActivePeers", "number of increased active peers") - , ("peerSelection.churn.DecreasedActiveBigLedgerPeers", "number of decreased active big ledger peers") - , ("peerSelection.churn.IncreasedActiveBigLedgerPeers", "number of increased active big ledger peers") - , ("peerSelection.churn.DecreasedEstablishedPeers", "number of decreased established peers") - , ("peerSelection.churn.IncreasedEstablishedPeers", "number of increased established peers") - , ("peerSelection.churn.IncreasedEstablishedBigLedgerPeers", "number of increased established big ledger peers") - , ("peerSelection.churn.DecreasedEstablishedBigLedgerPeers", "number of decreased established big ledger peers") - , ("peerSelection.churn.DecreasedKnownPeers", "number of decreased known peers") - , ("peerSelection.churn.IncreasedKnownPeers", "number of increased known peers") - , ("peerSelection.churn.DecreasedKnownBigLedgerPeers", "number of decreased known big ledger peers") - , ("peerSelection.churn.IncreasedKnownBigLedgerPeers", "number of increased known big ledger peers") - ] - metricsDocFor _ = [] - - allNamespaces =[ - Namespace [] ["ChurnCounters"] - ] - - --------------------------------------------------------------------------------- --- PeerSelectionActions Tracer --------------------------------------------------------------------------------- - --- TODO: Write PeerStatusChangeType ToJSON at ouroboros-network --- For that an export is needed at ouroboros-network -instance Show lAddr => LogFormatting (PeerSelectionActionsTrace SockAddr lAddr) where - forMachine _dtal (PeerStatusChanged ps) = - mconcat [ "kind" .= String "PeerStatusChanged" - , "peerStatusChangeType" .= show ps - ] - forMachine _dtal (PeerStatusChangeFailure ps f) = - mconcat [ "kind" .= String "PeerStatusChangeFailure" - , "peerStatusChangeType" .= show ps - , "reason" .= show f - ] - forMachine _dtal (PeerMonitoringError connId s) = - mconcat [ "kind" .= String "PeerMonitoringError" - , "connectionId" .= toJSON connId - , "reason" .= show s - ] - forMachine _dtal (PeerMonitoringResult connId wf) = - mconcat [ "kind" .= String "PeerMonitoringResult" - , "connectionId" .= toJSON connId - , "withProtocolTemp" .= show wf - ] - forMachine _dtal (AcquireConnectionError exception) = - mconcat [ "kind" .= String "AcquireConnectionError" - , "error" .= displayException exception - ] - forMachine _dtal (PeerHotDuration connId dt) = - mconcat [ "kind" .= String "PeerHotDuration" - , "connectionId" .= toJSON connId - , "time" .= show dt] - forHuman = pack . show - -instance MetaTrace (PeerSelectionActionsTrace SockAddr lAddr) where - namespaceFor PeerStatusChanged {} = Namespace [] ["StatusChanged"] - namespaceFor PeerStatusChangeFailure {} = Namespace [] ["StatusChangeFailure"] - namespaceFor PeerMonitoringError {} = Namespace [] ["MonitoringError"] - namespaceFor PeerMonitoringResult {} = Namespace [] ["MonitoringResult"] - namespaceFor AcquireConnectionError {} = Namespace [] ["ConnectionError"] - namespaceFor PeerHotDuration {} = Namespace [] ["PeerHotDuration"] - - severityFor (Namespace _ ["StatusChanged"]) _ = Just Info - severityFor (Namespace _ ["StatusChangeFailure"]) _ = Just Error - severityFor (Namespace _ ["MonitoringError"]) _ = Just Error - severityFor (Namespace _ ["MonitoringResult"]) _ = Just Debug - severityFor (Namespace _ ["ConnectionError"]) _ = Just Error - severityFor (Namespace _ ["PeerHotDuration"]) _ = Just Info - severityFor _ _ = Nothing - - documentFor (Namespace _ ["StatusChanged"]) = Just - "" - documentFor (Namespace _ ["StatusChangeFailure"]) = Just - "" - documentFor (Namespace _ ["MonitoringError"]) = Just - "" - documentFor (Namespace _ ["MonitoringResult"]) = Just - "" - documentFor (Namespace _ ["ConnectionError"]) = Just - "" - documentFor (Namespace _ ["PeerHotDuration"]) = Just - "Reports how long the outbound connection was in hot state" - documentFor _ = Nothing - - allNamespaces = [ - Namespace [] ["StatusChanged"] - , Namespace [] ["StatusChangeFailure"] - , Namespace [] ["MonitoringError"] - , Namespace [] ["MonitoringResult"] - , Namespace [] ["ConnectionError"] - , Namespace [] ["PeerHotDuration"] - ] - --------------------------------------------------------------------------------- --- Connection Manager Tracer --------------------------------------------------------------------------------- - -instance (Show addr, LogFormatting addr, ToJSON addr, LogFormatting handler, Show handler) - => LogFormatting (ConnectionManager.Trace addr handler) where - forMachine dtal (TrIncludeConnection prov peerAddr) = - mconcat $ reverse - [ "kind" .= String "IncludeConnection" - , "remoteAddress" .= forMachine dtal peerAddr - , "provenance" .= String (pack . show $ prov) - ] - forMachine _dtal (TrReleaseConnection prov connId) = - mconcat $ reverse - [ "kind" .= String "UnregisterConnection" - , "remoteAddress" .= toJSON connId - , "provenance" .= String (pack . show $ prov) - ] - forMachine _dtal (TrConnect (Just localAddress) remoteAddress diffusionMode) = - mconcat - [ "kind" .= String "Connect" - , "connectionId" .= toJSON ConnectionId { localAddress, remoteAddress } - , "diffusionMode" .= toJSON diffusionMode - ] - forMachine dtal (TrConnect Nothing remoteAddress diffusionMode) = - mconcat - [ "kind" .= String "Connect" - , "remoteAddress" .= forMachine dtal remoteAddress - , "diffusionMode" .= toJSON diffusionMode - ] - forMachine _dtal (TrConnectError (Just localAddress) remoteAddress err) = - mconcat - [ "kind" .= String "ConnectError" - , "connectionId" .= toJSON ConnectionId { localAddress, remoteAddress } - , "reason" .= String (pack . show $ err) - ] - forMachine dtal (TrConnectError Nothing remoteAddress err) = - mconcat - [ "kind" .= String "ConnectError" - , "remoteAddress" .= forMachine dtal remoteAddress - , "reason" .= String (pack . show $ err) - ] - forMachine _dtal (TrTerminatingConnection prov connId) = - mconcat - [ "kind" .= String "TerminatingConnection" - , "provenance" .= String (pack . show $ prov) - , "connectionId" .= toJSON connId - ] - forMachine dtal (TrTerminatedConnection prov remoteAddress) = - mconcat - [ "kind" .= String "TerminatedConnection" - , "provenance" .= String (pack . show $ prov) - , "remoteAddress" .= forMachine dtal remoteAddress - ] - forMachine dtal (TrConnectionHandler connId handler) = - mconcat - [ "kind" .= String "ConnectionHandler" - , "connectionId" .= toJSON connId - , "connectionHandler" .= forMachine dtal handler - ] - forMachine _dtal TrShutdown = - mconcat - [ "kind" .= String "Shutdown" - ] - forMachine dtal (TrConnectionExists prov remoteAddress inState) = - mconcat - [ "kind" .= String "ConnectionExists" - , "provenance" .= String (pack . show $ prov) - , "remoteAddress" .= forMachine dtal remoteAddress - , "state" .= toJSON inState - ] - forMachine _dtal (TrForbiddenConnection connId) = - mconcat - [ "kind" .= String "ForbiddenConnection" - , "connectionId" .= toJSON connId - ] - forMachine _dtal (TrConnectionFailure connId) = - mconcat - [ "kind" .= String "ConnectionFailure" - , "connectionId" .= toJSON connId - ] - forMachine dtal (TrConnectionNotFound prov remoteAddress) = - mconcat - [ "kind" .= String "ConnectionNotFound" - , "remoteAddress" .= forMachine dtal remoteAddress - , "provenance" .= String (pack . show $ prov) - ] - forMachine dtal (TrForbiddenOperation remoteAddress connState) = - mconcat - [ "kind" .= String "ForbiddenOperation" - , "remoteAddress" .= forMachine dtal remoteAddress - , "connectionState" .= toJSON connState - ] - forMachine _dtal (TrPruneConnections pruningSet numberPruned chosenPeers) = - mconcat - [ "kind" .= String "PruneConnections" - , "prunedPeers" .= toJSON pruningSet - , "numberPrunedPeers" .= toJSON numberPruned - , "choiceSet" .= toJSON (toJSON `Set.map` chosenPeers) - ] - forMachine _dtal (TrConnectionCleanup connId) = - mconcat - [ "kind" .= String "ConnectionCleanup" - , "connectionId" .= toJSON connId - ] - forMachine _dtal (TrConnectionTimeWait connId) = - mconcat - [ "kind" .= String "ConnectionTimeWait" - , "connectionId" .= toJSON connId - ] - forMachine _dtal (TrConnectionTimeWaitDone connId) = - mconcat - [ "kind" .= String "ConnectionTimeWaitDone" - , "connectionId" .= toJSON connId - ] - forMachine _dtal (TrConnectionManagerCounters cmCounters) = - mconcat - [ "kind" .= String "ConnectionManagerCounters" - , "state" .= toJSON cmCounters - ] - forMachine _dtal (TrState cmState) = - mconcat - [ "kind" .= String "ConnectionManagerState" - , "state" .= listValue (\(remoteAddr, inner) -> - object - [ "connections" .= - listValue (\(localAddr, connState) -> - object - [ "localAddress" .= localAddr - , "state" .= toJSON connState - ] - ) - (Map.toList inner) - , "remoteAddress" .= toJSON remoteAddr - ] - ) - (Map.toList (getConnMap cmState)) - ] - forMachine _dtal (ConnectionManager.TrUnexpectedlyFalseAssertion info) = - mconcat - [ "kind" .= String "UnexpectedlyFalseAssertion" - , "info" .= String (pack . show $ info) - ] - forHuman = pack . show - asMetrics (TrConnectionManagerCounters ConnectionManagerCounters {..}) = - [ IntM - "connectionManager.fullDuplexConns" - (fromIntegral fullDuplexConns) - , IntM - "connectionManager.duplexConns" - (fromIntegral duplexConns) - , IntM - "connectionManager.unidirectionalConns" - (fromIntegral unidirectionalConns) - , IntM - "connectionManager.inboundConns" - (fromIntegral inboundConns) - , IntM - "connectionManager.outboundConns" - (fromIntegral outboundConns) - ] - asMetrics _ = [] - -instance (Show versionNumber, ToJSON versionNumber, ToJSON agreedOptions) - => LogFormatting (ConnectionHandlerTrace versionNumber agreedOptions) where - forMachine _dtal (TrHandshakeSuccess versionNumber agreedOptions) = - mconcat - [ "kind" .= String "HandshakeSuccess" - , "versionNumber" .= toJSON versionNumber - , "agreedOptions" .= toJSON agreedOptions - ] - forMachine _dtal (TrHandshakeQuery vMap) = - mconcat - [ "kind" .= String "HandshakeQuery" - , "versions" .= toJSON ((\(k,v) -> object [ - "versionNumber" .= k - , "options" .= v - ]) <$> Map.toList vMap) - ] - forMachine _dtal (TrHandshakeClientError err) = - mconcat - [ "kind" .= String "HandshakeClientError" - , "reason" .= toJSON err - ] - forMachine _dtal (TrHandshakeServerError err) = - mconcat - [ "kind" .= String "HandshakeServerError" - , "reason" .= toJSON err - ] - forMachine _dtal (TrConnectionHandlerError e err cerr) = - mconcat - [ "kind" .= String "Error" - , "context" .= show e - , "reason" .= show err - , "command" .= show cerr - ] - -instance MetaTrace handler => MetaTrace (ConnectionManager.Trace addr handler) where - namespaceFor TrIncludeConnection {} = Namespace [] ["IncludeConnection"] - namespaceFor TrReleaseConnection {} = Namespace [] ["UnregisterConnection"] - namespaceFor TrConnect {} = Namespace [] ["Connect"] - namespaceFor TrConnectError {} = Namespace [] ["ConnectError"] - namespaceFor TrTerminatingConnection {} = Namespace [] ["TerminatingConnection"] - namespaceFor TrTerminatedConnection {} = Namespace [] ["TerminatedConnection"] - namespaceFor (TrConnectionHandler _ hdl) = - nsPrependInner "ConnectionHandler" (namespaceFor hdl) - namespaceFor TrShutdown {} = Namespace [] ["Shutdown"] - namespaceFor TrConnectionExists {} = Namespace [] ["ConnectionExists"] - namespaceFor TrForbiddenConnection {} = Namespace [] ["ForbiddenConnection"] - namespaceFor TrConnectionFailure {} = Namespace [] ["ConnectionFailure"] - namespaceFor TrConnectionNotFound {} = Namespace [] ["ConnectionNotFound"] - namespaceFor TrForbiddenOperation {} = Namespace [] ["ForbiddenOperation"] - namespaceFor TrPruneConnections {} = Namespace [] ["PruneConnections"] - namespaceFor TrConnectionCleanup {} = Namespace [] ["ConnectionCleanup"] - namespaceFor TrConnectionTimeWait {} = Namespace [] ["ConnectionTimeWait"] - namespaceFor TrConnectionTimeWaitDone {} = Namespace [] ["ConnectionTimeWaitDone"] - namespaceFor TrConnectionManagerCounters {} = Namespace [] ["ConnectionManagerCounters"] - namespaceFor TrState {} = Namespace [] ["State"] - namespaceFor ConnectionManager.TrUnexpectedlyFalseAssertion {} = - Namespace [] ["UnexpectedlyFalseAssertion"] - - severityFor (Namespace _ ["IncludeConnection"]) _ = Just Debug - severityFor (Namespace _ ["UnregisterConnection"]) _ = Just Debug - severityFor (Namespace _ ["Connect"]) _ = Just Debug - severityFor (Namespace _ ["ConnectError"]) _ = Just Info - severityFor (Namespace _ ["TerminatingConnection"]) _ = Just Debug - severityFor (Namespace _ ["TerminatedConnection"]) _ = Just Debug - severityFor (Namespace out ("ConnectionHandler" : tl)) (Just (TrConnectionHandler _ hdl)) = - severityFor (Namespace out tl) (Just hdl) - severityFor (Namespace _ ("ConnectionHandler" : _)) Nothing = Just Info - severityFor (Namespace _ ["Shutdown"]) _ = Just Info - severityFor (Namespace _ ["ConnectionExists"]) _ = Just Info - severityFor (Namespace _ ["ForbiddenConnection"]) _ = Just Info - severityFor (Namespace _ ["ConnectionFailure"]) _ = Just Info - severityFor (Namespace _ ["ConnectionNotFound"]) _ = Just Debug - severityFor (Namespace _ ["ForbiddenOperation"]) _ = Just Info - severityFor (Namespace _ ["PruneConnections"]) _ = Just Notice - severityFor (Namespace _ ["ConnectionCleanup"]) _ = Just Debug - severityFor (Namespace _ ["ConnectionTimeWait"]) _ = Just Debug - severityFor (Namespace _ ["ConnectionTimeWaitDone"]) _ = Just Info - severityFor (Namespace _ ["ConnectionManagerCounters"]) _ = Just Info - severityFor (Namespace _ ["State"]) _ = Just Info - severityFor (Namespace _ ["UnexpectedlyFalseAssertion"]) _ = Just Error - severityFor _ _ = Nothing - - documentFor (Namespace _ ["IncludeConnection"]) = Just "" - documentFor (Namespace _ ["UnregisterConnection"]) = Just "" - documentFor (Namespace _ ["Connect"]) = Just "" - documentFor (Namespace _ ["ConnectError"]) = Just "" - documentFor (Namespace _ ["TerminatingConnection"]) = Just "" - documentFor (Namespace _ ["TerminatedConnection"]) = Just "" - documentFor (Namespace out ("ConnectionHandler" : tl)) = - documentFor (Namespace out tl :: Namespace handler) - documentFor (Namespace _ ["Shutdown"]) = Just "" - documentFor (Namespace _ ["ConnectionExists"]) = Just "" - documentFor (Namespace _ ["ForbiddenConnection"]) = Just "" - documentFor (Namespace _ ["ConnectionFailure"]) = Just "" - documentFor (Namespace _ ["ConnectionNotFound"]) = Just "" - documentFor (Namespace _ ["ForbiddenOperation"]) = Just "" - documentFor (Namespace _ ["PruneConnections"]) = Just "" - documentFor (Namespace _ ["ConnectionCleanup"]) = Just "" - documentFor (Namespace _ ["ConnectionTimeWait"]) = Just "" - documentFor (Namespace _ ["ConnectionTimeWaitDone"]) = Just "" - documentFor (Namespace _ ["ConnectionManagerCounters"]) = Just "" - documentFor (Namespace _ ["State"]) = Just "" - documentFor (Namespace _ ["UnexpectedlyFalseAssertion"]) = Just "" - documentFor _ = Nothing - - metricsDocFor (Namespace _ ["ConnectionManagerCounters"]) = - [("connectionManager.fullDuplexConns","") - ,("connectionManager.duplexConns","") - ,("connectionManager.unidirectionalConns","") - ,("connectionManager.inboundConns","") - ,("connectionManager.outboundConns","") - ,("connectionManager.prunableConns","") - ] - metricsDocFor _ = [] - - allNamespaces = [ - Namespace [] ["IncludeConnection"] - , Namespace [] ["UnregisterConnection"] - , Namespace [] ["Connect"] - , Namespace [] ["ConnectError"] - , Namespace [] ["TerminatingConnection"] - , Namespace [] ["TerminatedConnection"] - , Namespace [] ["Shutdown"] - , Namespace [] ["ConnectionExists"] - , Namespace [] ["ForbiddenConnection"] - , Namespace [] ["ConnectionFailure"] - , Namespace [] ["ConnectionNotFound"] - , Namespace [] ["ForbiddenOperation"] - , Namespace [] ["PruneConnections"] - , Namespace [] ["ConnectionCleanup"] - , Namespace [] ["ConnectionTimeWait"] - , Namespace [] ["ConnectionTimeWaitDone"] - , Namespace [] ["ConnectionManagerCounters"] - , Namespace [] ["State"] - , Namespace [] ["UnexpectedlyFalseAssertion"]] - ++ map (nsPrependInner "ConnectionHandler") - (allNamespaces :: [Namespace handler]) - - -instance MetaTrace (ConnectionHandlerTrace versionNumber agreedOptions) where - namespaceFor TrHandshakeSuccess {} = Namespace [] ["HandshakeSuccess"] - namespaceFor TrHandshakeQuery {} = Namespace [] ["HandshakeQuery"] - namespaceFor TrHandshakeClientError {} = Namespace [] ["HandshakeClientError"] - namespaceFor TrHandshakeServerError {} = Namespace [] ["HandshakeServerError"] - namespaceFor TrConnectionHandlerError {} = Namespace [] ["Error"] - - severityFor (Namespace _ ["HandshakeSuccess"]) _ = Just Info - severityFor (Namespace _ ["HandshakeQuery"]) _ = Just Info - severityFor (Namespace _ ["HandshakeClientError"]) _ = Just Notice - severityFor (Namespace _ ["HandshakeServerError"]) _ = Just Info - severityFor (Namespace _ ["Error"]) (Just (TrConnectionHandlerError _ _ ShutdownNode)) = Just Critical - severityFor (Namespace _ ["Error"]) (Just (TrConnectionHandlerError _ _ ShutdownPeer)) = Just Info - severityFor (Namespace _ ["Error"]) Nothing = Just Info - severityFor _ _ = Nothing - - documentFor (Namespace _ ["HandshakeSuccess"]) = Just "" - documentFor (Namespace _ ["HandshakeQuery"]) = Just "" - documentFor (Namespace _ ["HandshakeClientError"]) = Just "" - documentFor (Namespace _ ["HandshakeServerError"]) = Just "" - documentFor (Namespace _ ["Error"]) = Just "" - documentFor _ = Nothing - - allNamespaces = [ - Namespace [] ["HandshakeSuccess"] - , Namespace [] ["HandshakeQuery"] - , Namespace [] ["HandshakeClientError"] - , Namespace [] ["HandshakeServerError"] - , Namespace [] ["Error"] - ] - --------------------------------------------------------------------------------- --- Connection Manager Transition Tracer --------------------------------------------------------------------------------- - -instance (Show peerAddr, ToJSON peerAddr) - => LogFormatting (ConnectionManager.AbstractTransitionTrace peerAddr) where - forMachine _dtal (ConnectionManager.TransitionTrace peerAddr tr) = - mconcat $ reverse - [ "kind" .= String "ConnectionManagerTransition" - , "address" .= toJSON peerAddr - , "from" .= toJSON (ConnectionManager.fromState tr) - , "to" .= toJSON (ConnectionManager.toState tr) - ] - - forHuman = pack . show - - asMetrics _ = [] - -instance MetaTrace (ConnectionManager.AbstractTransitionTrace peerAddr) where - namespaceFor ConnectionManager.TransitionTrace {} = - Namespace [] ["Transition"] - - severityFor (Namespace _ ["Transition"]) _ = Just Debug - severityFor _ _ = Nothing - - documentFor (Namespace _ ["Transition"]) = Just "" - documentFor _ = Nothing - - allNamespaces = [Namespace [] ["Transition"]] - --------------------------------------------------------------------------------- --- Server Tracer --------------------------------------------------------------------------------- - -instance (Show addr, LogFormatting addr, ToJSON addr) - => LogFormatting (Server.Trace addr) where - forMachine _dtal (TrAcceptConnection connId) = - mconcat [ "kind" .= String "AcceptConnection" - , "address" .= toJSON connId - ] - forMachine _dtal (TrAcceptError exception) = - mconcat [ "kind" .= String "AcceptErroor" - , "reason" .= show exception - ] - forMachine dtal (TrAcceptPolicyTrace policyTrace) = - mconcat [ "kind" .= String "AcceptPolicyTrace" - , "policy" .= forMachine dtal policyTrace - ] - forMachine dtal (TrServerStarted peerAddrs) = - mconcat [ "kind" .= String "AcceptPolicyTrace" - , "addresses" .= toJSON (forMachine dtal `map` peerAddrs) - ] - forMachine _dtal TrServerStopped = - mconcat [ "kind" .= String "ServerStopped" - ] - forMachine _dtal (TrServerError exception) = - mconcat [ "kind" .= String "ServerError" - , "reason" .= show exception - ] - forHuman = pack . show - -instance MetaTrace (Server.Trace addr) where - namespaceFor TrAcceptConnection {} = Namespace [] ["AcceptConnection"] - namespaceFor TrAcceptError {} = Namespace [] ["AcceptError"] - namespaceFor TrAcceptPolicyTrace {} = Namespace [] ["AcceptPolicy"] - namespaceFor TrServerStarted {} = Namespace [] ["Started"] - namespaceFor TrServerStopped {} = Namespace [] ["Stopped"] - namespaceFor TrServerError {} = Namespace [] ["Error"] - - severityFor (Namespace _ ["AcceptConnection"]) _ = Just Debug - severityFor (Namespace _ ["AcceptError"]) _ = Just Error - severityFor (Namespace _ ["AcceptPolicy"]) _ = Just Notice - severityFor (Namespace _ ["Started"]) _ = Just Notice - severityFor (Namespace _ ["Stopped"]) _ = Just Notice - severityFor (Namespace _ ["Error"]) _ = Just Critical - severityFor _ _ = Nothing - - documentFor (Namespace _ ["AcceptConnection"]) = Just "" - documentFor (Namespace _ ["AcceptError"]) = Just "" - documentFor (Namespace _ ["AcceptPolicy"]) = Just "" - documentFor (Namespace _ ["Started"]) = Just "" - documentFor (Namespace _ ["Stopped"]) = Just "" - documentFor (Namespace _ ["Error"]) = Just "" - documentFor _ = Nothing - - allNamespaces = [ - Namespace [] ["AcceptConnection"] - , Namespace [] ["AcceptError"] - , Namespace [] ["AcceptPolicy"] - , Namespace [] ["Started"] - , Namespace [] ["Stopped"] - , Namespace [] ["Error"] - ] - --------------------------------------------------------------------------------- --- InboundGovernor Tracer --------------------------------------------------------------------------------- - -instance LogFormatting (InboundGovernor.Trace SockAddr) where - forMachine = forMachineGov - forHuman = pack . show - asMetrics (TrInboundGovernorCounters InboundGovernor.Counters {..}) = - [ IntM - "inboundGovernor.idle" - (fromIntegral idlePeersRemote) - , IntM - "inboundGovernor.cold" - (fromIntegral coldPeersRemote) - , IntM - "inboundGovernor.warm" - (fromIntegral warmPeersRemote) - , IntM - "inboundGovernor.hot" - (fromIntegral hotPeersRemote) - ] - asMetrics _ = [] - -instance LogFormatting (InboundGovernor.Trace LocalAddress) where - forMachine = forMachineGov - forHuman = pack . show - asMetrics (TrInboundGovernorCounters InboundGovernor.Counters {..}) = - [ IntM - "localInboundGovernor.idle" - (fromIntegral idlePeersRemote) - , IntM - "localInboundGovernor.cold" - (fromIntegral coldPeersRemote) - , IntM - "localInboundGovernor.warm" - (fromIntegral warmPeersRemote) - , IntM - "localInboundGovernor.hot" - (fromIntegral hotPeersRemote) - ] - asMetrics _ = [] - - -forMachineGov :: (ToJSON adr, Show adr, ToJSONKey adr) => DetailLevel -> InboundGovernor.Trace adr -> Object -forMachineGov _dtal (TrNewConnection p connId) = - mconcat [ "kind" .= String "NewConnection" - , "provenance" .= show p - , "connectionId" .= toJSON connId - ] -forMachineGov _dtal (TrResponderRestarted connId m) = - mconcat [ "kind" .= String "ResponderStarted" - , "connectionId" .= toJSON connId - , "miniProtocolNum" .= toJSON m - ] -forMachineGov _dtal (TrResponderStartFailure connId m s) = - mconcat [ "kind" .= String "ResponderStartFailure" - , "connectionId" .= toJSON connId - , "miniProtocolNum" .= toJSON m - , "reason" .= show s - ] -forMachineGov _dtal (TrResponderErrored connId m s) = - mconcat [ "kind" .= String "ResponderErrored" - , "connectionId" .= toJSON connId - , "miniProtocolNum" .= toJSON m - , "reason" .= show s - ] -forMachineGov _dtal (TrResponderStarted connId m) = - mconcat [ "kind" .= String "ResponderStarted" - , "connectionId" .= toJSON connId - , "miniProtocolNum" .= toJSON m - ] -forMachineGov _dtal (TrResponderTerminated connId m) = - mconcat [ "kind" .= String "ResponderTerminated" - , "connectionId" .= toJSON connId - , "miniProtocolNum" .= toJSON m - ] -forMachineGov _dtal (TrPromotedToWarmRemote connId opRes) = - mconcat [ "kind" .= String "PromotedToWarmRemote" - , "connectionId" .= toJSON connId - , "result" .= toJSON opRes - ] -forMachineGov _dtal (TrPromotedToHotRemote connId) = - mconcat [ "kind" .= String "PromotedToHotRemote" - , "connectionId" .= toJSON connId - ] -forMachineGov _dtal (TrDemotedToColdRemote connId od) = - mconcat [ "kind" .= String "DemotedToColdRemote" - , "connectionId" .= toJSON connId - , "result" .= show od - ] -forMachineGov _dtal (TrDemotedToWarmRemote connId) = - mconcat [ "kind" .= String "DemotedToWarmRemote" - , "connectionId" .= toJSON connId - ] -forMachineGov _dtal (TrWaitIdleRemote connId opRes) = - mconcat [ "kind" .= String "WaitIdleRemote" - , "connectionId" .= toJSON connId - , "result" .= toJSON opRes - ] -forMachineGov _dtal (TrMuxCleanExit connId) = - mconcat [ "kind" .= String "MuxCleanExit" - , "connectionId" .= toJSON connId - ] -forMachineGov _dtal (TrMuxErrored connId s) = - mconcat [ "kind" .= String "MuxErrored" - , "connectionId" .= toJSON connId - , "reason" .= show s - ] -forMachineGov _dtal (TrInboundGovernorCounters counters) = - mconcat [ "kind" .= String "InboundGovernorCounters" - , "idlePeers" .= idlePeersRemote counters - , "coldPeers" .= coldPeersRemote counters - , "warmPeers" .= warmPeersRemote counters - , "hotPeers" .= hotPeersRemote counters - ] -forMachineGov _dtal (TrRemoteState st) = - mconcat [ "kind" .= String "RemoteState" - , "remoteSt" .= toJSON st - ] -forMachineGov _dtal (InboundGovernor.TrUnexpectedlyFalseAssertion info) = - mconcat [ "kind" .= String "UnexpectedlyFalseAssertion" - , "remoteSt" .= String (pack . show $ info) - ] -forMachineGov _dtal (InboundGovernor.TrInboundGovernorError err) = - mconcat [ "kind" .= String "InboundGovernorError" - , "remoteSt" .= String (pack . show $ err) - ] -forMachineGov _dtal (InboundGovernor.TrMaturedConnections matured fresh) = - mconcat [ "kind" .= String "MaturedConnections" - , "matured" .= toJSON matured - , "fresh" .= toJSON fresh - ] -forMachineGov _dtal (InboundGovernor.TrInactive fresh) = - mconcat [ "kind" .= String "Inactive" - , "fresh" .= toJSON fresh - ] - -instance MetaTrace (InboundGovernor.Trace addr) where - namespaceFor TrNewConnection {} = Namespace [] ["NewConnection"] - namespaceFor TrResponderRestarted {} = Namespace [] ["ResponderRestarted"] - namespaceFor TrResponderStartFailure {} = Namespace [] ["ResponderStartFailure"] - namespaceFor TrResponderErrored {} = Namespace [] ["ResponderErrored"] - namespaceFor TrResponderStarted {} = Namespace [] ["ResponderStarted"] - namespaceFor TrResponderTerminated {} = Namespace [] ["ResponderTerminated"] - namespaceFor TrPromotedToWarmRemote {} = Namespace [] ["PromotedToWarmRemote"] - namespaceFor TrPromotedToHotRemote {} = Namespace [] ["PromotedToHotRemote"] - namespaceFor TrDemotedToColdRemote {} = Namespace [] ["DemotedToColdRemote"] - namespaceFor TrDemotedToWarmRemote {} = Namespace [] ["DemotedToWarmRemote"] - namespaceFor TrWaitIdleRemote {} = Namespace [] ["WaitIdleRemote"] - namespaceFor TrMuxCleanExit {} = Namespace [] ["MuxCleanExit"] - namespaceFor TrMuxErrored {} = Namespace [] ["MuxErrored"] - namespaceFor TrInboundGovernorCounters {} = Namespace [] ["InboundGovernorCounters"] - namespaceFor TrRemoteState {} = Namespace [] ["RemoteState"] - namespaceFor InboundGovernor.TrUnexpectedlyFalseAssertion {} = - Namespace [] ["UnexpectedlyFalseAssertion"] - namespaceFor InboundGovernor.TrInboundGovernorError {} = - Namespace [] ["InboundGovernorError"] - namespaceFor InboundGovernor.TrMaturedConnections {} = - Namespace [] ["MaturedConnections"] - namespaceFor InboundGovernor.TrInactive {} = - Namespace [] ["Inactive"] - - severityFor (Namespace _ ["NewConnection"]) _ = Just Debug - severityFor (Namespace _ ["ResponderRestarted"]) _ = Just Debug - severityFor (Namespace _ ["ResponderStartFailure"]) _ = Just Info - severityFor (Namespace _ ["ResponderErrored"]) _ = Just Info - severityFor (Namespace _ ["ResponderStarted"]) _ = Just Debug - severityFor (Namespace _ ["ResponderTerminated"]) _ = Just Debug - severityFor (Namespace _ ["PromotedToWarmRemote"]) _ = Just Info - severityFor (Namespace _ ["PromotedToHotRemote"]) _ = Just Info - severityFor (Namespace _ ["DemotedToColdRemote"]) _ = Just Info - severityFor (Namespace _ ["DemotedToWarmRemote"]) _ = Just Info - severityFor (Namespace _ ["WaitIdleRemote"]) _ = Just Debug - severityFor (Namespace _ ["MuxCleanExit"]) _ = Just Debug - severityFor (Namespace _ ["MuxErrored"]) _ = Just Info - severityFor (Namespace _ ["InboundGovernorCounters"]) _ = Just Info - severityFor (Namespace _ ["RemoteState"]) _ = Just Debug - severityFor (Namespace _ ["UnexpectedlyFalseAssertion"]) _ = Just Error - severityFor (Namespace _ ["InboundGovernorError"]) _ = Just Error - severityFor (Namespace _ ["MaturedConnections"]) _ = Just Info - severityFor (Namespace _ ["Inactive"]) _ = Just Debug - severityFor _ _ = Nothing - - documentFor (Namespace _ ["NewConnection"]) = Just "" - documentFor (Namespace _ ["ResponderRestarted"]) = Just "" - documentFor (Namespace _ ["ResponderStartFailure"]) = Just "" - documentFor (Namespace _ ["ResponderErrored"]) = Just "" - documentFor (Namespace _ ["ResponderStarted"]) = Just "" - documentFor (Namespace _ ["ResponderTerminated"]) = Just "" - documentFor (Namespace _ ["PromotedToWarmRemote"]) = Just "" - documentFor (Namespace _ ["PromotedToHotRemote"]) = Just "" - documentFor (Namespace _ ["DemotedToColdRemote"]) = Just $ mconcat - [ "All mini-protocols terminated. The boolean is true if this connection" - , " was not used by p2p-governor, and thus the connection will be terminated." - ] - documentFor (Namespace _ ["DemotedToWarmRemote"]) = Just $ mconcat - [ "All mini-protocols terminated. The boolean is true if this connection" - , " was not used by p2p-governor, and thus the connection will be terminated." - ] - documentFor (Namespace _ ["WaitIdleRemote"]) = Just "" - documentFor (Namespace _ ["MuxCleanExit"]) = Just "" - documentFor (Namespace _ ["MuxErrored"]) = Just "" - documentFor (Namespace _ ["InboundGovernorCounters"]) = Just "" - documentFor (Namespace _ ["RemoteState"]) = Just "" - documentFor (Namespace _ ["UnexpectedlyFalseAssertion"]) = Just "" - documentFor (Namespace _ ["InboundGovernorError"]) = Just "" - documentFor (Namespace _ ["MaturedConnections"]) = Just "" - documentFor (Namespace _ ["Inactive"]) = Just "" - documentFor _ = Nothing - - metricsDocFor (Namespace ons ["InboundGovernorCounters"]) - | null ons -- docu generation - = - [("localInboundGovernor.idle","") - ,("localInboundGovernor.cold","") - ,("localInboundGovernor.warm","") - ,("localInboundGovernor.hot","") - ,("inboundGovernor.Idle","") - ,("inboundGovernor.Cold","") - ,("inboundGovernor.Warm","") - ,("inboundGovernor.Hot","") - ] - | last ons == "Local" - = - [("localInboundGovernor.idle","") - ,("localInboundGovernor.cold","") - ,("localInboundGovernor.warm","") - ,("localInboundGovernor.hot","") - ] - | otherwise - = - [("inboundGovernor.Idle","") - ,("inboundGovernor.Cold","") - ,("inboundGovernor.Warm","") - ,("inboundGovernor.Hot","") - ] - metricsDocFor _ = [] - - allNamespaces = [ - Namespace [] ["NewConnection"] - , Namespace [] ["ResponderRestarted"] - , Namespace [] ["ResponderStartFailure"] - , Namespace [] ["ResponderErrored"] - , Namespace [] ["ResponderStarted"] - , Namespace [] ["ResponderTerminated"] - , Namespace [] ["PromotedToWarmRemote"] - , Namespace [] ["PromotedToHotRemote"] - , Namespace [] ["DemotedToColdRemote"] - , Namespace [] ["DemotedToWarmRemote"] - , Namespace [] ["WaitIdleRemote"] - , Namespace [] ["MuxCleanExit"] - , Namespace [] ["MuxErrored"] - , Namespace [] ["InboundGovernorCounters"] - , Namespace [] ["RemoteState"] - , Namespace [] ["UnexpectedlyFalseAssertion"] - , Namespace [] ["InboundGovernorError"] - , Namespace [] ["MaturedConnections"] - , Namespace [] ["Inactive"] - ] - --------------------------------------------------------------------------------- --- InboundGovernor Transition Tracer --------------------------------------------------------------------------------- - - -instance (Show peerAddr, ToJSON peerAddr) - => LogFormatting (InboundGovernor.RemoteTransitionTrace peerAddr) where - forMachine _dtal (InboundGovernor.TransitionTrace peerAddr tr) = - mconcat $ reverse - [ "kind" .= String "ConnectionManagerTransition" - , "address" .= toJSON peerAddr - , "from" .= toJSON (ConnectionManager.fromState tr) - , "to" .= toJSON (ConnectionManager.toState tr) - ] - forHuman = pack . show - asMetrics _ = [] - -instance MetaTrace (InboundGovernor.RemoteTransitionTrace peerAddr) where - namespaceFor InboundGovernor.TransitionTrace {} = Namespace [] ["Transition"] - - severityFor (Namespace [] ["Transition"]) _ = Just Debug - severityFor _ _ = Nothing - - documentFor (Namespace [] ["Transition"]) = Just "" - documentFor _ = Nothing - - allNamespaces = [Namespace [] ["Transition"]] - - --------------------------------------------------------------------------------- --- AcceptPolicy Tracer --------------------------------------------------------------------------------- - -instance LogFormatting NtN.AcceptConnectionsPolicyTrace where - forMachine _dtal (NtN.ServerTraceAcceptConnectionRateLimiting delay numOfConnections) = - mconcat [ "kind" .= String "ServerTraceAcceptConnectionRateLimiting" - , "delay" .= show delay - , "numberOfConnection" .= show numOfConnections - ] - forMachine _dtal (NtN.ServerTraceAcceptConnectionHardLimit softLimit) = - mconcat [ "kind" .= String "ServerTraceAcceptConnectionHardLimit" - , "softLimit" .= show softLimit - ] - forMachine _dtal (NtN.ServerTraceAcceptConnectionResume numOfConnections) = - mconcat [ "kind" .= String "ServerTraceAcceptConnectionResume" - , "numberOfConnection" .= show numOfConnections - ] - forHuman = showT - -instance MetaTrace NtN.AcceptConnectionsPolicyTrace where - namespaceFor NtN.ServerTraceAcceptConnectionRateLimiting {} = - Namespace [] ["ConnectionRateLimiting"] - namespaceFor NtN.ServerTraceAcceptConnectionHardLimit {} = - Namespace [] ["ConnectionHardLimit"] - namespaceFor NtN.ServerTraceAcceptConnectionResume {} = - Namespace [] ["ConnectionLimitResume"] - - severityFor (Namespace _ ["ConnectionRateLimiting"]) _ = Just Info - severityFor (Namespace _ ["ConnectionHardLimit"]) _ = Just Warning - severityFor (Namespace _ ["ConnectionLimitResume"]) _ = Just Info - severityFor _ _ = Nothing - - documentFor (Namespace _ ["ConnectionRateLimiting"]) = Just $ mconcat - [ "Rate limiting accepting connections," - , " delaying next accept for given time, currently serving n connections." - ] - documentFor (Namespace _ ["ConnectionHardLimit"]) = Just $ mconcat - [ "Hard rate limit reached," - , " waiting until the number of connections drops below n." - ] - documentFor (Namespace _ ["ConnectionLimitResume"]) = Just - "" - documentFor _ = Nothing - - allNamespaces = [ - Namespace [] ["ConnectionRateLimiting"] - , Namespace [] ["ConnectionHardLimit"] - , Namespace [] ["ConnectionLimitResume"] - ] - --------------------------------------------------------------------------------- --- DNSTrace Tracer --------------------------------------------------------------------------------- - -instance LogFormatting DNSTrace where - forMachine _dtal (DNSLookupResult peerKind domain Nothing results) = - mconcat [ "kind" .= String "DNSLookupResult" - , "peerKind" .= String (pack . show $ peerKind) - , "domain" .= String (pack . show $ domain) - , "results" .= results - ] - forMachine _dtal (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 - ] - forMachine _dtal (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) - ] - forMachine _dtal (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 - ] - ] - forMachine _dtal (SRVLookupError peerKind domain) = - mconcat [ "kind" .= String "SRVLookupError" - , "peerKind" .= String (pack . show $ peerKind) - , "domain" .= String (pack . show $ domain) - ] - -instance MetaTrace DNSTrace where - namespaceFor DNSLookupResult {} = - Namespace [] ["DNSLookupResult"] - namespaceFor DNSLookupError {} = - Namespace [] ["DNSLookupError"] - namespaceFor SRVLookupResult {} = - Namespace [] ["SRVLookupResult"] - namespaceFor SRVLookupError {} = - Namespace [] ["SRVLookupError"] - - severityFor _ (Just DNSLookupResult {}) = Just Info - severityFor _ (Just DNSLookupError {}) = Just Info - severityFor _ (Just SRVLookupResult{}) = Just Info - severityFor _ (Just SRVLookupError{}) = Just Info - severityFor _ Nothing = Nothing - - documentFor _ = Nothing - - allNamespaces = [ - Namespace [] ["DNSLookupResult"] - , Namespace [] ["DNSLookupError"] - , Namespace [] ["SRVLookupResult"] - , Namespace [] ["SRVLookupError"] - ] - --------------------------------------------------------------------------------- --- ChurnMode Tracer --------------------------------------------------------------------------------- - -instance LogFormatting TraceChurnMode where - forMachine _dtal (TraceChurnMode mode) = - mconcat [ "kind" .= String "ChurnMode" - , "churnMode" .= String (pack . show $ mode) - ] - -instance MetaTrace TraceChurnMode where - namespaceFor TraceChurnMode {} = - Namespace [] ["PeerSelection", "ChurnMode"] - severityFor _ (Just TraceChurnMode {}) = Just Info - severityFor _ Nothing = Nothing - - documentFor (Namespace _ ["PeerSelection", "ChurnMode"]) = Just $ mconcat - ["Affects churning strategy. For a synced node or operating in GenesisMode " - , " consensus mode, the default strategy is used. Otherwise for a syncing PraosMode" - , " node, the legacy bulk sync churning intervals are used whose durations" - , " depend on whether bootstrap peers are enabled." - ] - documentFor _ = Nothing - - allNamespaces = [ - Namespace [] ["PeerSelection", "ChurnMode"] - ] diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/Startup.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/Startup.hs index 379d7820f77..1c3c8df85bb 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/Startup.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/Startup.hs @@ -40,8 +40,8 @@ import Ouroboros.Consensus.HardFork.Combinator.Degenerate (HardForkLed import Ouroboros.Consensus.Node.NetworkProtocolVersion import Ouroboros.Consensus.Node.ProtocolInfo (ProtocolInfo (..)) import Ouroboros.Consensus.Shelley.Ledger.Ledger (shelleyLedgerGenesis) -import Ouroboros.Network.NodeToClient (LocalAddress (..)) -import Ouroboros.Network.NodeToNode (DiffusionMode (..)) +import Cardano.Network.NodeToClient (LocalAddress (..)) +import Cardano.Network.NodeToNode (DiffusionMode (..)) import Ouroboros.Network.PeerSelection.LedgerPeers.Type (AfterSlot (..), UseLedgerPeers (..)) @@ -216,31 +216,9 @@ instance ( Show (BlockNodeToNodeVersion blk) forMachine _dtal NetworkConfigUpdate = mconcat [ "kind" .= String "NetworkConfigUpdate" , "message" .= String "network configuration update" ] - forMachine _dtal (LedgerPeerSnapshotLoaded wOrigin) = + forMachine _dtal (LedgerPeerSnapshotLoaded slotNo) = mconcat [ "kind" .= String "LedgerPeerSnapshot" - , "message" .= String ("loaded input recorded " <> showT wOrigin)] - forMachine _dtal (LedgerPeerSnapshotIgnored useLedgerAfterSlot snapshotSlotNo (PeerSnapshotFile snapshotFile)) = - mconcat [ "kind" .= String "LedgerPeerSnapshot" - , "message" .= String ( - mconcat [ "Topology file misconfiguration: ignoring ledger peer snapshot recorded for " - , showT snapshotSlotNo - , " since topology file specifies to use ledger after " - , showT useLedgerAfterSlot - , ".\nPossible fix: update ledger peer snapshot at " - , showT snapshotFile - ] - )] - forMachine _dtal (LedgerPeerSnapshotError useLedgerAfterSlot snapshotSlotNo (PeerSnapshotFile snapshotFile)) = - mconcat [ "kind" .= String "LedgerPeerSnapshot" - , "message" .= String ( - mconcat [ "Topology file misconfiguration: ignoring ledger peer snapshot recorded for " - , showT snapshotSlotNo - , " since topology file specifies to use ledger peers after " - , showT useLedgerAfterSlot - , ".\nPossible fix: update ledger peer snapshot at " - , showT snapshotFile - ] - )] + , "message" .= String ("loaded input recorded " <> showT slotNo)] forMachine _dtal NetworkConfigUpdateUnsupported = mconcat [ "kind" .= String "NetworkConfigUpdate" , "message" .= String "network topology reconfiguration is not supported in non-p2p mode" ] @@ -345,10 +323,6 @@ instance MetaTrace (StartupTrace blk) where Namespace [] ["NetworkConfigUpdate"] namespaceFor (LedgerPeerSnapshotLoaded {}) = Namespace [] ["LedgerPeerSnapshot"] - namespaceFor (LedgerPeerSnapshotIgnored {}) = - Namespace [] ["LedgerPeerSnapshot", "Incompatible"] - namespaceFor (LedgerPeerSnapshotError {}) = - Namespace [] ["LedgerPeerSnapshot", "Error"] namespaceFor NetworkConfigUpdateUnsupported {} = Namespace [] ["NetworkConfigUpdateUnsupported"] namespaceFor NetworkConfigUpdateError {} = @@ -505,6 +479,7 @@ nodeToClientVersionToInt = \case NodeToClientV_20 -> 20 NodeToClientV_21 -> 21 NodeToClientV_22 -> 22 + NodeToClientV_23 -> 23 nodeToNodeVersionToInt :: NodeToNodeVersion -> Int nodeToNodeVersionToInt = \case @@ -598,26 +573,8 @@ ppStartupInfoTrace (NetworkConfig localRoots publicRoots useLedgerPeers peerSnap <> show (unPeerSnapshotFile p) ] -ppStartupInfoTrace (LedgerPeerSnapshotLoaded wOrigin) = - "Topology: Peer snapshot containing ledger peers " <> showT wOrigin <> " loaded." -ppStartupInfoTrace (LedgerPeerSnapshotIgnored useLedgerAfterSlot snapshotSlotNo (PeerSnapshotFile snapshotFile)) = - mconcat - [ "Topology file misconfiguration: ignoring ledger peer snapshot recorded for " - , showT snapshotSlotNo - , " since topology file specifies to use ledger after " - , showT useLedgerAfterSlot - , ".\nPossible fix: update ledger peer snapshot at " - , showT snapshotFile - ] -ppStartupInfoTrace (LedgerPeerSnapshotError useLedgerAfterSlot snapshotSlotNo (PeerSnapshotFile snapshotFile)) = - mconcat - [ "Topology file misconfiguration: ignoring ledger peer snapshot recorded for " - , showT snapshotSlotNo - , " since topology file specifies to use ledger after " - , showT useLedgerAfterSlot - , ".\nPossible fix: update ledger peer snapshot at " - , showT snapshotFile - ] +ppStartupInfoTrace (LedgerPeerSnapshotLoaded slotNo) = + "Topology: Peer snapshot containing ledger peers recorded at " <> showT slotNo <> " loaded." ppStartupInfoTrace NonP2PWarning = nonP2PWarningMessage diff --git a/cardano-node/src/Cardano/Node/Types.hs b/cardano-node/src/Cardano/Node/Types.hs index 321d038cdc1..3a592fbd8d7 100644 --- a/cardano-node/src/Cardano/Node/Types.hs +++ b/cardano-node/src/Cardano/Node/Types.hs @@ -16,6 +16,7 @@ module Cardano.Node.Types , GenesisFile(..) , PeerSnapshotFile (..) , CheckpointsFile(..) + , KESSource(..) , ProtocolFilepaths (..) , hasProtocolFile , GenesisHash(..) @@ -47,7 +48,7 @@ import qualified Cardano.Crypto.Hash as Crypto import Cardano.Network.ConsensusMode (ConsensusMode (..)) import Cardano.Node.Configuration.Socket (SocketConfig (..)) import Cardano.Node.Orphans () -import Ouroboros.Network.NodeToNode (DiffusionMode (..)) +import Cardano.Network.NodeToNode (DiffusionMode (..)) import Control.Exception import Data.Aeson @@ -166,11 +167,16 @@ class AdjustFilePaths a where adjustFilePaths :: (FilePath -> FilePath) -> a -> a +data KESSource + = KESKeyFilePath FilePath + | KESAgentSocketPath FilePath + deriving (Eq, Show) + data ProtocolFilepaths = ProtocolFilepaths { byronCertFile :: !(Maybe FilePath) , byronKeyFile :: !(Maybe FilePath) - , shelleyKESFile :: !(Maybe FilePath) + , shelleyKESSource :: !(Maybe KESSource) , shelleyVRFFile :: !(Maybe FilePath) , shelleyCertFile :: !(Maybe FilePath) , shelleyBulkCredsFile :: !(Maybe FilePath) @@ -183,14 +189,14 @@ hasProtocolFile :: ProtocolFilepaths -> Bool hasProtocolFile ProtocolFilepaths { byronCertFile, byronKeyFile, - shelleyKESFile, + shelleyKESSource, shelleyVRFFile, shelleyCertFile, shelleyBulkCredsFile } = isJust byronCertFile || isJust byronKeyFile - || isJust shelleyKESFile + || isJust shelleyKESSource || isJust shelleyVRFFile || isJust shelleyCertFile || isJust shelleyBulkCredsFile diff --git a/cardano-node/src/Cardano/Tracing/Config.hs b/cardano-node/src/Cardano/Tracing/Config.hs index 43b7e1cb07e..09e01488756 100644 --- a/cardano-node/src/Cardano/Tracing/Config.hs +++ b/cardano-node/src/Cardano/Tracing/Config.hs @@ -197,6 +197,8 @@ 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) @@ -280,6 +282,8 @@ data TraceSelection , traceDevotedBlockFetch :: OnOff TraceDevotedBlockFetch , traceChurnMode :: OnOff TraceChurnMode , traceDNS :: OnOff TraceDNS + , traceTxLogic :: OnOff TraceTxLogic + , traceTxCounters :: OnOff TraceTxCounters } deriving (Eq, Show) @@ -357,6 +361,8 @@ data PartialTraceSelection , pTraceChurnMode :: Last (OnOff TraceChurnMode) , pTraceDNS :: Last (OnOff TraceDNS) , pTraceKesAgent :: Last (OnOff TraceKesAgent) + , pTraceTxLogic :: Last (OnOff TraceTxLogic) + , pTraceTxCounters :: Last (OnOff TraceTxCounters) } deriving (Eq, Generic, Show) @@ -435,6 +441,8 @@ instance FromJSON PartialTraceSelection where <*> parseTracer (Proxy @TraceChurnMode) v <*> parseTracer (Proxy @TraceDNS) v <*> parseTracer (Proxy @TraceKesAgent) v + <*> parseTracer (Proxy @TraceTxLogic) v + <*> parseTracer (Proxy @TraceTxCounters) v defaultPartialTraceConfiguration :: PartialTraceSelection @@ -510,6 +518,8 @@ defaultPartialTraceConfiguration = , pTraceChurnMode = pure $ OnOff True , pTraceDNS = pure $ OnOff True , pTraceKesAgent = pure $ OnOff False + , pTraceTxLogic = pure $ OnOff False + , pTraceTxCounters = pure $ OnOff False } @@ -587,6 +597,8 @@ partialTraceSelectionToEither (Last (Just (PartialTraceDispatcher pTraceSelectio 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 @@ -657,6 +669,8 @@ partialTraceSelectionToEither (Last (Just (PartialTraceDispatcher pTraceSelectio , traceChurnMode , traceDNS , traceKesAgent = traceKesAgent + , traceTxLogic + , traceTxCounters } partialTraceSelectionToEither (Last (Just (PartialTracingOnLegacy pTraceSelection))) = do @@ -731,6 +745,8 @@ partialTraceSelectionToEither (Last (Just (PartialTracingOnLegacy pTraceSelectio 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 @@ -801,6 +817,8 @@ partialTraceSelectionToEither (Last (Just (PartialTracingOnLegacy pTraceSelectio , traceChurnMode , traceDNS , traceKesAgent = traceKesAgent + , traceTxLogic + , traceTxCounters } proxyLastToEither :: KnownSymbol name => Proxy name -> Last (OnOff name) -> Either Text (OnOff name) diff --git a/cardano-node/src/Cardano/Tracing/HasIssuer.hs b/cardano-node/src/Cardano/Tracing/HasIssuer.hs index 8b74ccdd33b..f41f64a56fe 100644 --- a/cardano-node/src/Cardano/Tracing/HasIssuer.hs +++ b/cardano-node/src/Cardano/Tracing/HasIssuer.hs @@ -69,8 +69,8 @@ instance -- We don't support a "block issuer" key role in @cardano-api@, so we'll -- just convert it to a stake pool key. toStakePoolKey - :: Shelley.VKey 'Shelley.BlockIssuer - -> Shelley.VKey 'Shelley.StakePool + :: Shelley.VKey Shelley.BlockIssuer + -> Shelley.VKey Shelley.StakePool toStakePoolKey vk = Shelley.VKey (Shelley.unVKey vk) issuer = pHeaderIssuer (shelleyHeaderRaw shelleyBlkHdr) diff --git a/cardano-node/src/Cardano/Tracing/OrphanInstances/Consensus.hs b/cardano-node/src/Cardano/Tracing/OrphanInstances/Consensus.hs index d376ef0319a..eee200131a8 100644 --- a/cardano-node/src/Cardano/Tracing/OrphanInstances/Consensus.hs +++ b/cardano-node/src/Cardano/Tracing/OrphanInstances/Consensus.hs @@ -19,11 +19,13 @@ module Cardano.Tracing.OrphanInstances.Consensus () where +import Ouroboros.Consensus.Peras.SelectView import Cardano.Node.Tracing.Tracers.ConsensusStartupException (ConsensusStartupException (..)) import Cardano.Prelude (Typeable, maximumDef) import Cardano.Slotting.Slot (fromWithOrigin) import Cardano.Tracing.OrphanInstances.Common +import Cardano.Network.OrphanInstances () import Cardano.Tracing.OrphanInstances.Network () import Cardano.Tracing.Render (renderChainHash, renderChunkNo, renderHeaderHash, renderHeaderHashForVerbosity, renderPointAsPhrase, renderPointForVerbosity, @@ -31,7 +33,7 @@ import Cardano.Tracing.Render (renderChainHash, renderChunkNo, renderH renderWithOrigin) import Ouroboros.Consensus.Block (BlockProtocol, BlockSupportsProtocol, CannotForge, ConvertRawHash (..), ForgeStateUpdateError, GenesisWindow (..), GetHeader (..), - Header, RealPoint (..), blockNo, blockPoint, blockPrevHash, getHeader, pointHash, + Header, HeaderHash, RealPoint (..), blockNo, blockPoint, blockPrevHash, getHeader, pointHash, realPointHash, realPointSlot, withOriginToMaybe) import Ouroboros.Consensus.Block.SupportsSanityCheck import Ouroboros.Consensus.Genesis.Governor (DensityBounds (..), GDDDebugInfo (..), @@ -162,9 +164,9 @@ instance HasSeverityAnnotation (ChainDB.TraceEvent blk) where ChainDB.TrySwitchToAFork {} -> Info ChainDB.StoreButDontChange {} -> Debug ChainDB.ChangingSelection {} -> Debug - ChainDB.AddedToCurrentChain events _ _ _ -> + ChainDB.AddedToCurrentChain events _ _ _ _ -> maximumDef Notice (map getSeverityAnnotation events) - ChainDB.SwitchedToAFork events _ _ _ -> + ChainDB.SwitchedToAFork events _ _ _ _ -> maximumDef Notice (map getSeverityAnnotation events) ChainDB.AddBlockValidation ev' -> case ev' of ChainDB.InvalidBlock {} -> Error @@ -175,7 +177,6 @@ instance HasSeverityAnnotation (ChainDB.TraceEvent blk) where ChainDB.PoppedReprocessLoEBlocksFromQueue -> Debug ChainDB.ChainSelectionLoEDebug _ _ -> Debug - getSeverityAnnotation (ChainDB.TraceLedgerDBEvent ev) = case ev of LedgerDB.LedgerDBSnapshotEvent ev' -> case ev' of LedgerDB.TookSnapshot {} -> Info @@ -253,6 +254,9 @@ instance HasSeverityAnnotation (ChainDB.TraceEvent blk) where getSeverityAnnotation ChainDB.TraceChainSelStarvationEvent{} = Debug + getSeverityAnnotation ChainDB.TracePerasCertDbEvent{} = Info + getSeverityAnnotation ChainDB.TraceAddPerasCertEvent{} = Info + instance HasSeverityAnnotation (LedgerEvent blk) where getSeverityAnnotation (LedgerUpdate _) = Notice getSeverityAnnotation (LedgerWarning _) = Critical @@ -361,7 +365,7 @@ instance HasTextFormatter (TraceLabelPeer peer (TraceBlockFetchServerEvent blk)) formatText _ = pack . show . toList -instance (ConvertRawHash blk, LedgerSupportsProtocol blk) +instance (ConvertRawHash blk, LedgerSupportsProtocol blk, ToJSON (HeaderHash blk)) => Transformable Text IO (TraceChainSyncClientEvent blk) where trTransformer = trStructured @@ -378,9 +382,11 @@ instance (StandardHash blk, Show peer) formatText a _ = pack $ show a -instance ( ToObject (ApplyTxErr blk), ToObject (GenTx blk), - ToJSON (GenTxId blk), LedgerSupportsMempool blk, - ConvertRawHash blk) +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 @@ -521,7 +527,9 @@ instance ( ConvertRawHash blk , InspectLedger blk , ToObject (Header blk) , ToObject (LedgerEvent blk) - , ToObject (SelectView (BlockProtocol blk))) + , ToObject (WeightedSelectView (BlockProtocol blk)) + , ToJSON (HeaderHash blk) + ) => Transformable Text IO (ChainDB.TraceEvent blk) where trTransformer = trStructuredText @@ -562,10 +570,10 @@ instance ( ConvertRawHash blk "Block fits onto some fork: " <> renderRealPointAsPhrase pt ChainDB.ChangingSelection pt -> "Changing selection to: " <> renderPointAsPhrase pt - ChainDB.AddedToCurrentChain es _ _ c -> + ChainDB.AddedToCurrentChain es _ _ c _ -> "Chain extended, new tip: " <> renderPointAsPhrase (AF.headPoint c) <> Text.concat [ "\nEvent: " <> showT e | e <- es ] - ChainDB.SwitchedToAFork es _ _ c -> + 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 @@ -786,10 +794,14 @@ instance ( ConvertRawHash blk 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@ -- @@ -925,9 +937,10 @@ instance (ToObject (LedgerUpdate blk), ToObject (LedgerWarning blk)) instance ( ConvertRawHash blk , LedgerSupportsProtocol blk + , ToJSON (HeaderHash blk) , ToObject (Header blk) , ToObject (LedgerEvent blk) - , ToObject (SelectView (BlockProtocol blk))) + , ToObject (WeightedSelectView (BlockProtocol blk))) => ToObject (ChainDB.TraceEvent blk) where toObject _verb ChainDB.TraceLastShutdownUnclean = mconcat [ "kind" .= String "TraceLastShutdownUnclean" ] @@ -967,31 +980,31 @@ instance ( ConvertRawHash blk ChainDB.ChangingSelection pt -> mconcat [ "kind" .= String "TraceAddBlockEvent.ChangingSelection" , "block" .= toObject verb pt ] - ChainDB.AddedToCurrentChain events selChangedInfo base extended -> + ChainDB.AddedToCurrentChain events selChangedInfo base extended _ -> mconcat $ [ "kind" .= String "TraceAddBlockEvent.AddedToCurrentChain" , "newtip" .= renderPointForVerbosity verb (AF.headPoint extended) , "chainLengthDelta" .= extended `chainLengthΔ` base - , "newTipSelectView" .= toObject verb (ChainDB.newTipSelectView selChangedInfo) + , "newSuffixSelectView" .= toObject verb (ChainDB.newSuffixSelectView selChangedInfo) ] - ++ [ "oldTipSelectView" .= toObject verb oldTipSelectView - | Just oldTipSelectView <- [ChainDB.oldTipSelectView 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 -> + 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) - , "newTipSelectView" .= toObject verb (ChainDB.newTipSelectView selChangedInfo) + , "newSuffixSelectView" .= toObject verb (ChainDB.newSuffixSelectView selChangedInfo) ] - ++ [ "oldTipSelectView" .= toObject verb oldTipSelectView - | Just oldTipSelectView <- [ChainDB.oldTipSelectView selChangedInfo] + ++ [ "oldSuffixSelectView" .= toObject verb oldSuffixSelectView + | Just oldSuffixSelectView <- [ChainDB.oldSuffixSelectView selChangedInfo] ] ++ [ "headers" .= toJSON (toObject verb `map` addedHdrsNewChain old new) | verb == MaximalVerbosity ] @@ -1066,6 +1079,15 @@ instance ( ConvertRawHash blk 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 @@ -1365,7 +1387,7 @@ tipToObject = \case , "blockNo" .= blockno ] -instance (ConvertRawHash blk, LedgerSupportsProtocol blk) +instance (ConvertRawHash blk, LedgerSupportsProtocol blk, ToJSON (HeaderHash blk)) => ToObject (TraceChainSyncClientEvent blk) where toObject verb ev = case ev of TraceDownloadedHeader h -> @@ -1424,8 +1446,9 @@ instance (ConvertRawHash blk, LedgerSupportsProtocol blk) , "n" .= natToInt n ] -instance ( LedgerSupportsProtocol blk, - ConvertRawHash blk +instance ( LedgerSupportsProtocol blk + , ConvertRawHash blk + , ToJSON (HeaderHash blk) ) => ToObject (ChainSync.Client.Instruction blk) where toObject verb = \case ChainSync.Client.RunNormally -> @@ -1437,8 +1460,9 @@ instance ( LedgerSupportsProtocol blk, , "payload" .= toObject verb info ] -instance ( LedgerSupportsProtocol blk, - ConvertRawHash blk +instance ( LedgerSupportsProtocol blk + , ConvertRawHash blk + , ToJSON (HeaderHash blk) ) => ToObject (ChainSync.Client.JumpInstruction blk) where toObject verb = \case ChainSync.Client.JumpTo info -> @@ -1448,8 +1472,9 @@ instance ( LedgerSupportsProtocol blk, mconcat [ "kind" .= String "JumpToGoodPoint" , "info" .= toObject verb info ] -instance ( LedgerSupportsProtocol blk, - ConvertRawHash blk +instance ( LedgerSupportsProtocol blk + , ConvertRawHash blk + , ToJSON (HeaderHash blk) ) => ToObject (ChainSync.Client.JumpInfo blk) where toObject verb info = mconcat [ "kind" .= String "JumpInfo" @@ -1461,10 +1486,10 @@ instance ( LedgerSupportsProtocol blk, instance HasPrivacyAnnotation (ChainSync.Client.TraceEventCsj peer blk) where instance HasSeverityAnnotation (ChainSync.Client.TraceEventCsj peer blk) where getSeverityAnnotation _ = Debug -instance (ToObject peer, ConvertRawHash blk) +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) +instance (ToObject peer, ConvertRawHash blk, ToJSON (HeaderHash blk)) => ToObject (ChainSync.Client.TraceEventCsj peer blk) where toObject verb = \case ChainSync.Client.BecomingObjector prevObjector -> @@ -1534,9 +1559,10 @@ instance ConvertRawHash blk ] <> [ "risingEdge" .= True | RisingEdge <- [enclosing] ] -instance ( ToObject (ApplyTxErr blk), ToObject (GenTx blk), - ToJSON (GenTxId blk), LedgerSupportsMempool blk, - ConvertRawHash blk +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 @@ -1803,10 +1829,10 @@ instance ToObject selection => ToObject (TraceGsmEvent selection) where instance HasPrivacyAnnotation (TraceGDDEvent peer blk) where instance HasSeverityAnnotation (TraceGDDEvent peer blk) where getSeverityAnnotation _ = Debug -instance (Typeable blk, ToObject peer, ConvertRawHash blk, GetHeader blk) => Transformable Text IO (TraceGDDEvent peer blk) where +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) => ToObject (TraceGDDEvent peer blk) where +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) @@ -1852,7 +1878,9 @@ instance (Typeable blk, ToObject peer, ConvertRawHash blk, GetHeader blk) => ToO , "peer" .= toJSON (map (toObject verb) $ toList peer) ] -instance (Typeable blk, ConvertRawHash blk, GetHeader blk) => ToObject (DensityBounds blk) where +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 diff --git a/cardano-node/src/Cardano/Tracing/OrphanInstances/HardFork.hs b/cardano-node/src/Cardano/Tracing/OrphanInstances/HardFork.hs index 8c75604c5cb..1736b04f68c 100644 --- a/cardano-node/src/Cardano/Tracing/OrphanInstances/HardFork.hs +++ b/cardano-node/src/Cardano/Tracing/OrphanInstances/HardFork.hs @@ -22,7 +22,7 @@ import Cardano.Slotting.Slot (EpochSize (..)) import Cardano.Tracing.OrphanInstances.Common import Cardano.Tracing.OrphanInstances.Consensus () import Ouroboros.Consensus.Block (BlockProtocol, CannotForge, ForgeStateInfo, - ForgeStateUpdateError) + ForgeStateUpdateError, PerasWeight (..)) import Ouroboros.Consensus.BlockchainTime (getSlotLength) import Ouroboros.Consensus.Cardano.Condense () import Ouroboros.Consensus.HardFork.Combinator @@ -43,7 +43,7 @@ import Ouroboros.Consensus.Ledger.Inspect (LedgerUpdate, LedgerWarning import Ouroboros.Consensus.Ledger.SupportsMempool (ApplyTxErr) import Ouroboros.Consensus.Node.NetworkProtocolVersion (BlockNodeToClientVersion, BlockNodeToNodeVersion) -import Ouroboros.Consensus.Protocol.Abstract (ValidationErr, SelectView (svTiebreakerView, svBlockNo), ConsensusProtocol (TiebreakerView)) +import Ouroboros.Consensus.Protocol.Abstract (ValidationErr, ConsensusProtocol (TiebreakerView)) import Ouroboros.Consensus.TypeFamilyWrappers import Ouroboros.Consensus.Util.Condense (Condense (..)) @@ -53,6 +53,7 @@ import qualified Data.ByteString.Short as SBS import Data.Proxy (Proxy (..)) import Data.SOP (All, Compose, K (..)) import Data.SOP.Strict +import Ouroboros.Consensus.Peras.SelectView -- @@ -434,10 +435,11 @@ instance (ToJSON (BlockNodeToNodeVersion blk)) => ToJSON (WrapNodeToNodeVersion instance All (ToObject `Compose` WrapTiebreakerView) xs => ToObject (HardForkTiebreakerView xs) where toObject verb = toObject verb . getHardForkTiebreakerView -instance ToObject (TiebreakerView protocol) => ToObject (SelectView protocol) where +instance ToObject (TiebreakerView protocol) => ToObject (WeightedSelectView protocol) where toObject verb sv = mconcat - [ "blockNo" .= svBlockNo sv - , toObject verb (svTiebreakerView sv) + [ "blockNo" .= wsvBlockNo sv + , "weightBoost" .= unPerasWeight (wsvWeightBoost sv) + , toObject verb (wsvTiebreaker sv) ] instance All (ToObject `Compose` WrapTiebreakerView) xs => ToObject (OneEraTiebreakerView xs) where diff --git a/cardano-node/src/Cardano/Tracing/OrphanInstances/Network.hs b/cardano-node/src/Cardano/Tracing/OrphanInstances/Network.hs index f77dc4092aa..b19eff76a0c 100644 --- a/cardano-node/src/Cardano/Tracing/OrphanInstances/Network.hs +++ b/cardano-node/src/Cardano/Tracing/OrphanInstances/Network.hs @@ -21,12 +21,14 @@ module Cardano.Tracing.OrphanInstances.Network , FetchDecisionToJSON (..) ) where + +import qualified Cardano.Network.PeerSelection as Cardano +import qualified Cardano.Network.PeerSelection.ExtraRootPeers as Cardano +import Cardano.Network.PeerSelection.PublicRootPeers (PublicRootPeers(..)) import Cardano.Network.Diffusion (CardanoDebugPeerSelection, CardanoPeerSelectionCounters, - CardanoTraceLocalRootPeers, CardanoTracePeerSelection, TraceChurnMode (..)) + CardanoTraceLocalRootPeers, TraceChurnMode (..)) import Cardano.Network.OrphanInstances () import qualified Cardano.Network.PeerSelection.ExtraRootPeers as Cardano.PublicRootPeers -import qualified Cardano.Network.PeerSelection.Governor.PeerSelectionState as Cardano -import qualified Cardano.Network.PeerSelection.Governor.Types as Cardano import Cardano.Node.Queries (ConvertTxId) import Cardano.Tracing.OrphanInstances.Common import Cardano.Tracing.Render @@ -55,11 +57,10 @@ 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.NodeToClient (NodeToClientVersion (..)) -import qualified Ouroboros.Network.NodeToClient as NtC -import Ouroboros.Network.NodeToNode (NodeToNodeVersion (..), RemoteAddress, +import qualified Cardano.Network.NodeToClient as NtC +import Cardano.Network.NodeToNode (RemoteAddress, TraceSendRecv (..)) -import qualified Ouroboros.Network.NodeToNode as NtN +import qualified Cardano.Network.NodeToNode as NtN import Ouroboros.Network.OrphanInstances () import Ouroboros.Network.PeerSelection.Governor (DebugPeerSelection (..), DebugPeerSelectionState (..), PeerSelectionCounters, PeerSelectionState (..), @@ -89,13 +90,14 @@ 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 (ProcessedTxCount (..), - TraceTxSubmissionInbound (..)) +import Ouroboros.Network.TxSubmission.Inbound.V2 (ProcessedTxCount (..), + TraceTxSubmissionInbound (..), TraceTxLogic(..), TxSubmissionCounters(..), + TxDecision(..), TxsToMempool(..)) import Ouroboros.Network.TxSubmission.Outbound (TraceTxSubmissionOutbound (..)) import Control.Exception (Exception (..)) import Control.Monad.Class.MonadTime.SI (DiffTime, Time (..)) -import Data.Aeson (Value (..)) +import Data.Aeson (Value (..), ToJSONKey(..)) import qualified Data.Aeson as Aeson import Data.Aeson.Types (listValue) import Data.Bifunctor (Bifunctor (first)) @@ -124,16 +126,6 @@ instance HasSeverityAnnotation (Diffusion.DiffusionTracer ntnAddr ntcAddr) where getSeverityAnnotation Diffusion.DiffusionErrored {} = Critical getSeverityAnnotation _ = Info -instance HasPrivacyAnnotation (NtC.HandshakeTr LocalAddress NodeToClientVersion) -instance HasSeverityAnnotation (NtC.HandshakeTr LocalAddress NodeToClientVersion) where - getSeverityAnnotation _ = Info - - -instance HasPrivacyAnnotation (NtN.HandshakeTr RemoteAddress NodeToNodeVersion) -instance HasSeverityAnnotation (NtN.HandshakeTr RemoteAddress NodeToNodeVersion) where - getSeverityAnnotation _ = Info - - instance HasPrivacyAnnotation NtN.AcceptConnectionsPolicyTrace instance HasSeverityAnnotation NtN.AcceptConnectionsPolicyTrace where getSeverityAnnotation NtN.ServerTraceAcceptConnectionRateLimiting {} = Info @@ -205,6 +197,10 @@ instance HasSeverityAnnotation (TraceTxSubmissionInbound txid tx) where 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) @@ -252,6 +248,8 @@ instance HasSeverityAnnotation (Mux.WithBearer peer Mux.Trace) where 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 @@ -278,6 +276,8 @@ instance HasSeverityAnnotation (Mux.WithBearer peer Mux.BearerTrace) where 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 @@ -287,8 +287,8 @@ instance HasPrivacyAnnotation TracePublicRootPeers instance HasSeverityAnnotation TracePublicRootPeers where getSeverityAnnotation _ = Info -instance HasPrivacyAnnotation CardanoTracePeerSelection -instance HasSeverityAnnotation CardanoTracePeerSelection where +instance HasPrivacyAnnotation (TracePeerSelection extraDebugState extraFlags extraPeers ntnAddr) where +instance HasSeverityAnnotation (TracePeerSelection extraDebugState extraFlags extraPeers ntnAddr) where getSeverityAnnotation ev = case ev of TraceLocalRootPeersChanged {} -> Notice @@ -321,7 +321,6 @@ instance HasSeverityAnnotation CardanoTracePeerSelection where TraceDemoteLocalAsynchronous {} -> Warning TraceGovernorWakeup {} -> Info TraceChurnWait {} -> Info - -- TraceChurnMode {} -> Info TraceForgetBigLedgerPeers {} -> Info @@ -348,10 +347,8 @@ instance HasSeverityAnnotation CardanoTracePeerSelection where TraceDemoteBigLedgerPeersAsynchronous {} -> Warning - TraceUseBootstrapPeersChanged {} -> Info TraceBootstrapPeersFlagChangedWhilstInSensitiveState -> Info - TraceLedgerStateJudgementChanged {} -> Notice TraceOnlyBootstrapPeers {} -> Notice TraceOutboundGovernorCriticalFailure {} -> Error @@ -364,6 +361,8 @@ instance HasSeverityAnnotation CardanoTracePeerSelection where TraceVerifyPeerSnapshot True -> Info TraceVerifyPeerSnapshot False -> Error + ExtraTrace {} -> Info + instance HasPrivacyAnnotation CardanoDebugPeerSelection instance HasSeverityAnnotation CardanoDebugPeerSelection where getSeverityAnnotation _ = Debug @@ -416,6 +415,7 @@ instance HasSeverityAnnotation (ConnMgr.Trace addr (ConnectionHandlerTrace versi TrConnectionManagerCounters {} -> Info TrState {} -> Info ConnMgr.TrUnexpectedlyFalseAssertion {} -> Error + TrInboundConnectionNotFound {} -> Info instance HasPrivacyAnnotation (ConnMgr.AbstractTransitionTrace addr) instance HasSeverityAnnotation (ConnMgr.AbstractTransitionTrace addr) where @@ -477,8 +477,7 @@ instance Transformable Text IO NtN.AcceptConnectionsPolicyTrace where instance HasTextFormatter NtN.AcceptConnectionsPolicyTrace where formatText a _ = pack (show a) - -instance (StandardHash header, Show peer, ToJSON peer, ConvertRawHash header) +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) @@ -492,7 +491,7 @@ 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) +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) @@ -510,8 +509,8 @@ instance (ToObject peer, ToObject (AnyMessage (TraceTxSubmissionInbound (GenTxId => Transformable Text IO (TraceLabelPeer peer (NtN.TraceSendRecv (TraceTxSubmissionInbound (GenTxId blk) (GenTx blk)))) where trTransformer = trStructured -instance ToObject peer - => Transformable Text IO (TraceLabelPeer peer (TraceTxSubmissionInbound (GenTxId blk) (GenTx blk))) where +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) @@ -557,9 +556,9 @@ instance (ToObject peer, Show (TxId (GenTx blk)), Show (GenTx blk)) => Transformable Text IO (TraceLabelPeer peer (TraceTxSubmissionOutbound (GenTxId blk) (GenTx blk))) where trTransformer = trStructured -instance Transformable Text IO (TraceTxSubmissionInbound txid tx) where +instance (Show tx, Show txid, ToJSON txid, ToObject (TxDecision txid tx)) => Transformable Text IO (TraceTxSubmissionInbound txid tx) where trTransformer = trStructuredText -instance HasTextFormatter (TraceTxSubmissionInbound txid tx) where +instance (Show tx, Show txid) => HasTextFormatter (TraceTxSubmissionInbound txid tx) where formatText a _ = pack (show a) @@ -609,9 +608,21 @@ instance Transformable Text IO TracePublicRootPeers where instance HasTextFormatter TracePublicRootPeers where formatText a _ = pack (show a) -instance Transformable Text IO CardanoTracePeerSelection where +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 HasTextFormatter CardanoTracePeerSelection where +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 @@ -672,6 +683,26 @@ 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@ -- @@ -1056,20 +1087,6 @@ instance ToObject NtN.AcceptConnectionsPolicyTrace where , "numberOfConnection" .= show numOfConnections ] - -instance ConvertRawHash header - => ToJSON (Point header) where - toJSON GenesisPoint = String "GenesisPoint" - toJSON (BlockPoint (SlotNo slotNo) hash) = - -- it is unlikely that there will be two short hashes in the same slot - String $ renderHeaderHashForVerbosity - (Proxy @header) - MinimalVerbosity - hash - <> "@" - <> pack (show slotNo) - - newtype Verbose a = Verbose a instance ConvertRawHash header @@ -1085,7 +1102,7 @@ instance ConvertRawHash header <> pack (show slotNo) -instance ConvertRawHash blk +instance (ConvertRawHash blk, ToJSON (HeaderHash blk)) => ToObject (Point blk) where toObject _verb GenesisPoint = mconcat [ "point" .= String "GenesisPoint" ] @@ -1114,7 +1131,7 @@ instance (ConvertRawHash blk) => ToObject (AF.Anchor blk) where , "blockNo" .= toJSON (unBlockNo bno) ] -instance (ConvertRawHash blk, HasHeader blk) => ToObject (AF.AnchoredFragment blk) where +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) @@ -1165,7 +1182,7 @@ instance (HasHeader header, ConvertRawHash header) , "outstanding" .= outstanding ] -instance (ToJSON peer, ConvertRawHash header) +instance (ToJSON peer, ConvertRawHash header, ToJSON (HeaderHash header)) => ToObject [TraceLabelPeer peer (FetchDecision [Point header])] where toObject MinimalVerbosity _ = mempty toObject _ [] = mempty @@ -1196,7 +1213,7 @@ instance ToJSON point toJSON (FetchDecisionToJSON (Right points)) = toJSON points -instance (ToJSON peer, ConvertRawHash header) +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 @@ -1220,11 +1237,11 @@ instance ToObject (Stateful.AnyMessage ps f) [ "kind" .= String "Recv" , "msg" .= toObject verb m ] -instance ToObject (TraceTxSubmissionInbound txid tx) where - toObject _verb (TraceTxSubmissionCollected count) = +instance (ToJSON txid, ToObject (TxDecision txid tx)) => ToObject (TraceTxSubmissionInbound txid tx) where + toObject _verb (TraceTxSubmissionCollected txids) = mconcat [ "kind" .= String "TxSubmissionCollected" - , "count" .= toJSON count + , "count" .= toJSON (length txids) ] toObject _verb (TraceTxSubmissionProcessed processed) = mconcat @@ -1246,6 +1263,26 @@ instance ToObject (TraceTxSubmissionInbound txid tx) where [ "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) @@ -1432,17 +1469,25 @@ instance ToObject TracePublicRootPeers where , "domainAddresses" .= Aeson.toJSONList domains ] - -instance ToObject CardanoTracePeerSelection where +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 pst') = + toObject _verb (TraceTargetsChanged pst) = mconcat [ "kind" .= String "TargetsChanged" - , "previous" .= toJSON pst - , "current" .= toJSON pst' + , "current" .= toJSON pst ] toObject _verb (TracePublicRootsRequest tRootPeers nRootPeers) = mconcat [ "kind" .= String "PublicRootsRequest" @@ -1517,13 +1562,14 @@ instance ToObject CardanoTracePeerSelection where , "targetLocalEstablished" .= tLocalEst , "selectedPeers" .= Aeson.toJSONList (toList sp) ] - toObject _verb (TracePromoteColdFailed tEst aEst p d err) = + 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" @@ -1537,13 +1583,14 @@ instance ToObject CardanoTracePeerSelection where , "actualEstablished" .= actualKnown , "selectedPeers" .= Aeson.toJSONList (toList sp) ] - toObject _verb (TracePromoteColdBigLedgerPeerFailed tEst aEst p d err) = + 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" @@ -1706,9 +1753,6 @@ instance ToObject CardanoTracePeerSelection where mconcat [ "kind" .= String "ChurnWait" , "diffTime" .= toJSON dt ] - -- toObject _verb (TraceChurnMode c) = - -- mconcat [ "kind" .= String "ChurnMode" - -- , "event" .= show c ] toObject _verb (TracePickInboundPeers targetNumberOfKnownPeers numberOfKnownPeers selected available) = mconcat [ "kind" .= String "PickInboundPeers" , "targetKnown" .= targetNumberOfKnownPeers @@ -1716,14 +1760,8 @@ instance ToObject CardanoTracePeerSelection where , "selected" .= selected , "available" .= available ] - toObject _verb (TraceLedgerStateJudgementChanged new) = - mconcat [ "kind" .= String "LedgerStateJudgementChanged" - , "new" .= show new ] toObject _verb TraceOnlyBootstrapPeers = mconcat [ "kind" .= String "OnlyBootstrapPeers" ] - toObject _verb (TraceUseBootstrapPeersChanged ubp) = - mconcat [ "kind" .= String "UseBootstrapPeersChanged" - , "bootstrapPeers" .= show ubp ] toObject _verb TraceBootstrapPeersFlagChangedWhilstInSensitiveState = mconcat [ "kind" .= String "BootstrapPeersFlagChangedWhilstInSensitiveState" ] @@ -1771,6 +1809,13 @@ instance ToObject CardanoTracePeerSelection where , "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 @@ -1801,8 +1846,6 @@ instance ToObject CardanoDebugPeerSelection where , "wakeupAfter" .= String (pack $ show wakeupAfter) , "targets" .= peerSelectionTargetsToObject targets , "counters" .= toObject verb (peerSelectionStateToCounters - Cardano.PublicRootPeers.toSet - Cardano.cardanoPeerSelectionStatetoCounters st) ] @@ -2068,6 +2111,11 @@ instance (Show addr, Show versionNumber, Show agreedOptions, ToObject addr, [ "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 @@ -2118,9 +2166,6 @@ instance ToObject NtN.RemoteAddress where toObject _verb (SockAddrUnix path) = mconcat [ "path" .= show path ] -instance ToJSON Time where - toJSON = String . pack . show - instance ToObject NtN.RemoteConnectionId where toObject verb (NtN.ConnectionId l r) = mconcat [ "local" .= toObject verb l @@ -2294,3 +2339,32 @@ instance ToObject DNSTrace where , "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 index d8645b49170..ca76caaa55e 100644 --- a/cardano-node/src/Cardano/Tracing/OrphanInstances/Shelley.hs +++ b/cardano-node/src/Cardano/Tracing/OrphanInstances/Shelley.hs @@ -38,13 +38,14 @@ 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.Dijkstra.Rules as Dijkstra import qualified Cardano.Ledger.Core as Core import qualified Cardano.Ledger.Core as Ledger import qualified Cardano.Ledger.Hashes as Hashes import Cardano.Ledger.Shelley.API import Cardano.Ledger.Shelley.Rules import Cardano.Node.Tracing.Render (renderMissingRedeemers, renderScriptHash, - renderScriptIntegrityHash) + renderScriptIntegrityHash, renderIncompleteWithdrawals) import Cardano.Node.Tracing.Tracers.KESInfo () import qualified Cardano.Protocol.Crypto as Core import Cardano.Protocol.TPraos.API (ChainTransitionError (ChainTransitionError)) @@ -73,15 +74,18 @@ import Ouroboros.Consensus.Util.Condense (condense) import Ouroboros.Network.Block (SlotNo (..), blockHash, blockNo, blockSlot) import Ouroboros.Network.Point (WithOrigin, withOriginToMaybe) +import qualified Data.Aeson.Types as Aeson import Data.Aeson (Value (..)) -import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Key as Aeson (fromText) import qualified Data.ByteString.Base16 as B16 import qualified Data.List.NonEmpty as NonEmpty import Data.Set (Set) import qualified Data.Set as Set +import qualified Data.Map as Map import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text +import qualified Data.Set.NonEmpty as NonEmptySet {- HLINT ignore "Use :" -} @@ -109,9 +113,8 @@ instance ShelleyCompatible protocol era => ToObject (Header (ShelleyBlock protoc instance ( ToObject (PredicateFailure (Core.EraRule "LEDGER" ledgerera)) + , ToJSON (ApplyTxError ledgerera) -- provided by cardano-api ) => ToObject (ApplyTxError ledgerera) where - toObject verb (ApplyTxError predicateFailures) = - mconcat $ NonEmpty.toList $ fmap (toObject verb) predicateFailures instance Core.Crypto crypto => ToObject (TPraosCannotForge crypto) where toObject _verb (TPraosCannotForgeKeyNotUsableYet wallClockPeriod keyStartPeriod) = @@ -214,7 +217,7 @@ instance ToObject (Conway.ConwayDelegPredFailure era) where , "amount" .= String (textShow credential) , "error" .= String "Stake key not registered" ] - Conway.StakeKeyHasNonZeroRewardAccountBalanceDELEG coin -> + Conway.StakeKeyHasNonZeroAccountBalanceDELEG coin -> [ "kind" .= String "StakeKeyHasNonZeroAccountBalanceDELEG" , "amount" .= coin , "error" .= String "Stake key has non-zero account balance" @@ -237,13 +240,13 @@ instance ToObject (Conway.ConwayDelegPredFailure era) where , "error" .= String "Refund mismatch" ] -instance ToObject (Set (Credential 'Staking)) where +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 +instance ToObject (NonEmpty.NonEmpty (KeyHash Staking)) where toObject _verb keyHashes = mconcat [ "kind" .= String "StakeKeyHashes" , "stakeKeyHashes" .= toJSON keyHashes @@ -320,6 +323,15 @@ instance ) => 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)) @@ -327,6 +339,11 @@ instance ) => 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)) @@ -334,6 +351,14 @@ instance , 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 @@ -407,11 +432,6 @@ instance Ledger.EraPParams era => ToObject (Conway.ConwayGovPredFailure era) whe , "protVer" .= mismatchSupplied , "prevProtVer" .= mismatchExpected ] - toObject _ (Conway.InvalidPolicyHash actualPolicyHash expectedPolicyHash) = - mconcat [ "kind" .= String "InvalidPolicyHash" - , "actualPolicyHash" .= actualPolicyHash - , "expectedPolicyHash" .= expectedPolicyHash - ] toObject _ (Conway.DisallowedProposalDuringBootstrap proposal) = mconcat [ "kind" .= String "DisallowedProposalDuringBootstrap" , "proposal" .= proposal @@ -440,7 +460,11 @@ instance Ledger.EraPParams era => ToObject (Conway.ConwayGovPredFailure era) whe 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)) @@ -450,6 +474,37 @@ instance 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 @@ -469,7 +524,7 @@ instance toObject _ (MissingRequiredDatums required received) = mconcat [ "kind" .= String "MissingRequiredDatums" , "required" .= map (Crypto.hashToTextAsHex . Hashes.extractHash) - (Set.toList required) + (NonEmptySet.toList required) , "received" .= map (Crypto.hashToTextAsHex . Hashes.extractHash) (Set.toList received) ] @@ -480,11 +535,11 @@ instance ] toObject _ (UnspendableUTxONoDatumHash txins) = mconcat [ "kind" .= String "MissingRequiredSigners" - , "txins" .= Set.toList txins + , "txins" .= NonEmptySet.toList txins ] toObject _ (NotAllowedSupplementalDatums disallowed acceptable) = mconcat [ "kind" .= String "NotAllowedSupplementalDatums" - , "disallowed" .= Set.toList disallowed + , "disallowed" .= NonEmptySet.toList disallowed , "acceptable" .= Set.toList acceptable ] toObject _ (ExtraRedeemers rdmrs) = @@ -493,7 +548,7 @@ instance (\alonzoOnwards -> mconcat [ "kind" .= String "ExtraRedeemers" - , "rdmrs" .= map (Api.toScriptIndex alonzoOnwards) rdmrs + , "rdmrs" .= map (Api.toScriptIndex alonzoOnwards) (NonEmpty.toList rdmrs) ] ) (Api.shelleyBasedEra :: Api.ShelleyBasedEra era) @@ -509,11 +564,11 @@ instance ) => ToObject (ShelleyUtxowPredFailure ledgerera) where toObject _verb (ExtraneousScriptWitnessesUTXOW extraneousScripts) = mconcat [ "kind" .= String "ExtraneousScriptWitnessesUTXOW" - , "extraneousScripts" .= Set.map renderScriptHash extraneousScripts + , "extraneousScripts" .= map renderScriptHash (NonEmptySet.toList extraneousScripts) ] toObject _verb (InvalidWitnessesUTXOW wits') = mconcat [ "kind" .= String "InvalidWitnessesUTXOW" - , "invalidWitnesses" .= map textShow wits' + , "invalidWitnesses" .= map textShow (NonEmpty.toList wits') ] toObject _verb (MissingVKeyWitnessesUTXOW wits') = mconcat [ "kind" .= String "MissingVKeyWitnessesUTXOW" @@ -560,7 +615,7 @@ instance toObject _verb (BadInputsUTxO badInputs) = mconcat [ "kind" .= String "BadInputsUTxO" , "badInputs" .= badInputs - , "error" .= renderBadInputsUTxOErr badInputs + , "error" .= renderBadInputsUTxOErr (NonEmptySet.toSet badInputs) ] toObject _verb (ExpiredUTxO Mismatch {mismatchSupplied, mismatchExpected}) = mconcat [ "kind" .= String "ExpiredUTxO" @@ -622,7 +677,7 @@ instance toObject _verb (Allegra.BadInputsUTxO badInputs) = mconcat [ "kind" .= String "BadInputsUTxO" , "badInputs" .= badInputs - , "error" .= renderBadInputsUTxOErr badInputs + , "error" .= renderBadInputsUTxOErr (NonEmptySet.toSet badInputs) ] toObject _verb (Allegra.OutsideValidityIntervalUTxO validityInterval slot) = mconcat [ "kind" .= String "ExpiredUTxO" @@ -706,14 +761,6 @@ instance Ledger.Era era => ToObject (ShelleyPpupPredFailure era) where instance ( ToObject (PredicateFailure (Core.EraRule "DELPL" ledgerera)) ) => ToObject (ShelleyDelegsPredFailure ledgerera) where - toObject _verb (DelegateeNotRegisteredDELEG targetPool) = - mconcat [ "kind" .= String "DelegateeNotRegisteredDELEG" - , "targetPool" .= targetPool - ] - toObject _verb (WithdrawalsNotInRewardsDELEGS incorrectWithdrawals) = - mconcat [ "kind" .= String "WithdrawalsNotInRewardsCERTS" - , "incorrectWithdrawals" .= unWithdrawals incorrectWithdrawals - ] toObject verb (DelplFailure f) = toObject verb f @@ -798,6 +845,10 @@ instance Ledger.Era era => ToObject (ShelleyDelegPredFailure era) where TreasuryMIR -> "Treasury") , "amount" .= coin ] + toObject _verb (DelegateeNotRegisteredDELEG keyHash) = + mconcat [ "kind" .= String "DelegateeNotRegisteredDELEG" + , "unregisteredKeyHash" .= keyHash + ] instance ToObject (ShelleyPoolPredFailure era) where toObject _verb (StakePoolNotRegisteredOnKeyPOOL (KeyHash unregStakePool)) = @@ -1029,7 +1080,7 @@ instance toObject _verb (Alonzo.BadInputsUTxO badInputs) = mconcat [ "kind" .= String "BadInputsUTxO" , "badInputs" .= badInputs - , "error" .= renderBadInputsUTxOErr badInputs + , "error" .= renderBadInputsUTxOErr (NonEmptySet.toSet badInputs) ] toObject _verb (Alonzo.OutsideValidityIntervalUTxO validtyInterval slot) = mconcat [ "kind" .= String "ExpiredUTxO" @@ -1316,6 +1367,7 @@ instance ToJSON ShelleyNodeToClientVersion where toJSON ShelleyNodeToClientVersion12 = String "ShelleyNodeToClientVersion12" toJSON ShelleyNodeToClientVersion13 = String "ShelleyNodeToClientVersion13" toJSON ShelleyNodeToClientVersion14 = String "ShelleyNodeToClientVersion14" + toJSON ShelleyNodeToClientVersion15 = String "ShelleyNodeToClientVersion15" -------------------------------------------------------------------------------- -- Conway related @@ -1360,7 +1412,7 @@ instance Conway.BadInputsUTxO badInputs -> mconcat [ "kind" .= String "BadInputsUTxO" , "badInputs" .= badInputs - , "error" .= renderBadInputsUTxOErr badInputs + , "error" .= renderBadInputsUTxOErr (NonEmptySet.toSet badInputs) ] Conway.OutsideValidityIntervalUTxO validityInterval slot -> mconcat [ "kind" .= String "ExpiredUTxO" @@ -1476,7 +1528,7 @@ instance Conway.UtxoFailure utxoPredFail -> toObject v utxoPredFail Conway.InvalidWitnessesUTXOW ws -> mconcat [ "kind" .= String "InvalidWitnessesUTXOW" - , "invalidWitnesses" .= map textShow ws + , "invalidWitnesses" .= map textShow (NonEmpty.toList ws) ] Conway.MissingVKeyWitnessesUTXOW ws -> mconcat [ "kind" .= String "MissingVKeyWitnessesUTXOW" @@ -1508,7 +1560,7 @@ instance ] Conway.ExtraneousScriptWitnessesUTXOW scripts -> mconcat [ "kind" .= String "InvalidWitnessesUTXOW" - , "extraneousScripts" .= Set.map renderScriptHash scripts + , "extraneousScripts" .= Set.map renderScriptHash (NonEmptySet.toSet scripts) ] Conway.MissingRedeemers scripts -> mconcat [ "kind" .= String "MissingRedeemers" @@ -1517,13 +1569,13 @@ instance Conway.MissingRequiredDatums required received -> mconcat [ "kind" .= String "MissingRequiredDatums" , "required" .= map (Crypto.hashToTextAsHex . Hashes.extractHash) - (Set.toList required) + (NonEmptySet.toList required) , "received" .= map (Crypto.hashToTextAsHex . Hashes.extractHash) (Set.toList received) ] Conway.NotAllowedSupplementalDatums disallowed acceptable -> mconcat [ "kind" .= String "NotAllowedSupplementalDatums" - , "disallowed" .= Set.toList disallowed + , "disallowed" .= NonEmptySet.toList disallowed , "acceptable" .= Set.toList acceptable ] Conway.PPViewHashesDontMatch Mismatch {mismatchSupplied, mismatchExpected} -> @@ -1533,7 +1585,7 @@ instance ] Conway.UnspendableUTxONoDatumHash ins -> mconcat [ "kind" .= String "MissingRequiredSigners" - , "txins" .= Set.toList ins + , "txins" .= NonEmptySet.toList ins ] Conway.ExtraRedeemers rs -> Api.caseShelleyToMaryOrAlonzoEraOnwards @@ -1541,7 +1593,7 @@ instance (\alonzoOnwards -> mconcat [ "kind" .= String "ExtraRedeemers" - , "rdmrs" .= map (Api.toScriptIndex alonzoOnwards) rs + , "rdmrs" .= map (Api.toScriptIndex alonzoOnwards) (NonEmpty.toList rs) ] ) (Api.shelleyBasedEra :: Api.ShelleyBasedEra era) diff --git a/cardano-node/src/Cardano/Tracing/Tracers.hs b/cardano-node/src/Cardano/Tracing/Tracers.hs index 869a3015eed..3c2259aa9c1 100644 --- a/cardano-node/src/Cardano/Tracing/Tracers.hs +++ b/cardano-node/src/Cardano/Tracing/Tracers.hs @@ -29,6 +29,10 @@ module Cardano.Tracing.Tracers , traceCounter ) where +import qualified Cardano.Network.PeerSelection.ExtraRootPeers as Cardano +import qualified Ouroboros.Network.PeerSelection.Governor as Governor +import qualified Ouroboros.Network.PeerSelection.Governor.Types as Governor +import qualified Data.List as List import Cardano.BM.Data.Aggregated (Measurable (..)) import Cardano.BM.Data.Tracer (WithSeverity (..), annotateSeverity) import Cardano.BM.Data.Transformers @@ -44,7 +48,6 @@ 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 qualified Cardano.Node.Tracing.Tracers.Diffusion as DiffusionTracers import Cardano.Node.Tracing.Tracers.NodeVersion import Cardano.Network.Diffusion (CardanoPeerSelectionCounters) import Cardano.Protocol.TPraos.OCert (KESPeriod (..)) @@ -58,7 +61,7 @@ import Cardano.Tracing.Shutdown () import Cardano.Tracing.Startup () import Ouroboros.Consensus.Block (BlockConfig, BlockProtocol, CannotForge, ConvertRawHash (..), ForgeStateInfo, ForgeStateUpdateError, Header, - realPointHash, realPointSlot) + HeaderHash, realPointHash, realPointSlot) import Ouroboros.Consensus.BlockchainTime (SystemStart (..), TraceBlockchainTimeEvent (..)) import Ouroboros.Consensus.HeaderValidation (OtherHeaderEnvelopeError) @@ -76,7 +79,7 @@ import qualified Ouroboros.Consensus.Network.NodeToClient as NodeToClient import qualified Ouroboros.Consensus.Network.NodeToNode as NodeToNode import qualified Ouroboros.Consensus.Node.Run as Consensus (RunNode) import qualified Ouroboros.Consensus.Node.Tracers as Consensus -import Ouroboros.Consensus.Protocol.Abstract (SelectView, ValidationErr) +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 @@ -85,7 +88,6 @@ import Ouroboros.Consensus.Util.Enclose import qualified Network.Mux as Mux import qualified Cardano.Network.Diffusion.Types as Cardano.Diffusion -import qualified Cardano.Network.PeerSelection.Governor.Types as Cardano import qualified Ouroboros.Network.AnchoredFragment as AF import Ouroboros.Network.Block (BlockNo (..), ChainUpdate (..), HasHeader (..), Point, @@ -101,16 +103,14 @@ 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.NodeToClient (LocalAddress) -import Ouroboros.Network.NodeToNode (RemoteAddress) -import Ouroboros.Network.PeerSelection.Churn (ChurnCounters (..)) +import Cardano.Network.NodeToClient (LocalAddress) +import Cardano.Network.NodeToNode (RemoteAddress) import Ouroboros.Network.PeerSelection.Governor ( PeerSelectionView (..)) -import qualified Ouroboros.Network.PeerSelection.Governor 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 +import Ouroboros.Network.TxSubmission.Inbound.V2 import Codec.CBOR.Read (DeserialiseFailure) import Control.Concurrent (MVar, modifyMVar_) @@ -139,6 +139,7 @@ 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 +import Ouroboros.Consensus.Peras.SelectView {-# OPTIONS_GHC -Wno-redundant-constraints #-} @@ -245,7 +246,7 @@ instance ElidingTracer (WithSeverity (ChainDB.TraceEvent blk)) where 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.AddedToCurrentChain events _ _ _ _))) = null events doelide (WithSeverity _ (ChainDB.TraceAddBlockEvent (ChainDB.PipeliningEvent{}))) = True doelide (WithSeverity _ (ChainDB.TraceAddBlockEvent _)) = True doelide (WithSeverity _ (ChainDB.TraceCopyToImmutableDBEvent _)) = True @@ -413,15 +414,6 @@ mkTracers blockConfig tOpts@(TracingOnLegacy trSel) tr nodeKern ekgDirect = do <> tracePeerSelectionTracerMetrics (tracePeerSelection trSel) ekgDirect - , Diffusion.dtTraceChurnCounters = - traceChurnCountersMetrics - ekgDirect - , Diffusion.dtDebugPeerSelectionInitiatorTracer = - tracerOnOff (traceDebugPeerSelectionInitiatorTracer trSel) - verb "DebugPeerSelection" tr - , Diffusion.dtDebugPeerSelectionInitiatorResponderTracer = - tracerOnOff (traceDebugPeerSelectionInitiatorResponderTracer trSel) - verb "DebugPeerSelection" tr , Diffusion.dtTracePeerSelectionCounters = tracePeerSelectionCountersMetrics (tracePeerSelectionCounters trSel) @@ -465,6 +457,8 @@ mkTracers blockConfig tOpts@(TracingOnLegacy trSel) tr nodeKern ekgDirect = do verb "LedgerPeers" tr , Diffusion.dtDnsTracer = tracerOnOff (traceDNS trSel) verb "DNS" tr + , Diffusion.dtDebugPeerSelectionTracer = + tracerOnOff (traceDNS trSel) verb "DebugPeerSelection" tr } verb :: TracingVerbosity verb = traceVerbosity trSel @@ -511,6 +505,8 @@ mkTracers _ _ _ _ _ = , Consensus.csjTracer = nullTracer , Consensus.dbfTracer = nullTracer , Consensus.kesAgentTracer = nullTracer + , Consensus.txLogicTracer = nullTracer + , Consensus.txCountersTracer = nullTracer } , nodeToClientTracers = NodeToClient.Tracers { NodeToClient.tChainSyncTracer = nullTracer @@ -526,6 +522,7 @@ mkTracers _ _ _ _ _ = , NodeToNode.tTxSubmission2Tracer = nullTracer , NodeToNode.tKeepAliveTracer = nullTracer , NodeToNode.tPeerSharingTracer = nullTracer + , NodeToNode.tTxLogicTracer = nullTracer } , diffusionTracers = Diffusion.nullTracers , churnModeTracer = nullTracer @@ -547,8 +544,25 @@ notifyTxsMempoolTimeoutHard :: Maybe EKGDirect -> Tracer IO Mux.Trace notifyTxsMempoolTimeoutHard mbEKGDirect = case mbEKGDirect of Nothing -> nullTracer Just ekgDirect -> Tracer $ \ev -> do - when (DiffusionTracers.impliesMempoolTimeoutHard ev) $ do - sendEKGDirectCounter ekgDirect $ "cardano.node.metrics." <> DiffusionTracers.txsMempoolTimeoutHardCounterName + 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 @@ -576,7 +590,8 @@ teeTraceChainTip , InspectLedger blk , ToObject (Header blk) , ToObject (LedgerEvent blk) - , ToObject (SelectView (BlockProtocol blk)) + , ToObject (WeightedSelectView (BlockProtocol blk)) + , ToJSON (HeaderHash blk) ) => BlockConfig blk -> ForgingStats @@ -600,7 +615,8 @@ teeTraceChainTipElide , InspectLedger blk , ToObject (Header blk) , ToObject (LedgerEvent blk) - , ToObject (SelectView (BlockProtocol blk)) + , ToObject (WeightedSelectView (BlockProtocol blk)) + , ToJSON (HeaderHash blk) ) => TracingVerbosity -> MVar (Maybe (WithSeverity (ChainDB.TraceEvent blk)), Integer) @@ -632,11 +648,11 @@ traceChainMetrics (Just _ekgDirect) tForks _blockConfig _fStats tr = do chainTipInformation :: ChainDB.TraceEvent blk -> Maybe ChainInformation chainTipInformation = \case ChainDB.TraceAddBlockEvent ev -> case ev of - ChainDB.SwitchedToAFork _warnings selChangedInfo oldChain newChain -> + 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 -> + ChainDB.AddedToCurrentChain _warnings selChangedInfo oldChain newChain _switchReason -> Just $ chainInformation selChangedInfo False oldChain newChain 0 _ -> Nothing _ -> Nothing @@ -750,6 +766,7 @@ mkConsensusTracers , ToJSON peer , LedgerQueries blk , ToJSON (GenTxId blk) + , ToJSON (HeaderHash blk) , ToObject (ApplyTxErr blk) , ToObject (CannotForge blk) , ToObject (GenTx blk) @@ -778,7 +795,7 @@ mkConsensusTracers mbEKGDirect trSel verb tr nodeKern fStats = do tBlocksServed <- STM.newTVarIO 0 tLocalUp <- STM.newTVarIO 0 tMaxSlotNo <- STM.newTVarIO $ SlotNo 0 - tSubmissionsCollected <- STM.newTVarIO 0 + tSubmissionsCollected <- STM.newTVarIO [] tSubmissionsAccepted <- STM.newTVarIO 0 tSubmissionsRejected <- STM.newTVarIO 0 tBlockDelayM <- STM.newTVarIO Pq.empty @@ -809,8 +826,8 @@ mkConsensusTracers mbEKGDirect trSel verb tr nodeKern fStats = do traceWith (annotateSeverity . toLogObject' verb $ appendName "TxInbound" tr) ev case ev of TraceLabelPeer _ (TraceTxSubmissionCollected collected) -> - traceI trmet meta "submissions.submitted.count" =<< - STM.modifyReadTVarIO tSubmissionsCollected (+ collected) + traceI trmet meta "submissions.submitted.count" . length =<< + STM.modifyReadTVarIO tSubmissionsCollected (<> collected) TraceLabelPeer _ (TraceTxSubmissionProcessed processed) -> do traceI trmet meta "submissions.accepted.count" =<< @@ -821,6 +838,10 @@ mkConsensusTracers mbEKGDirect trSel verb tr nodeKern fStats = do 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 @@ -840,6 +861,8 @@ mkConsensusTracers mbEKGDirect trSel verb tr nodeKern fStats = do , 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 @@ -1066,15 +1089,15 @@ traceLeadershipChecks _ft nodeKern _tverb tr = Tracer $ !query <- mapNodeKernelDataIO (\nk -> (,,) - <$> fmap (maybe 0 LedgerDB.ledgerTableSize) (ChainDB.getStatistics $ getChainDB nk) + <$> ChainDB.getStatistics (getChainDB nk) <*> nkQueryLedger (ledgerDelegMapSize . ledgerState) nk <*> nkQueryChain fragmentChainDensity nk) nodeKern meta <- mkLOMeta sev Public fromSMaybe (pure ()) $ query <&> - \(utxoSize, delegMapSize, _) -> do - traceCounter "utxoSize" tr utxoSize + \(ledgerStatistics, delegMapSize, _) -> do + traceCounter "utxoSize" tr (LedgerDB.ledgerTableSize ledgerStatistics) traceCounter "delegMapSize" tr delegMapSize traceNamedObject (appendName "LeadershipCheck" tr) ( meta @@ -1084,8 +1107,8 @@ traceLeadershipChecks _ft nodeKern _tverb tr = Tracer $ ,("slot", toJSON $ unSlotNo slot)] ++ fromSMaybe [] (query <&> - \(utxoSize, delegMapSize, chainDensity) -> - [ ("utxoSize", toJSON utxoSize) + \(ledgerStatistics, delegMapSize, chainDensity) -> + [ ("utxoSize", toJSON (LedgerDB.ledgerTableSize ledgerStatistics)) , ("delegMapSize", toJSON delegMapSize) , ("chainDensity", toJSON (fromRational chainDensity :: Float)) ]) @@ -1321,6 +1344,7 @@ mempoolTracer :: ( ToJSON (GenTxId blk) , ToObject (ApplyTxErr blk) , ToObject (GenTx blk) + , ToJSON (HeaderHash blk) , LedgerSupportsMempool blk , ConvertRawHash blk ) @@ -1341,6 +1365,7 @@ mempoolTracer mbEKGDirect tc tracer fStats = Tracer $ \ev -> do mpTracer :: ( ToJSON (GenTxId blk) , ToObject (ApplyTxErr blk) , ToObject (GenTx blk) + , ToJSON (HeaderHash blk) , ConvertRawHash blk , LedgerSupportsMempool blk ) @@ -1504,6 +1529,9 @@ nodeToNodeTracers' trSel verb tr = , NodeToNode.tPeerSharingTracer = tracerOnOff (tracePeerSharingProtocol trSel) verb "PeerSharingPrototocol" tr + , NodeToNode.tTxLogicTracer = + tracerOnOff (traceTxLogic trSel) + verb "TxLogicTracer" tr } -- TODO @ouroboros-network @@ -1511,6 +1539,7 @@ teeTraceBlockFetchDecision :: ( Eq peer , Show peer , ToJSON peer + , ToJSON (HeaderHash blk) , HasHeader blk , ConvertRawHash blk ) @@ -1523,25 +1552,16 @@ teeTraceBlockFetchDecision verb eliding tr = PeerStarvedUs {} -> do traceWith (toLogObject' verb meTr) ev PeersFetch ev' -> do - traceWith (teeTraceBlockFetchDecision' meTr) (WithSeverity s ev') traceWith (teeTraceBlockFetchDecisionElide verb eliding bfdTr) (WithSeverity s ev') where meTr = appendName "metrics" tr bfdTr = appendName "BlockFetchDecision" tr -teeTraceBlockFetchDecision' - :: Trace IO Text - -> Tracer IO (WithSeverity [TraceLabelPeer peer (FetchDecision [Point (Header blk)])]) -teeTraceBlockFetchDecision' tr = - Tracer $ \(WithSeverity _ peers) -> do - meta <- mkLOMeta Info Confidential - let tr' = appendName "peers" tr - traceNamedObject tr' (meta, LogValue "connectedPeers" . PureI $ fromIntegral $ length peers) - teeTraceBlockFetchDecisionElide :: ( Eq peer , Show peer , ToJSON peer + , ToJSON (HeaderHash blk) , HasHeader blk , ConvertRawHash blk ) @@ -1590,7 +1610,6 @@ traceConnectionManagerTraceMetrics (OnOff True) (Just ekgDirect) = cmtTracer outboundConns _ -> return () - tracePeerSelectionTracerMetrics :: forall extraDebugState extraFlags extraPeers peeraddr. OnOff TracePeerSelection @@ -1610,7 +1629,6 @@ tracePeerSelectionTracerMetrics (OnOff True) (Just ekgDirect) = pstTracer (realToFrac duration) _ -> pure () - tracePeerSelectionCountersMetrics :: OnOff TracePeerSelectionCounters -> Maybe EKGDirect @@ -1621,7 +1639,7 @@ tracePeerSelectionCountersMetrics (OnOff True) (Just ekgDirect) = pscTracer where pscTracer :: Tracer IO CardanoPeerSelectionCounters pscTracer = Tracer $ \psc -> do - let PeerSelectionCountersHWC {..} = psc + 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 @@ -1672,18 +1690,6 @@ tracePeerSelectionCountersMetrics (OnOff True) (Just ekgDirect) = pscTracer sendEKGDirectInt ekgDirect "cardano.node.metrics.peerSelection.ActiveBootstrapPeers" (snd $ Cardano.viewActiveBootstrapPeers extraCounters) sendEKGDirectInt ekgDirect "cardano.node.metrics.peerSelection.ActiveBootstrapPeersDemotions" (snd $ Cardano.viewActiveBootstrapPeersDemotions extraCounters) - -traceChurnCountersMetrics - :: Maybe EKGDirect - -> Tracer IO ChurnCounters -traceChurnCountersMetrics Nothing = nullTracer -traceChurnCountersMetrics (Just ekgDirect) = churnTracer - where - churnTracer :: Tracer IO ChurnCounters - churnTracer = Tracer $ \(ChurnCounter action c) -> - sendEKGDirectInt ekgDirect ("cardano.node.metrics.peerSelection.churn." <> Text.pack (show action)) c - - traceInboundGovernorCountersMetrics :: forall addr. OnOff TraceInboundGovernorCounters diff --git a/cardano-node/test/Test/Cardano/Node/Gen.hs b/cardano-node/test/Test/Cardano/Node/Gen.hs index d2fd8220b49..bf78e319949 100644 --- a/cardano-node/test/Test/Cardano/Node/Gen.hs +++ b/cardano-node/test/Test/Cardano/Node/Gen.hs @@ -14,7 +14,6 @@ module Test.Cardano.Node.Gen , genNodeIPAddress , genNodeIPv4Address , genNodeIPv6Address - , genNodeSetup ) where import Cardano.Api (textShow) @@ -24,17 +23,20 @@ import Cardano.Network.PeerSelection.PeerTrustable import Cardano.Node.Configuration.NodeAddress (NodeAddress' (..), NodeHostIPAddress (..), NodeHostIPv4Address (..), NodeHostIPv6Address (..), NodeIPAddress, NodeIPv4Address, NodeIPv6Address) -import Cardano.Node.Configuration.TopologyP2P (LocalRootPeersGroup (..), - LocalRootPeersGroups (..), NetworkTopology (..), NodeSetup (..), - PeerAdvertise (..), PublicRootPeers (..), RootConfig (..)) +import Ouroboros.Network.Diffusion.Topology (LocalRootPeersGroup (..), + LocalRootPeersGroups (..), NetworkTopology (..), + PublicRootPeers (..), RootConfig (..), LocalRoots (..)) import Cardano.Node.Types import Cardano.Slotting.Slot (SlotNo (..)) -import Ouroboros.Network.NodeToNode.Version +import Cardano.Network.NodeToNode.Version import Ouroboros.Network.PeerSelection.LedgerPeers.Type (AfterSlot (..), UseLedgerPeers (..)) import Ouroboros.Network.PeerSelection.RelayAccessPoint (RelayAccessPoint (..)) import Ouroboros.Network.PeerSelection.State.LocalRootPeers (HotValency (..), WarmValency (..)) +import Cardano.Network.Diffusion.Topology (CardanoNetworkTopology) +import Ouroboros.Network.PeerSelection.PeerAdvertise (PeerAdvertise (..)) +import Ouroboros.Network.ConnectionManager.Types (Provenance (..)) import qualified Data.Aeson as Aeson import qualified Data.Aeson.KeyMap as Aeson.KeyMap @@ -50,14 +52,14 @@ import Hedgehog.Internal.Gen () import qualified Hedgehog.Range as Range -- TODO parameterize generators -genNetworkTopology :: Gen (NetworkTopology RelayAccessPoint) +genNetworkTopology :: Gen CardanoNetworkTopology genNetworkTopology = Gen.choice - [ RealNodeTopology <$> genLocalRootPeersGroups - <*> Gen.list (Range.linear 0 10) genPublicRootPeers - <*> genUseLedgerPeers - <*> genUseBootstrapPeers - <*> genPeerSnapshotPath + [ NetworkTopology <$> genLocalRootPeersGroups + <*> Gen.list (Range.linear 0 10) genPublicRootPeers + <*> genUseLedgerPeers + <*> (fmap unPeerSnapshotFile <$> genPeerSnapshotPath) + <*> genUseBootstrapPeers ] -- | Generate valid encodings of p2p topology files @@ -145,15 +147,6 @@ genNodeIPv4Address = genNodeAddress' genNodeHostIPv4Address genNodeIPv6Address :: Gen NodeIPv6Address genNodeIPv6Address = genNodeAddress' genNodeHostIPv6Address -genNodeSetup :: Gen (NodeSetup RelayAccessPoint) -genNodeSetup = - NodeSetup - <$> Gen.word64 (Range.linear 0 10000) - <*> Gen.maybe (genNodeAddress' genNodeHostIPv4Address) - <*> Gen.maybe (genNodeAddress' genNodeHostIPv6Address) - <*> Gen.list (Range.linear 0 6) genRootConfig - <*> genUseLedgerPeers - -- Generates only fully qualified domain names. -- genRelayAddress :: Gen RelayAccessPoint @@ -172,25 +165,34 @@ genRelayAddress = <*> (fromIntegral <$> Gen.int (Range.linear 1000 9000)) ] -genRootConfig :: Gen (RootConfig RelayAccessPoint) +genRootConfig :: Gen RootConfig genRootConfig = do RootConfig <$> Gen.list (Range.linear 0 6) genRelayAddress <*> Gen.element [DoAdvertisePeer, DoNotAdvertisePeer] -genLocalRootPeersGroup :: Gen (LocalRootPeersGroup RelayAccessPoint) +genProvenance :: Gen Provenance +genProvenance = Gen.element [Outbound, Inbound] + +genLocalRoots :: Gen LocalRoots +genLocalRoots = + LocalRoots + <$> genRootConfig + <*> genProvenance + +genLocalRootPeersGroup :: Gen (LocalRootPeersGroup PeerTrustable) genLocalRootPeersGroup = do - ra <- genRootConfig - hval <- Gen.int (Range.linear 0 (length (rootAccessPoints ra))) + ra <- genLocalRoots + hval <- Gen.int (Range.linear 0 (length (rootAccessPoints (rootConfig ra)))) wval <- WarmValency <$> Gen.int (Range.linear 0 hval) - LocalRootPeersGroup ra (HotValency hval) wval <$> genPeerTrustable <*> pure InitiatorAndResponderDiffusionMode + LocalRootPeersGroup ra (HotValency hval) wval InitiatorAndResponderDiffusionMode <$> genPeerTrustable -genLocalRootPeersGroups :: Gen (LocalRootPeersGroups RelayAccessPoint) +genLocalRootPeersGroups :: Gen (LocalRootPeersGroups PeerTrustable) genLocalRootPeersGroups = LocalRootPeersGroups <$> Gen.list (Range.linear 0 6) genLocalRootPeersGroup -genPublicRootPeers :: Gen (PublicRootPeers RelayAccessPoint) +genPublicRootPeers :: Gen PublicRootPeers genPublicRootPeers = PublicRootPeers <$> genRootConfig diff --git a/cardano-node/test/Test/Cardano/Node/Json.hs b/cardano-node/test/Test/Cardano/Node/Json.hs index 9452fa28d95..513fc62810b 100644 --- a/cardano-node/test/Test/Cardano/Node/Json.hs +++ b/cardano-node/test/Test/Cardano/Node/Json.hs @@ -4,8 +4,8 @@ module Test.Cardano.Node.Json ( tests ) where -import Cardano.Node.Configuration.TopologyP2P (NetworkTopology) -import Ouroboros.Network.PeerSelection.RelayAccessPoint (RelayAccessPoint) +import Cardano.Network.Diffusion.Topology (CardanoNetworkTopology) +import Cardano.Network.OrphanInstances () import Data.Aeson (decode, encode, fromJSON, toJSON) import Data.Maybe (isJust) @@ -44,13 +44,6 @@ prop_roundtrip_NodeHostAddress_JSON = Hedgehog.tripping nha toJSON fromJSON Hedgehog.tripping nha encode decode -prop_roundtrip_NodeSetup_JSON :: Property -prop_roundtrip_NodeSetup_JSON = - Hedgehog.property $ do - ns <- Hedgehog.forAll genNodeSetup - Hedgehog.tripping ns toJSON fromJSON - Hedgehog.tripping ns encode decode - prop_roundtrip_NetworkTopology_JSON :: Property prop_roundtrip_NetworkTopology_JSON = Hedgehog.property $ do @@ -64,7 +57,7 @@ prop_decode_NetworkTopology_JSON :: Property prop_decode_NetworkTopology_JSON = Hedgehog.property $ do enc <- Hedgehog.forAll genNetworkTopologyEncoding - let tp :: Maybe (NetworkTopology RelayAccessPoint) + let tp :: Maybe CardanoNetworkTopology tp = decode enc Hedgehog.assert $ isJust tp diff --git a/cardano-node/test/Test/Cardano/Node/POM.hs b/cardano-node/test/Test/Cardano/Node/POM.hs index d4de440fbd7..9384854dbcb 100644 --- a/cardano-node/test/Test/Cardano/Node/POM.hs +++ b/cardano-node/test/Test/Cardano/Node/POM.hs @@ -22,10 +22,11 @@ import Ouroboros.Consensus.Storage.LedgerDB.Args import Ouroboros.Consensus.Storage.LedgerDB.Snapshots (NumOfDiskSnapshots (..), SnapshotInterval (..)) import Ouroboros.Network.Block (SlotNo (..)) -import Ouroboros.Network.Diffusion.Configuration (ConsensusMode (..)) -import Ouroboros.Network.NodeToNode (AcceptedConnectionsLimit (..), +import Cardano.Network.ConsensusMode (ConsensusMode (..)) +import Cardano.Network.NodeToNode (AcceptedConnectionsLimit (..), DiffusionMode (InitiatorAndResponderDiffusionMode)) import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing (..)) +import Ouroboros.Network.TxSubmission.Inbound.V2.Types import Data.Monoid (Last (..)) import Data.Text (Text) @@ -174,6 +175,8 @@ testPartialYamlConfig = , pncResponderCoreAffinityPolicy = mempty , pncLedgerDbConfig = mempty , pncEgressPollInterval = mempty + , pncTxSubmissionLogicVersion = mempty + , pncTxSubmissionInitDelay = mempty } -- | Example partial configuration theoretically created @@ -227,6 +230,8 @@ testPartialCliConfig = , pncResponderCoreAffinityPolicy = mempty , pncLedgerDbConfig = mempty , pncEgressPollInterval = mempty + , pncTxSubmissionLogicVersion = mempty + , pncTxSubmissionInitDelay = mempty } -- | Expected final NodeConfiguration @@ -286,6 +291,8 @@ eExpectedConfig = do , ncGenesisConfig = disableGenesisConfig , ncResponderCoreAffinityPolicy = NoResponderCoreAffinity , ncLedgerDbConfig = LedgerDbConfiguration DefaultNumOfDiskSnapshots DefaultSnapshotInterval DefaultQueryBatchSize V2InMemory noDeprecatedOptions + , ncTxSubmissionLogicVersion = TxSubmissionLogicV1 + , ncTxSubmissionInitDelay = defaultTxSubmissionInitDelay } -- ----------------------------------------------------------------------------- diff --git a/cardano-submit-api/cardano-submit-api.cabal b/cardano-submit-api/cardano-submit-api.cabal index b7cb0bd700f..18bd10e11eb 100644 --- a/cardano-submit-api/cardano-submit-api.cabal +++ b/cardano-submit-api/cardano-submit-api.cabal @@ -39,18 +39,18 @@ library , aeson , async , bytestring - , cardano-api ^>= 10.24.1 + , cardano-api ^>= 10.25 , cardano-binary , cardano-cli ^>= 10.15.0.1 - , cardano-crypto-class ^>=2.2.3.2 + , cardano-crypto-class ^>=2.3 , containers , ekg-core , http-media , mtl , network , optparse-applicative-fork - , ouroboros-consensus-cardano - , ouroboros-network-protocols + , ouroboros-consensus:cardano + , ouroboros-network:{protocols} , prometheus >= 2.2.4 , ekg-prometheus-adapter , safe-exceptions @@ -99,4 +99,4 @@ test-suite unit main-is: test.hs hs-source-dirs: test build-depends: base - , cardano-crypto-class ^>=2.2.3.2 + , cardano-crypto-class ^>=2.3 diff --git a/cardano-submit-api/src/Cardano/TxSubmit/Tracing/TraceSubmitApi.hs b/cardano-submit-api/src/Cardano/TxSubmit/Tracing/TraceSubmitApi.hs index a1924ecb434..58ef4f47578 100644 --- a/cardano-submit-api/src/Cardano/TxSubmit/Tracing/TraceSubmitApi.hs +++ b/cardano-submit-api/src/Cardano/TxSubmit/Tracing/TraceSubmitApi.hs @@ -52,6 +52,8 @@ renderTxCmdError (TxCmdTxSubmitValidationError e) = "transaction submit error " <> textShow validationErr TxValidationEraMismatch eraMismatch -> "transaction submit era mismatch" <> textShow eraMismatch +renderTxCmdError (TxCmdTxSubmitConnectionError e) = + "transaction connection error " <> textShow e instance LogFormatting TraceSubmitApi where forMachine _ ApplicationStopping = mempty diff --git a/cardano-submit-api/src/Cardano/TxSubmit/Types.hs b/cardano-submit-api/src/Cardano/TxSubmit/Types.hs index 07d5f29df4e..ccbccd3e4cf 100644 --- a/cardano-submit-api/src/Cardano/TxSubmit/Types.hs +++ b/cardano-submit-api/src/Cardano/TxSubmit/Types.hs @@ -93,6 +93,7 @@ data TxCmdError = TxCmdSocketEnvError EnvSocketError | TxCmdTxReadError !RawCborDecodeError | TxCmdTxSubmitValidationError !TxValidationErrorInCardanoMode + | TxCmdTxSubmitConnectionError !Text deriving instance Generic TxCmdError @@ -108,6 +109,7 @@ renderTxCmdError = \case case e of TxValidationErrorInCardanoMode err -> "transaction submit error " <> T.pack (show err) TxValidationEraMismatch eraMismatch -> "transaction submit era mismatch" <> textShow eraMismatch + TxCmdTxSubmitConnectionError msg -> "transaction submit connection error: " <> msg -- | Servant API which provides access to tx submission webapi type TxSubmitApi = "api" :> ToServantApi TxSubmitApiRecord diff --git a/cardano-submit-api/src/Cardano/TxSubmit/Web.hs b/cardano-submit-api/src/Cardano/TxSubmit/Web.hs index f646bb0422a..307c79e16ce 100644 --- a/cardano-submit-api/src/Cardano/TxSubmit/Web.hs +++ b/cardano-submit-api/src/Cardano/TxSubmit/Web.hs @@ -17,8 +17,10 @@ import Cardano.Api (AllegraEra, AnyCardanoEra (AnyCardanoEra), AsType IsCardanoEra (..), LocalNodeConnectInfo (LocalNodeConnectInfo, localConsensusModeParams, localNodeNetworkId, localNodeSocketPath), NetworkId, SerialiseAsCBOR (..), ShelleyBasedEra (..), ShelleyEra, SocketPath, - ToJSON, Tx, TxId (..), TxInMode (TxInMode), TxValidationErrorInCardanoMode (..), + ToJSON, Tx, TxId (..), TxInMode (TxInMode), + TxValidationErrorInCardanoMode (..), getTxBody, getTxId, submitTxToNodeLocal) +import qualified Cardano.Api import Cardano.Binary (DecoderError (..)) import qualified Cardano.Crypto.Hash.Class as Crypto @@ -28,7 +30,8 @@ import qualified Cardano.TxSubmit.Rest.Web as Web import Cardano.TxSubmit.Tracing.TraceSubmitApi (TraceSubmitApi (..)) import Cardano.TxSubmit.Types (EnvSocketError (..), RawCborDecodeError (..), TxCmdError (..), TxSubmitApi, TxSubmitApiRecord (..), - TxSubmitWebApiError (TxSubmitFail), renderTxCmdError) + TxSubmitWebApiError, renderTxCmdError) +import qualified Cardano.TxSubmit.Types as Types import Cardano.TxSubmit.Util (logException) import Ouroboros.Consensus.Cardano.Block (EraMismatch (..)) import qualified Ouroboros.Network.Protocol.LocalTxSubmission.Client as Net.Tx @@ -140,11 +143,13 @@ txSubmitPost trace p@(CardanoModeParams cModeParams) networkId socketPath txByte res <- liftIO $ submitTxToNodeLocal localNodeConnInfo txInMode case res of - Net.Tx.SubmitSuccess -> do + Cardano.Api.TxSubmitSuccess -> do liftIO $ T.putStrLn "Transaction successfully submitted." return $ getTxId (getTxBody tx) - Net.Tx.SubmitFail e -> + Cardano.Api.TxSubmitFail e -> left $ TxCmdTxSubmitValidationError e + Cardano.Api.TxSubmitError e -> + left $ TxCmdTxSubmitConnectionError (T.pack (show e)) where handle :: ExceptT TxCmdError IO TxId -> Handler TxId handle f = do @@ -161,7 +166,7 @@ txSubmitPost trace p@(CardanoModeParams cModeParams) networkId socketPath txByte case res of Left err -> do liftIO $ traceWith trace $ EndpointFailedToSubmitTransaction err - errorResponse (TxSubmitFail err) + errorResponse (Types.TxSubmitFail err) Right txid -> do liftIO $ traceWith trace $ EndpointSubmittedTransaction txid pure txid diff --git a/cardano-testnet/cardano-testnet.cabal b/cardano-testnet/cardano-testnet.cabal index a959470b641..8a418f549e2 100644 --- a/cardano-testnet/cardano-testnet.cabal +++ b/cardano-testnet/cardano-testnet.cabal @@ -41,9 +41,9 @@ library , annotated-exception , ansi-terminal , bytestring - , cardano-api ^>= 10.24.1 + , cardano-api ^>= 10.25 , cardano-cli:{cardano-cli, cardano-cli-test-lib} ^>= 10.15.0.1 - , cardano-crypto-class ^>=2.2.3.2 + , cardano-crypto-class ^>=2.3 , cardano-crypto-wrapper , cardano-git-rev ^>= 0.2.2 , cardano-ledger-alonzo @@ -57,7 +57,7 @@ library , cardano-ledger-dijkstra , cardano-ledger-shelley , cardano-node - , cardano-ping ^>= 0.9 + , cardano-ping ^>= 0.10 , cardano-prelude , contra-tracer , containers @@ -84,8 +84,8 @@ library , network , network-mux , optparse-applicative-fork - , ouroboros-network ^>= 0.22.6 - , ouroboros-network-api + , ouroboros-network:{api, framework, ouroboros-network} ^>= 1.1 + , cardano-diffusion:{api, cardano-diffusion} ^>= 1.0 , prettyprinter , process , resourcet @@ -153,7 +153,7 @@ executable cardano-testnet main-is: cardano-testnet.hs - build-depends: cardano-crypto-class ^>=2.2.3.2 + build-depends: cardano-crypto-class ^>=2.3 , cardano-cli , cardano-testnet , optparse-applicative-fork @@ -257,7 +257,6 @@ test-suite cardano-testnet-test , cardano-ledger-conway , cardano-ledger-core , cardano-ledger-shelley - , cardano-node , cardano-prelude , cardano-slotting , cardano-strict-containers ^>= 0.1 @@ -276,6 +275,7 @@ test-suite cardano-testnet-test , microlens , monad-control , mtl + , ouroboros-network:api , process , resourcet , regex-compat diff --git a/cardano-testnet/src/Parsers/Cardano.hs b/cardano-testnet/src/Parsers/Cardano.hs index 12dc8f77e85..cde14d1a37f 100644 --- a/cardano-testnet/src/Parsers/Cardano.hs +++ b/cardano-testnet/src/Parsers/Cardano.hs @@ -82,6 +82,11 @@ pCardanoTestnetCliOptions = CardanoTestnetOptions <> OA.help "Directory where to store files, sockets, and so on. It is created if it doesn't exist. If unset, a temporary directory is used." <> OA.metavar "DIRECTORY" ))) + <*> OA.flag UseKESKeyFile UseKESSocket + ( OA.long "use-kes-agent" + <> OA.help "Get Praos block forging credentials from kes-agent via the default socket path" + <> OA.showDefault + ) pTestnetNodeOptions :: Parser (NonEmpty NodeOption) pTestnetNodeOptions = diff --git a/cardano-testnet/src/Parsers/Run.hs b/cardano-testnet/src/Parsers/Run.hs index 050c8230ed4..04d96885ccc 100644 --- a/cardano-testnet/src/Parsers/Run.hs +++ b/cardano-testnet/src/Parsers/Run.hs @@ -62,7 +62,7 @@ createEnvOptions CardanoTestnetCreateEnvOptions , createEnvCreateEnvOptions=ceOptions } = do conf <- mkConfigAbs outputDir - createTestnetEnv + void $ createTestnetEnv testnetOptions genesisOptions ceOptions -- Do not add hashes to the main config file, so that genesis files -- can be modified without having to recompute hashes every time. diff --git a/cardano-testnet/src/Testnet/Blockfrost.hs b/cardano-testnet/src/Testnet/Blockfrost.hs index be8093d13f6..4895fd1a3fc 100644 --- a/cardano-testnet/src/Testnet/Blockfrost.hs +++ b/cardano-testnet/src/Testnet/Blockfrost.hs @@ -4,6 +4,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Werror=missing-fields #-} +{-# LANGUAGE NamedFieldPuns #-} module Testnet.Blockfrost ( BlockfrostParams @@ -14,8 +15,7 @@ import Cardano.Ledger.Alonzo.Genesis (AlonzoGenesis (..)) import Cardano.Ledger.Alonzo.PParams (CoinPerWord) import Cardano.Ledger.BaseTypes (EpochInterval, NonNegativeInterval, Nonce, ProtVer (..), UnitInterval, Version) -import Cardano.Ledger.Coin (Coin) -import Cardano.Ledger.Compactible (toCompactPartial) +import Cardano.Ledger.Coin (Coin, CoinPerByte (..), compactCoinOrError) import Cardano.Ledger.Conway.Genesis (ConwayGenesis (..)) import Cardano.Ledger.Conway.PParams (DRepVotingThresholds (..), PoolVotingThresholds (..), UpgradeConwayPParams (..)) @@ -28,25 +28,27 @@ import Cardano.Ledger.Shelley.Genesis (ShelleyGenesis (..)) import Cardano.Ledger.Shelley.PParams (ShelleyPParams (..)) import Control.Applicative ((<|>)) +import Control.Exception.Safe (MonadThrow) import Data.Aeson (FromJSON (..), withObject, (.:)) import qualified Data.Aeson as Aeson import qualified Data.Aeson.Types as Aeson import qualified Data.Map.Strict as Map import Data.Scientific (Scientific) import Data.Word (Word16, Word32) +import GHC.Stack import Numeric.Natural (Natural) import Text.Read (readMaybe) data BlockfrostParams = BlockfrostParams { -- Alonzo parameters bfgCoinsPerUTxOWord :: CoinPerWord - , bfgCollateralPercent :: Natural + , bfgCollateralPercent :: Word16 , bfgMaxBlockExMem :: Natural , bfgMaxBlockExSteps :: Natural - , bfgMaxCollateralInputs :: Natural + , bfgMaxCollateralInputs :: Word16 , bfgMaxTxExMem :: Natural , bfgMaxTxExSteps :: Natural - , bfgMaxValueSize :: Natural + , bfgMaxValueSize :: Word32 , bfgPriceMem :: NonNegativeInterval , bfgPriceSteps :: NonNegativeInterval -- PlutusV1 and PlutusV2 @@ -182,75 +184,87 @@ instance FromJSON BlockfrostParams where Nothing -> Aeson.parseFail $ "Bogus value at key " ++ show k ++ " is neither Number nor String" -- Edit a set of Genesis files with data from Blockfrost parameters -blockfrostToGenesis :: () +blockfrostToGenesis + :: HasCallStack + => MonadThrow m => (ShelleyGenesis, AlonzoGenesis, ConwayGenesis, DijkstraGenesis) -> BlockfrostParams - -> (ShelleyGenesis, AlonzoGenesis, ConwayGenesis, DijkstraGenesis) + -> m (ShelleyGenesis, AlonzoGenesis, ConwayGenesis, DijkstraGenesis) blockfrostToGenesis (shelleyGenesis', alonzoGenesis', conwayGenesis', dijkstraGenesis') BlockfrostParams{..} = - (shelleyGenesis, alonzoGenesis, conwayGenesis, dijkstraGenesis) + (,,,) + <$> shelleyGenesis + <*> alonzoGenesis + <*> conwayGenesis + <*> dijkstraGenesis where -- Alonzo params - alonzoGenesis = alonzoGenesis' - { agCoinsPerUTxOWord = bfgCoinsPerUTxOWord - , agCollateralPercentage = bfgCollateralPercent - , agMaxBlockExUnits = ExUnits - { exUnitsMem = bfgMaxBlockExMem - , exUnitsSteps = bfgMaxBlockExSteps - } - , agMaxCollateralInputs = bfgMaxCollateralInputs - , agMaxTxExUnits = ExUnits - { exUnitsMem = bfgMaxTxExMem - , exUnitsSteps = bfgMaxTxExSteps - } - , agMaxValSize = bfgMaxValueSize - , agPrices = Prices - { prMem = bfgPriceMem - , prSteps = bfgPriceSteps - } - , agCostModels = CostModels.mkCostModels . Map.mapWithKey trimCostModelToInitial $ CostModels.costModelsValid bfgAlonzoCostModels - } + alonzoGenesis = do + v1CostModel <- maybe (error "Testnet.Blockfrost: no PlutusV1 valid cost model in response") (trimCostModelToInitial PlutusV1) + . Map.lookup PlutusV1 $ CostModels.costModelsValid bfgAlonzoCostModels - -- Conway Params - conwayParams = UpgradeConwayPParams - { ucppPoolVotingThresholds = PoolVotingThresholds - { pvtMotionNoConfidence = bfgPVTMotionNoConfidence - , pvtCommitteeNormal = bfgPVTCommitteeNormal - , pvtCommitteeNoConfidence = bfgPVTCommitteeNoConfidence - , pvtHardForkInitiation = bfgPVTHardForkInitiation - , pvtPPSecurityGroup = bfgPVTPPSecurityGroup + pure $ alonzoGenesis' + { agCoinsPerUTxOWord = bfgCoinsPerUTxOWord + , agCollateralPercentage = bfgCollateralPercent + , agMaxBlockExUnits = ExUnits + { exUnitsMem = bfgMaxBlockExMem + , exUnitsSteps = bfgMaxBlockExSteps + } + , agMaxCollateralInputs = bfgMaxCollateralInputs + , agMaxTxExUnits = ExUnits + { exUnitsMem = bfgMaxTxExMem + , exUnitsSteps = bfgMaxTxExSteps + } + , agMaxValSize = bfgMaxValueSize + , agPrices = Prices + { prMem = bfgPriceMem + , prSteps = bfgPriceSteps + } + , agPlutusV1CostModel = v1CostModel + -- CostModels.mkCostModels . Map.mapWithKey trimCostModelToInitial . $ CostModels.costModelsValid bfgAlonzoCostModels } - , ucppDRepVotingThresholds = DRepVotingThresholds - { dvtMotionNoConfidence = bfgDVTMotionNoConfidence - , dvtCommitteeNormal = bfgDVTCommitteeNormal - , dvtCommitteeNoConfidence = bfgDVTCommitteeNoConfidence - , dvtUpdateToConstitution = bfgDVTUpdateToConstitution - , dvtHardForkInitiation = bfgDVTHardForkInitiation - , dvtPPNetworkGroup = bfgDVTPPNetworkGroup - , dvtPPEconomicGroup = bfgDVTPPEconomicGroup - , dvtPPTechnicalGroup = bfgDVTPPTechnicalGroup - , dvtPPGovGroup = bfgDVTPPGovGroup - , dvtTreasuryWithdrawal = bfgDVTTreasuryWithdrawal - } - , ucppCommitteeMinSize = bfgCommitteeMinSize - , ucppCommitteeMaxTermLength = bfgCommitteeMaxTermLength - , ucppGovActionLifetime = bfgGovActionLifetime - , ucppGovActionDeposit = bfgGovActionDeposit - , ucppDRepDeposit = bfgDRepDeposit - , ucppDRepActivity = bfgDRepActivity - , ucppMinFeeRefScriptCostPerByte = bfgMinFeeRevScriptCostPerByte - , ucppPlutusV3CostModel = trimCostModelToInitial PlutusV3 bfgConwayCostModel - } - conwayGenesis = conwayGenesis'{cgUpgradePParams=conwayParams} + + conwayGenesis = do + ucppPlutusV3CostModel <- trimCostModelToInitial PlutusV3 bfgConwayCostModel + let conwayParams = UpgradeConwayPParams + { ucppPoolVotingThresholds = PoolVotingThresholds + { pvtMotionNoConfidence = bfgPVTMotionNoConfidence + , pvtCommitteeNormal = bfgPVTCommitteeNormal + , pvtCommitteeNoConfidence = bfgPVTCommitteeNoConfidence + , pvtHardForkInitiation = bfgPVTHardForkInitiation + , pvtPPSecurityGroup = bfgPVTPPSecurityGroup + } + , ucppDRepVotingThresholds = DRepVotingThresholds + { dvtMotionNoConfidence = bfgDVTMotionNoConfidence + , dvtCommitteeNormal = bfgDVTCommitteeNormal + , dvtCommitteeNoConfidence = bfgDVTCommitteeNoConfidence + , dvtUpdateToConstitution = bfgDVTUpdateToConstitution + , dvtHardForkInitiation = bfgDVTHardForkInitiation + , dvtPPNetworkGroup = bfgDVTPPNetworkGroup + , dvtPPEconomicGroup = bfgDVTPPEconomicGroup + , dvtPPTechnicalGroup = bfgDVTPPTechnicalGroup + , dvtPPGovGroup = bfgDVTPPGovGroup + , dvtTreasuryWithdrawal = bfgDVTTreasuryWithdrawal + } + , ucppCommitteeMinSize = bfgCommitteeMinSize + , ucppCommitteeMaxTermLength = bfgCommitteeMaxTermLength + , ucppGovActionLifetime = bfgGovActionLifetime + , ucppGovActionDeposit = bfgGovActionDeposit + , ucppDRepDeposit = bfgDRepDeposit + , ucppDRepActivity = bfgDRepActivity + , ucppMinFeeRefScriptCostPerByte = bfgMinFeeRevScriptCostPerByte + , ucppPlutusV3CostModel + } + pure conwayGenesis'{cgUpgradePParams=conwayParams} -- Shelley params shelleyParams = PParams $ ShelleyPParams - { sppMinFeeA = bfgMinFeeA - , sppMinFeeB = bfgMinFeeB + { sppTxFeePerByte = CoinPerByte $ compactCoinOrError bfgMinFeeA + , sppTxFeeFixed = compactCoinOrError bfgMinFeeB , sppMaxBBSize = bfgMaxBlockSize , sppMaxTxSize = bfgMaxTxSize , sppMaxBHSize = bfgMaxBlockHeaderSize - , sppKeyDeposit = bfgKeyDeposit - , sppPoolDeposit = toCompactPartial bfgPoolDeposit + , sppKeyDeposit = compactCoinOrError bfgKeyDeposit + , sppPoolDeposit = compactCoinOrError bfgPoolDeposit , sppEMax = bfgEMax , sppNOpt = bfgNOpt , sppA0 = bfgA0 @@ -262,21 +276,20 @@ blockfrostToGenesis (shelleyGenesis', alonzoGenesis', conwayGenesis', dijkstraGe { pvMajor = bfgProtocolMajorVer , pvMinor = bfgProtocolMinorVer } - , sppMinUTxOValue = bfgMinUTxO - , sppMinPoolCost = bfgMinPoolCost + , sppMinUTxOValue = compactCoinOrError bfgMinUTxO + , sppMinPoolCost = compactCoinOrError bfgMinPoolCost } - shelleyGenesis = shelleyGenesis'{sgProtocolParams=shelleyParams} + shelleyGenesis = pure shelleyGenesis'{sgProtocolParams=shelleyParams} -- TODO dijkstra: there are no dijkstra params on blockfrost - dijkstraGenesis = dijkstraGenesis' + dijkstraGenesis = pure dijkstraGenesis' -- | Trims cost model to the initial number of parameters. The cost models in geneses can't -- have more parameters than the initial number. -trimCostModelToInitial :: Language -> CostModel -> CostModel +trimCostModelToInitial :: HasCallStack => MonadThrow m => Language -> CostModel -> m CostModel trimCostModelToInitial lang cm = do let paramsCount = CostModels.costModelInitParamCount lang - either (error . ("Testnet.Blockfrost: Cost model trimming failure: " <>) . show) id + either (error . ("Testnet.Blockfrost: Cost model trimming failure: " <>) . show) pure . CostModels.mkCostModel lang . take paramsCount $ CostModels.getCostModelParams cm - diff --git a/cardano-testnet/src/Testnet/Components/Configuration.hs b/cardano-testnet/src/Testnet/Components/Configuration.hs index 1e5bd4f939f..b072e38a545 100644 --- a/cardano-testnet/src/Testnet/Components/Configuration.hs +++ b/cardano-testnet/src/Testnet/Components/Configuration.hs @@ -120,7 +120,7 @@ getShelleyGenesisHash path key = do -- | For an unknown reason, CLI commands are a lot slower on Windows than on Linux and -- MacOS. We need to allow a lot more time to set up a testnet. -startTimeOffsetSeconds :: DTC.NominalDiffTime +startTimeOffsetSeconds :: Int startTimeOffsetSeconds = if OS.isWin32 then 90 else 15 -- | A start time and 'ShelleyGenesis' value that are fit to pass to 'cardanoTestnet' @@ -132,7 +132,7 @@ getDefaultShelleyGenesis :: () -> m ShelleyGenesis getDefaultShelleyGenesis asbe maxSupply opts = do currentTime <- liftIOAnnotated DTC.getCurrentTime - let startTime = DTC.addUTCTime startTimeOffsetSeconds currentTime + let startTime = DTC.addUTCTime (fromIntegral startTimeOffsetSeconds) currentTime return $ Defaults.defaultShelleyGenesis asbe startTime maxSupply opts -- | An 'AlonzoGenesis' value that is fit to pass to 'cardanoTestnet' @@ -198,7 +198,7 @@ createSPOGenesisAndFiles let era = toCardanoEra sbe currentTime <- liftIOAnnotated DTC.getCurrentTime - let startTime = DTC.addUTCTime startTimeOffsetSeconds currentTime + let startTime = DTC.addUTCTime (fromIntegral startTimeOffsetSeconds) currentTime execCli_ $ [ eraToString sbe, "genesis", "create-testnet-data" ] @@ -267,9 +267,9 @@ resolveOnChainParams onChainParams geneses = case onChainParams of OnChainParamsFile file -> do eParams <- eitherDecode <$> liftIOAnnotated (LBS.readFile file) case eParams of - Right params -> pure $ blockfrostToGenesis geneses params + Right params -> blockfrostToGenesis geneses params Left err -> throwM $ BlockfrostParamsDecodeError file err OnChainParamsMainnet -> do mainnetParams <- liftIOAnnotated $ HTTP.getResponseBody <$> HTTP.httpJSON mainnetParamsRequest - pure $ blockfrostToGenesis geneses mainnetParams + blockfrostToGenesis geneses mainnetParams diff --git a/cardano-testnet/src/Testnet/Components/Query.hs b/cardano-testnet/src/Testnet/Components/Query.hs index 3313798edf2..151480b78a3 100644 --- a/cardano-testnet/src/Testnet/Components/Query.hs +++ b/cardano-testnet/src/Testnet/Components/Query.hs @@ -350,7 +350,7 @@ findLargestUtxoWithAddress epochStateView sbe address = withFrozenCallStack $ do . listToMaybe $ sortOn (\(_, TxOut _ txOutValue _ _) -> Down $ txOutValueToLovelace txOutValue) utxos --- | Retrieve the largest utxo with a multi-asset +-- | Retrieve the largest utxo with a multi-asset findLargestMultiAssetUtxoWithAddress :: HasCallStack => MonadAssertion m @@ -363,11 +363,11 @@ findLargestMultiAssetUtxoWithAddress findLargestMultiAssetUtxoWithAddress epochStateView sbe address = withFrozenCallStack $ do utxos <- toList <$> findUtxosWithAddress epochStateView sbe address let sortedUTxOs = sortOn (\(_, TxOut _ txOutValue _ _) -> Down $ txOutValueToLovelace txOutValue) utxos - utxosWithMas = filter (\(_,TxOut _ txOutValue _ _) -> isMultiAssetPresent txOutValue) sortedUTxOs + utxosWithMas = filter (\(_,TxOut _ txOutValue _ _) -> isMultiAssetPresent txOutValue) sortedUTxOs pure $ listToMaybe utxosWithMas -isMultiAssetPresent :: TxOutValue era -> Bool -isMultiAssetPresent v = +isMultiAssetPresent :: TxOutValue era -> Bool +isMultiAssetPresent v = Map.size (valueToPolicyAssets $ txOutValueToValue v) > 0 @@ -421,7 +421,7 @@ checkDRepState => MonadTest m => EpochStateView -> ShelleyBasedEra ConwayEra -- ^ The era in which the test runs - -> (Map (Credential 'DRepRole) + -> (Map (Credential DRepRole) DRepState -> Maybe a) -- ^ A function that checks whether the DRep state is correct or up to date -- and potentially inspects it. diff --git a/cardano-testnet/src/Testnet/Defaults.hs b/cardano-testnet/src/Testnet/Defaults.hs index e93e7b17aa1..c9c92dea822 100644 --- a/cardano-testnet/src/Testnet/Defaults.hs +++ b/cardano-testnet/src/Testnet/Defaults.hs @@ -65,17 +65,17 @@ import qualified Cardano.Ledger.Shelley as Ledger import Cardano.Ledger.Shelley.Genesis import Cardano.Network.PeerSelection.Bootstrap (UseBootstrapPeers (..)) import Cardano.Network.PeerSelection.PeerTrustable (PeerTrustable (..)) -import Cardano.Node.Configuration.TopologyP2P (LocalRootPeersGroup (..), - LocalRootPeersGroups (..), NetworkTopology (..), PublicRootPeers (..), - RootConfig (..)) -import qualified Cardano.Node.Configuration.TopologyP2P as P2P -import qualified Cardano.Node.Configuration.TopologyP2P as Topology import Cardano.Tracing.Config -import Ouroboros.Network.NodeToNode (DiffusionMode (..)) +import Cardano.Network.NodeToNode (DiffusionMode (..)) import Ouroboros.Network.PeerSelection (AfterSlot (..), PeerAdvertise (..), RelayAccessPoint (..), UseLedgerPeers (..)) import Ouroboros.Network.PeerSelection.State.LocalRootPeers (HotValency (..), WarmValency (..)) +import Ouroboros.Network.Diffusion.Topology (LocalRootPeersGroup (..), + LocalRootPeersGroups (..), NetworkTopology (..), PublicRootPeers (..), + RootConfig (..), LocalRoots (..)) +import Cardano.Network.Diffusion.Topology (CardanoNetworkTopology) +import Ouroboros.Network.ConnectionManager.Types (Provenance (..)) import Prelude @@ -466,27 +466,30 @@ mkProtVer (majorProtVer, minorProtVer) = ppProtocolVersionL' :: Lens' (PParams Ledger.ShelleyEra) ProtVer ppProtocolVersionL' = Ledger.ppLensHKD . Ledger.hkdProtocolVersionL @Ledger.ShelleyEra @Identity -defaultMainnetTopology :: Topology.NetworkTopology RelayAccessPoint +defaultMainnetTopology :: CardanoNetworkTopology defaultMainnetTopology = - Topology.RealNodeTopology { - ntLocalRootPeersGroups = LocalRootPeersGroups [ + NetworkTopology { + localRootPeersGroups = LocalRootPeersGroups [ LocalRootPeersGroup { - localRoots = RootConfig { - rootAccessPoints = - [ RelayAccessDomain "relays-new.cardano-mainnet.iohk.io" 3_001 - ], - rootAdvertise = DoAdvertisePeer + localRoots = LocalRoots { + rootConfig = RootConfig { + rootAccessPoints = + [ RelayAccessDomain "relays-new.cardano-mainnet.iohk.io" 3_001 + ], + rootAdvertise = DoAdvertisePeer + }, + provenance = Outbound }, hotValency = 2, warmValency = 2, - trustable = IsTrustable, - rootDiffusionMode = InitiatorAndResponderDiffusionMode + rootDiffusionMode = InitiatorAndResponderDiffusionMode, + extraFlags = IsTrustable } ], - ntPublicRootPeers = [], - ntUseLedgerPeers = UseLedgerPeers Always, - ntUseBootstrapPeers = DontUseBootstrapPeers, - ntPeerSnapshotPath = Nothing + extraConfig = DontUseBootstrapPeers, + publicRootPeers = [], + useLedgerPeers = UseLedgerPeers Always, + peerSnapshotPath = Nothing } defaultGenesisFilepath :: CardanoEra a -> FilePath @@ -596,9 +599,9 @@ defaultUtxoKeys n = simpleScript :: Text -> Text -simpleScript signerRequired = +simpleScript signerRequired = "{ \"scripts\": [ { \"keyHash\": \"" <> signerRequired <> "\", \"type\": \"sig\" } ], \"type\": \"all\" }" - + plutusV2Script :: Text plutusV2Script = @@ -620,30 +623,33 @@ plutusV2StakeScript :: Text plutusV2StakeScript = "{ \"type\": \"PlutusScriptV2\", \"description\": \"\", \"cborHex\": \"5907655907620100003232323232323232323232323232332232323232322232325335320193333573466e1cd55cea80124000466442466002006004646464646464646464646464646666ae68cdc39aab9d500c480008cccccccccccc88888888888848cccccccccccc00403403002c02802402001c01801401000c008cd4050054d5d0a80619a80a00a9aba1500b33501401635742a014666aa030eb9405cd5d0a804999aa80c3ae501735742a01066a02803e6ae85401cccd54060081d69aba150063232323333573466e1cd55cea801240004664424660020060046464646666ae68cdc39aab9d5002480008cc8848cc00400c008cd40a9d69aba15002302b357426ae8940088c98c80b4cd5ce01701681589aab9e5001137540026ae854008c8c8c8cccd5cd19b8735573aa004900011991091980080180119a8153ad35742a00460566ae84d5d1280111931901699ab9c02e02d02b135573ca00226ea8004d5d09aba2500223263202933573805405204e26aae7940044dd50009aba1500533501475c6ae854010ccd540600708004d5d0a801999aa80c3ae200135742a004603c6ae84d5d1280111931901299ab9c026025023135744a00226ae8940044d5d1280089aba25001135744a00226ae8940044d5d1280089aba25001135744a00226ae8940044d55cf280089baa00135742a004601c6ae84d5d1280111931900b99ab9c018017015101613263201633573892010350543500016135573ca00226ea800448c88c008dd6000990009aa80a911999aab9f0012500a233500930043574200460066ae880080508c8c8cccd5cd19b8735573aa004900011991091980080180118061aba150023005357426ae8940088c98c8050cd5ce00a80a00909aab9e5001137540024646464646666ae68cdc39aab9d5004480008cccc888848cccc00401401000c008c8c8c8cccd5cd19b8735573aa0049000119910919800801801180a9aba1500233500f014357426ae8940088c98c8064cd5ce00d00c80b89aab9e5001137540026ae854010ccd54021d728039aba150033232323333573466e1d4005200423212223002004357426aae79400c8cccd5cd19b875002480088c84888c004010dd71aba135573ca00846666ae68cdc3a801a400042444006464c6403666ae7007006c06406005c4d55cea80089baa00135742a00466a016eb8d5d09aba2500223263201533573802c02a02626ae8940044d5d1280089aab9e500113754002266aa002eb9d6889119118011bab00132001355012223233335573e0044a010466a00e66442466002006004600c6aae754008c014d55cf280118021aba200301213574200222440042442446600200800624464646666ae68cdc3a800a40004642446004006600a6ae84d55cf280191999ab9a3370ea0049001109100091931900819ab9c01101000e00d135573aa00226ea80048c8c8cccd5cd19b875001480188c848888c010014c01cd5d09aab9e500323333573466e1d400920042321222230020053009357426aae7940108cccd5cd19b875003480088c848888c004014c01cd5d09aab9e500523333573466e1d40112000232122223003005375c6ae84d55cf280311931900819ab9c01101000e00d00c00b135573aa00226ea80048c8c8cccd5cd19b8735573aa004900011991091980080180118029aba15002375a6ae84d5d1280111931900619ab9c00d00c00a135573ca00226ea80048c8cccd5cd19b8735573aa002900011bae357426aae7940088c98c8028cd5ce00580500409baa001232323232323333573466e1d4005200c21222222200323333573466e1d4009200a21222222200423333573466e1d400d2008233221222222233001009008375c6ae854014dd69aba135744a00a46666ae68cdc3a8022400c4664424444444660040120106eb8d5d0a8039bae357426ae89401c8cccd5cd19b875005480108cc8848888888cc018024020c030d5d0a8049bae357426ae8940248cccd5cd19b875006480088c848888888c01c020c034d5d09aab9e500b23333573466e1d401d2000232122222223005008300e357426aae7940308c98c804ccd5ce00a00980880800780700680600589aab9d5004135573ca00626aae7940084d55cf280089baa0012323232323333573466e1d400520022333222122333001005004003375a6ae854010dd69aba15003375a6ae84d5d1280191999ab9a3370ea0049000119091180100198041aba135573ca00c464c6401866ae700340300280244d55cea80189aba25001135573ca00226ea80048c8c8cccd5cd19b875001480088c8488c00400cdd71aba135573ca00646666ae68cdc3a8012400046424460040066eb8d5d09aab9e500423263200933573801401200e00c26aae7540044dd500089119191999ab9a3370ea00290021091100091999ab9a3370ea00490011190911180180218031aba135573ca00846666ae68cdc3a801a400042444004464c6401466ae7002c02802001c0184d55cea80089baa0012323333573466e1d40052002200723333573466e1d40092000212200123263200633573800e00c00800626aae74dd5000a4c2400292010350543100122002112323001001223300330020020011\" }" -defaultP2PTopology :: [adr] -> P2P.NetworkTopology adr -defaultP2PTopology addresses = P2P.RealNodeTopology - { ntLocalRootPeersGroups = LocalRootPeersGroups +defaultP2PTopology :: [RelayAccessPoint] -> CardanoNetworkTopology +defaultP2PTopology addresses = NetworkTopology + { localRootPeersGroups = LocalRootPeersGroups { groups = [ LocalRootPeersGroup - { localRoots = RootConfig - { rootAccessPoints = addresses - , rootAdvertise = DoNotAdvertisePeer + { localRoots = LocalRoots + { rootConfig = RootConfig + { rootAccessPoints = addresses + , rootAdvertise = DoNotAdvertisePeer + } + , provenance = Outbound } , hotValency = HotValency $ length addresses , warmValency = WarmValency $ length addresses - , trustable = IsTrustable , rootDiffusionMode = InitiatorAndResponderDiffusionMode + , extraFlags = IsTrustable } ] } - , ntPublicRootPeers = + , extraConfig = DontUseBootstrapPeers + , publicRootPeers = [ PublicRootPeers RootConfig { rootAccessPoints = [] , rootAdvertise = DoNotAdvertisePeer } ] - , ntUseLedgerPeers = DontUseLedgerPeers - , ntUseBootstrapPeers = DontUseBootstrapPeers - , ntPeerSnapshotPath = Nothing + , useLedgerPeers = DontUseLedgerPeers + , peerSnapshotPath = Nothing } diff --git a/cardano-testnet/src/Testnet/Process/Cli/SPO.hs b/cardano-testnet/src/Testnet/Process/Cli/SPO.hs index a5856dc6fc2..703ff345b65 100644 --- a/cardano-testnet/src/Testnet/Process/Cli/SPO.hs +++ b/cardano-testnet/src/Testnet/Process/Cli/SPO.hs @@ -172,7 +172,7 @@ checkStakeKeyRegistered tempAbsP nodeConfigFile sPath terminationEpoch execConfi accountState ^. L.balanceAccountStateL . to L.fromCompact -toApiStakeAddress :: L.Network -> L.Credential 'L.Staking -> StakeAddress +toApiStakeAddress :: L.Network -> L.Credential L.Staking -> StakeAddress toApiStakeAddress = StakeAddress diff --git a/cardano-testnet/src/Testnet/Process/Run.hs b/cardano-testnet/src/Testnet/Process/Run.hs index c03a8c02efc..2f2213c63d7 100644 --- a/cardano-testnet/src/Testnet/Process/Run.hs +++ b/cardano-testnet/src/Testnet/Process/Run.hs @@ -9,9 +9,12 @@ module Testnet.Process.Run , execCreateScriptContext , execCreateScriptContext' , execCliStdoutToJson + , execKESAgentControl + , execKESAgentControl_ , initiateProcess , procCli , procNode + , procKESAgent , procSubmitApi , procChairman , mkExecConfig @@ -145,7 +148,43 @@ procNode -- ^ Arguments to the CLI command -> m CreateProcess -- ^ Captured stdout -procNode = GHC.withFrozenCallStack $ H.procFlex "cardano-node" "CARDANO_NODE" +procNode args = GHC.withFrozenCallStack $ do + process <- H.procFlex "cardano-node" "CARDANO_NODE" args + H.annotate . ("━━━━ command ━━━━\n" <>)$ + case IO.cmdspec process of + IO.ShellCommand cmd -> cmd + IO.RawCommand cmd cmdArgs -> cmd <> " " <> unwords cmdArgs + pure process + +-- | Create a 'CreateProcess' describing how to start the kes-agent process +-- and an argument list. +procKESAgent + :: (MonadTest m, MonadCatch m, MonadIO m, HasCallStack) + => [String] + -- ^ Arguments to the CLI command + -> m CreateProcess + -- ^ Captured stdout +procKESAgent args = GHC.withFrozenCallStack $ do + process <- H.procFlex "kes-agent" "KES_AGENT" args + H.annotate . ("━━━━ command ━━━━\n" <>)$ + case IO.cmdspec process of + IO.ShellCommand cmd -> cmd + IO.RawCommand cmd cmdArgs -> cmd <> " " <> unwords cmdArgs + pure process + +-- | Run kes-agent-control, returning the stdout +execKESAgentControl + :: (MonadTest m, MonadCatch m, MonadIO m, HasCallStack) + => [String] + -> m String +execKESAgentControl = GHC.withFrozenCallStack $ H.execFlex "kes-agent-control" "KES_AGENT_CONTROL" + +-- | Run kes-agent-control, discarding return value +execKESAgentControl_ + :: (MonadTest m, MonadCatch m, MonadIO m, HasCallStack) + => [String] + -> m () +execKESAgentControl_ = GHC.withFrozenCallStack $ void . execKESAgentControl -- | Create a 'CreateProcess' describing how to start the cardano-submit-api process -- and an argument list. @@ -240,4 +279,3 @@ resourceAndIOExceptionHandlers :: Applicative m => [Handler m ProcessError] resourceAndIOExceptionHandlers = [ Handler $ pure . ProcessIOException , Handler $ pure . ResourceException ] - diff --git a/cardano-testnet/src/Testnet/Process/RunIO.hs b/cardano-testnet/src/Testnet/Process/RunIO.hs index b480bbc4d37..2794ccb68be 100644 --- a/cardano-testnet/src/Testnet/Process/RunIO.hs +++ b/cardano-testnet/src/Testnet/Process/RunIO.hs @@ -10,6 +10,9 @@ module Testnet.Process.RunIO , execCli_ , mkExecConfig , procNode + , procKESAgent + , execKESAgentControl_ + , procFlex , liftIOAnnotated ) where @@ -269,6 +272,24 @@ procNode -- ^ Captured stdout procNode = GHC.withFrozenCallStack $ procFlex "cardano-node" "CARDANO_NODE" +-- | Create a 'CreateProcess' describing how to start the kes-agent process +-- and an argument list. +procKESAgent + :: (HasCallStack) + => [String] + -- ^ Arguments to the CLI command + -> RIO env CreateProcess + -- ^ Captured stdout +procKESAgent = GHC.withFrozenCallStack $ procFlex "kes-agent" "KES_AGENT" + +-- | Run kes-agent-control, discarding return value +execKESAgentControl_ + :: HasCallStack + => MonadIO m + => [String] + -> m () +execKESAgentControl_ = GHC.withFrozenCallStack $ void . execFlex' defaultExecConfig "kes-agent-control" "KES_AGENT_CONTROL" + -- | Create a 'CreateProcess' describing how to start a process given the Cabal package name -- corresponding to the executable, an environment variable pointing to the executable, diff --git a/cardano-testnet/src/Testnet/Runtime.hs b/cardano-testnet/src/Testnet/Runtime.hs index 1ef96d658e3..b3dca04f111 100644 --- a/cardano-testnet/src/Testnet/Runtime.hs +++ b/cardano-testnet/src/Testnet/Runtime.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} @@ -12,6 +13,8 @@ module Testnet.Runtime ( startNode + , initAndStartKESAgent + , TestnetKESAgentArgs(..) , startLedgerNewEpochStateLogging , NodeStartFailure (..) -- Exposed for testing purposes @@ -52,9 +55,9 @@ import System.Process (waitForProcess) import Testnet.Filepath import qualified Testnet.Ping as Ping import Testnet.Process.Run (ProcessError (..), initiateProcess) -import Testnet.Process.RunIO (liftIOAnnotated, procNode) +import Testnet.Process.RunIO (liftIOAnnotated, procNode, procKESAgent, execKESAgentControl_, execCli_) import Testnet.Types (TestnetNode (..), TestnetRuntime (configurationFile), - showIpv4Address, testnetSprockets) + showIpv4Address, testnetSprockets, TestnetKESAgent(..)) import Hedgehog.Extras.Stock.IO.Network.Sprocket (Sprocket (..)) import qualified Hedgehog.Extras.Stock.IO.Network.Sprocket as H @@ -220,41 +223,213 @@ startNode tp node ipv4 port _testnetMagic nodeCmd = GHC.withFrozenCallStack $ do , nodeStderr = nodeStderrFile , nodeProcessHandle = hProcess } + +-- | Start a kes-agent for a particular node +startKESAgent + :: HasCallStack + => MonadResource m + => MonadCatch m + => MonadFail m + => TmpAbsolutePath + -- ^ The temporary absolute path + -> String + -- ^ The name of the node + -> [String] + -- ^ additional CLI options for 'kes-agent` + -> ExceptT NodeStartFailure m TestnetKESAgent +startKESAgent tp node args = GHC.withFrozenCallStack $ do + let tempBaseAbsPath = makeTmpBaseAbsPath tp + socketDir = makeSocketDir tp + logDir = makeLogDir tp + kesAgentStr= "kes-agent" + + _ <- liftIO $ createDirectoryIfMissingNew $ logDir node kesAgentStr + void . liftIO $ createSubdirectoryIfMissingNew tempBaseAbsPath (socketDir node kesAgentStr) + + let nodeStdoutFile = logDir node kesAgentStr "stdout.log" + nodeStderrFile = logDir node kesAgentStr "stderr.log" + nodePidFile = logDir node kesAgentStr (node <> kesAgentStr <> ".pid") + serviceSocketRelPath = socketDir node kesAgentStr "service.sock" + controlSocketRelPath = socketDir node kesAgentStr "control.sock" + serviceSprocket = Sprocket tempBaseAbsPath serviceSocketRelPath + controlSprocket = Sprocket tempBaseAbsPath controlSocketRelPath + + hNodeStdout <- retryOpenFile nodeStdoutFile IO.WriteMode + hNodeStderr <- retryOpenFile nodeStderrFile IO.ReadWriteMode + + -- Sometimes the handles are not getting properly closed when node fails to start. This results in + -- operating system holding the file lock for longer than it's necessary. This in the end prevents retrying + -- node start and acquiring a lock for the same stderr/stdout files again. + closeHandlesOnError [hNodeStdout, hNodeStderr] $ do + + unless (List.length (H.sprocketArgumentName serviceSprocket) <= H.maxSprocketArgumentNameLength) $ + left MaxSprocketLengthExceededError + unless (List.length (H.sprocketArgumentName controlSprocket) <= H.maxSprocketArgumentNameLength) $ + left MaxSprocketLengthExceededError + + let kesAgentCmd = [ "run" + , "-s", tempBaseAbsPath serviceSocketRelPath + , "-c", tempBaseAbsPath controlSocketRelPath + ] ++ args + + kesAgentProcess <- newExceptT . fmap (first ExecutableRelatedFailure) . try $ runRIO () $ procKESAgent kesAgentCmd + + (Just stdIn, _, _, hProcess, _) + <- firstExceptT ProcessRelatedFailure $ initiateProcess + $ kesAgentProcess + { IO.std_in = IO.CreatePipe, IO.std_out = IO.UseHandle hNodeStdout + , IO.std_err = IO.UseHandle hNodeStderr + , IO.cwd = Just tempBaseAbsPath + } + + -- We force the evaluation of initiateProcess so we can be sure that + -- the process has started. This allows us to read stderr in order + -- to fail early on errors generated from the cardano-node binary. + pid <- liftIO (IO.getPid hProcess) + >>= hoistMaybe (NodeExecutableError $ "startKESAgent:" <+> pretty node <+> "'s process did not start.") + + -- We then log the pid in the temp dir structure. + liftIO $ IO.writeFile nodePidFile $ show pid + + -- Wait for the service and control sockets to be created + eServiceSprocketError <- + liftIOAnnotated $ + Ping.waitForSprocket + 120 -- timeout + 0.2 -- check interval + serviceSprocket + eControlSprocketError <- + liftIOAnnotated $ + Ping.waitForSprocket + 120 -- timeout + 0.2 -- check interval + controlSprocket + + -- If we do have anything on stderr, fail. + stdErrContents <- liftIO $ IO.readFile nodeStderrFile + unless (null stdErrContents) $ + throwError $ mkNodeNonEmptyStderrError stdErrContents + + -- No stderr and no socket? Fail. + firstExceptT + (\ioex -> + NodeExecutableError . hsep $ + ["Socket", pretty serviceSocketRelPath, "was not created after 120 seconds. There was no output on stderr. Exception:", prettyException ioex]) + $ hoistEither eServiceSprocketError + firstExceptT + (\ioex -> + NodeExecutableError . hsep $ + ["Socket", pretty controlSocketRelPath, "was not created after 120 seconds. There was no output on stderr. Exception:", prettyException ioex]) + $ hoistEither eControlSprocketError + + -- Ping node and fail on error + -- FIXME: pinging of the node is broken now, has the protocol changed? + -- Ping.pingNode (fromIntegral testnetMagic) sprocket + -- >>= (firstExceptT (NodeExecutableError . ("Ping error:" <+>) . prettyError) . hoistEither) + + pure $ TestnetKESAgent + { kesAgentName = node + , kesAgentPoolKeys = Nothing -- they're set in the function caller, if present + , kesAgentServiceSprocket= serviceSprocket + , kesAgentControlSprocket = controlSprocket + , kesAgentStdinHandle = stdIn + , kesAgentStdout = nodeStdoutFile + , kesAgentStderr = nodeStderrFile + , kesAgentProcessHandle = hProcess + } + +-- | Various file paths needed to start and initialised a 'kes-agent' process +data TestnetKESAgentArgs = + TestnetKESAgentArgs + { tkaaShelleyGenesisFile :: FilePath + , tkaaColdVKeyFile :: FilePath + , tkaaColdSKeyFile :: FilePath + , tkaaKesVKeyFile :: FilePath + , tkaaOpcertCounterFile :: FilePath + , tkaaOpcertFile :: FilePath + } + +-- | Start the 'kes-agent' process and initialise it to handle the kes keys +-- for a block-producing node. +initAndStartKESAgent + :: HasCallStack + => MonadResource m + => MonadCatch m + => MonadFail m + => + TmpAbsolutePath + -- ^ The temporary absolute path + -> String + -- ^ The name of the node + -> TestnetKESAgentArgs + -> ExceptT NodeStartFailure m TestnetKESAgent +initAndStartKESAgent tp nodeNameStr + TestnetKESAgentArgs{ tkaaShelleyGenesisFile + , tkaaColdVKeyFile + , tkaaColdSKeyFile + , tkaaKesVKeyFile + , tkaaOpcertCounterFile + , tkaaOpcertFile + } + = do + -- start the agent process + kesAgent@TestnetKESAgent{kesAgentControlSprocket} <- startKESAgent tp nodeNameStr + [ "--cold-verification-key", tkaaColdVKeyFile + , "--genesis-file", tkaaShelleyGenesisFile + ] + -- generate kes key + execKESAgentControl_ [ "gen-staged-key" + , "--kes-verification-key-file", tkaaKesVKeyFile + , "--control-address", H.sprocketSystemName kesAgentControlSprocket] + -- issue opcert + execCli_ + [ "node", "issue-op-cert" + , "--kes-verification-key-file", tkaaKesVKeyFile + , "--cold-signing-key-file", tkaaColdSKeyFile + , "--operational-certificate-issue-counter", tkaaOpcertCounterFile + , "--kes-period", "0" + , "--out-file", tkaaOpcertFile + ] + -- install the opcert into the kes-agent + execKESAgentControl_ [ "install-key" + , "--control-address", H.sprocketSystemName kesAgentControlSprocket + , "--opcert-file", tkaaOpcertFile] + pure kesAgent + +-- | Close provided list of handles when 'ExceptT' throws an error +closeHandlesOnError :: MonadIO m => [IO.Handle] -> ExceptT e m a -> ExceptT e m a +closeHandlesOnError handles action = + catchE action $ \e -> do + liftIO $ mapM_ IO.hClose handles + throwE e + +-- Sometimes even when we close the files manually, the operating system still holds the lock for some +-- reason. This is most prominent on MacOS. Therefore, as a last resort, instead of +-- failing the node startup procedure, we simply try to use a different file name for the logs, with +-- the suffix @-n.log@ where @n@ is an attempt number. +retryOpenFile :: MonadIO m + => MonadCatch m + => FilePath -- ^ path we're trying to open + -> IO.IOMode + -> ExceptT NodeStartFailure m IO.Handle +retryOpenFile fullPath mode = go 0 where - -- close provided list of handles when 'ExceptT' throws an error - closeHandlesOnError :: MonadIO m => [IO.Handle] -> ExceptT e m a -> ExceptT e m a - closeHandlesOnError handles action = - catchE action $ \e -> do - liftIOAnnotated $ mapM_ IO.hClose handles - throwE e - - -- Sometimes even when we close the files manually, the operating system still holds the lock for some - -- reason. This is most prominent on MacOS. Therefore, as a last resort, instead of - -- failing the node startup procedure, we simply try to use a different file name for the logs, with - -- the suffix @-n.log@ where @n@ is an attempt number. - retryOpenFile :: MonadIO m - => MonadCatch m - => FilePath -- ^ path we're trying to open - -> IO.IOMode - -> ExceptT NodeStartFailure m IO.Handle - retryOpenFile fullPath mode = go 0 - where - go :: MonadIO m - => MonadCatch m - => Int - -> ExceptT NodeStartFailure m IO.Handle - go n = do - let (path, extension) = splitExtension fullPath - path' = if n > 0 - then path <> "-" <> show n <> extension - else fullPath - r <- fmap (first FileRelatedFailure) . try . liftIOAnnotated $ IO.openFile path' mode - case r of - Right h -> pure h - Left e - -- give up after 1000 attempts - | n >= 1000 -> throwE e - | otherwise -> go (n + 1) + go :: MonadIO m + => MonadCatch m + => Int + -> ExceptT NodeStartFailure m IO.Handle + go n = do + let (path, extension) = splitExtension fullPath + path' = if n > 0 + then path <> "-" <> show n <> extension + else fullPath + r <- fmap (first FileRelatedFailure) . try . liftIOAnnotated $ IO.openFile path' mode + case r of + Right h -> pure h + Left e + -- give up after 1000 attempts + | n >= 1000 -> throwE e + | otherwise -> go (n + 1) diff --git a/cardano-testnet/src/Testnet/Start/Cardano.hs b/cardano-testnet/src/Testnet/Start/Cardano.hs index 4fb0f28242a..cb754d65516 100644 --- a/cardano-testnet/src/Testnet/Start/Cardano.hs +++ b/cardano-testnet/src/Testnet/Start/Cardano.hs @@ -35,11 +35,11 @@ import qualified Cardano.Api.Byron as Byron import Cardano.CLI.Type.Common (SigningKeyFile) import Cardano.Node.Configuration.NodeAddress (NodeAddress' (..), - NodeHostIPv4Address (..)) -import qualified Cardano.Node.Configuration.TopologyP2P as P2P + NodeHostIPv4Address (..), PortNumber) import Cardano.Prelude (NonEmpty ((:|)), canonicalEncodePretty) import Cardano.TxGenerator.Setup.NixService (NixServiceOptions (..), NodeDescription (..)) import Ouroboros.Network.PeerSelection.RelayAccessPoint (RelayAccessPoint (..)) +import Cardano.Network.Diffusion.Topology (CardanoNetworkTopology) import Prelude hiding (lines) @@ -78,8 +78,9 @@ import Testnet.Start.Types import Testnet.Types as TR hiding (shelleyGenesis) import qualified Hedgehog.Extras as H -import qualified Hedgehog.Extras.Stock.IO.Network.Port as H +import Hedgehog.Extras.Stock (sprocketSystemName) import Hedgehog.Internal.Property (failException) +import qualified Hedgehog.Extras.Stock.IO.Network.Port as H import RIO (MonadUnliftIO, RIO (..), runRIO, throwString, timeout) import RIO.Orphans (ResourceMap) @@ -106,6 +107,7 @@ createTestnetEnv :: () => HasCallStack => MonadIO m => MonadThrow m + => MonadFail m => CardanoTestnetOptions -> GenesisOptions -> CreateEnvOptions @@ -141,14 +143,24 @@ createTestnetEnv liftIOAnnotated . LBS.writeFile configurationFile $ A.encodePretty $ Object config - -- Create network topology, with abstract IDs in lieu of addresses + portNumbers <- forM (NEL.zip (1 :| [2..]) cardanoNodes) + (\(i, _nodeOption) -> (i,) <$> H.randomPort testnetDefaultIpv4Address) + + let portNumbersMap = Map.fromList (NEL.toList portNumbers) + + -- Create network topology and write port files let nodeIds = fst <$> NEL.zip (1 :| [2..]) cardanoNodes forM_ nodeIds $ \i -> do let nodeDataDir = tmpAbsPath Defaults.defaultNodeDataDir i liftIOAnnotated $ IO.createDirectoryIfMissing True nodeDataDir - let producers = NodeId <$> NEL.filter (/= i) nodeIds - topology = Defaults.defaultP2PTopology producers + -- Write port file + case Map.lookup i portNumbersMap of + Just port -> liftIOAnnotated $ writeFile (nodeDataDir "port") (show port) + Nothing -> error $ "Port not found for node " <> show i + + producers <- mapM (idToRemoteAddressP2P portNumbersMap) $ NodeId <$> NEL.filter (/= i) nodeIds + let topology = Defaults.defaultP2PTopology producers liftIOAnnotated . LBS.writeFile (nodeDataDir "topology.json") $ A.encodePretty topology -- | Starts a number of nodes, as configured by the value of the 'cardanoNodes' @@ -235,6 +247,7 @@ cardanoTestnet let CardanoTestnetOptions { cardanoEnableNewEpochStateLogging=enableNewEpochStateLogging , cardanoNodes + , cardanoKESSource } = testnetOptions nPools = cardanoNumPools testnetOptions nodeConfigFile = tmpAbsPath "configuration.yaml" @@ -266,45 +279,30 @@ cardanoTestnet , paymentKeyInfoAddr = Text.pack paymentAddr } - portNumbersWithNodeOptions <- forM cardanoNodes - (\nodeOption -> (nodeOption,) <$> H.randomPort testnetDefaultIpv4Address) - - let portNumbers = NEL.zip (1 :| [2..]) $ snd <$> portNumbersWithNodeOptions - portNumbersMap = Map.fromList (NEL.toList portNumbers) - - idToRemoteAddressP2P :: () - => MonadIO m - => HasCallStack - => NodeId -> m RelayAccessPoint - idToRemoteAddressP2P (NodeId i) = case Map.lookup i portNumbersMap of - Just port -> pure $ RelayAccessAddress - (showIpv4Address testnetDefaultIpv4Address) - port - Nothing -> do - throwString $ "Found node id that was unaccounted for: " ++ show i - - forM_ portNumbers $ \(i, portNumber) -> do + -- Read port numbers from disk (written by createTestnetEnv) + portNumbers <- forM (NEL.zip (1 :| [2..]) cardanoNodes) $ \(i, _nodeOption) -> do let nodeDataDir = tmpAbsPath Defaults.defaultNodeDataDir i - liftIOAnnotated $ IO.createDirectoryIfMissing True nodeDataDir - liftIOAnnotated $ writeFile (nodeDataDir "port") (show portNumber) - let topologyPath = tmpAbsPath Defaults.defaultNodeDataDir i "topology.json" + portPath = nodeDataDir "port" + portStr <- liftIOAnnotated $ readFile portPath + let port = read portStr :: PortNumber + let topologyPath = nodeDataDir "topology.json" tBytes <- liftIOAnnotated $ LBS.readFile topologyPath case eitherDecode tBytes of - Right (abstractTopology :: P2P.NetworkTopology NodeId) -> do - topology <- mapM idToRemoteAddressP2P abstractTopology - liftIOAnnotated $ LBS.writeFile topologyPath $ encode topology + Right (abstractTopology :: CardanoNetworkTopology) -> do + liftIOAnnotated $ LBS.writeFile topologyPath $ encode abstractTopology Left e -> do -- There can be multiple reasons for why both decodings have failed. -- Here we assume, very optimistically, that the user has already -- instantiated it with a concrete topology file. liftIOAnnotated . putStrLn $ "Could not decode topology file: " <> topologyPath <> ". This may be okay. Reason for decoding failure is:\n" ++ e + pure (i, port) -- If necessary, update the time stamps in Byron and Shelley Genesis files. -- This is a QoL feature so that users who edit their configuration files don't -- have to manually set up the start times themselves. when (updateTimestamps == UpdateTimestamps) $ do currentTime <- liftIOAnnotated DTC.getCurrentTime - let startTime = DTC.addUTCTime startTimeOffsetSeconds currentTime + let startTime = DTC.addUTCTime (fromIntegral startTimeOffsetSeconds) currentTime -- Update start time in Byron genesis file eByron <- runExceptT $ Byron.readGenesisData byronGenesisFile @@ -319,23 +317,51 @@ cardanoTestnet let shelleyGenesis' = shelleyGenesis{sgSystemStart = startTime} liftIOAnnotated . LBS.writeFile shelleyGenesisFile $ A.encodePretty shelleyGenesis' - eTestnetNodes <- forConcurrently (NEL.zip (1 :| [2..]) portNumbersWithNodeOptions) $ \(i, (nodeOptions, port)) -> do + let portNumbersMap = Map.fromList (NEL.toList portNumbers) + + eTestnetNodes <- forConcurrently (NEL.zip (1 :| [2..]) cardanoNodes) $ \(i, nodeOptions) -> do + port <- case Map.lookup i portNumbersMap of + Just p -> pure p + Nothing -> throwString $ "Port not found for node " <> show i let nodeName = Defaults.defaultNodeName i nodeDataDir = tmpAbsPath Defaults.defaultNodeDataDir i nodePoolKeysDir = tmpAbsPath Defaults.defaultSpoKeysDir i - let (mKeys, spoNodeCliArgs) = - case nodeOptions of - RelayNodeOptions{} -> (Nothing, []) - SpoNodeOptions{} -> (Just keys, shelleyCliArgs <> byronCliArgs) - where - shelleyCliArgs = [ "--shelley-kes-key", nodePoolKeysDir "kes.skey" - , "--shelley-vrf-key", unFile $ signingKey poolNodeKeysVrf - , "--shelley-operational-certificate", nodePoolKeysDir "opcert.cert" + (mKeys, spoNodeCliArgs) <- + case nodeOptions of + RelayNodeOptions{} -> pure (Nothing, []) + SpoNodeOptions{} -> do + -- depending on testnet configuration, either start a 'kes-agent' or use a key from disk + kesSourceCliArg <- + case cardanoKESSource of + UseKESKeyFile -> pure ["--shelley-kes-key", nodePoolKeysDir "kes.skey"] + UseKESSocket -> do + -- wait startTimeOffsetSeconds so that the startTime from shelly-genesis.json is not in the future, + -- as otherwise we will trigger an underflow in kes-agent with a negative time difference. + liftIOAnnotated $ threadDelay (startTimeOffsetSeconds * 1_000_000) + kesAgent <- runExceptT $ + initAndStartKESAgent (TmpAbsolutePath tmpAbsPath) nodeName + TestnetKESAgentArgs{ tkaaShelleyGenesisFile = shelleyGenesisFile + , tkaaColdVKeyFile = nodePoolKeysDir "cold.vkey" + , tkaaColdSKeyFile = nodePoolKeysDir "cold.skey" + , tkaaKesVKeyFile = nodePoolKeysDir "kes.vkey" + , tkaaOpcertCounterFile = nodePoolKeysDir "opcert.counter" + , tkaaOpcertFile = nodePoolKeysDir "opcert.cert" + } + case kesAgent of + Left e -> do + -- TODO: fail if could not start KES agent + liftIOAnnotated . putStrLn $ "Could not start KES agent: " <> show e + pure ["--shelley-kes-key", nodePoolKeysDir "kes.skey"] + Right (TestnetKESAgent{kesAgentServiceSprocket}) -> + pure ["--shelley-kes-agent-socket", sprocketSystemName kesAgentServiceSprocket] + let shelleyCliArgs = [ "--shelley-vrf-key", unFile $ signingKey poolNodeKeysVrf + , "--shelley-operational-certificate", nodePoolKeysDir "opcert.cert" + ] + byronCliArgs = [ "--byron-delegation-certificate", nodePoolKeysDir "byron-delegation.cert" + , "--byron-signing-key", nodePoolKeysDir "byron-delegate.key" ] - byronCliArgs = [ "--byron-delegation-certificate", nodePoolKeysDir "byron-delegation.cert" - , "--byron-signing-key", nodePoolKeysDir "byron-delegate.key" - ] - keys@SpoNodeKeys{poolNodeKeysVrf} = mkTestnetNodeKeyPaths i + keys@SpoNodeKeys{poolNodeKeysVrf} = mkTestnetNodeKeyPaths i + pure (Just keys, kesSourceCliArg <> shelleyCliArgs <> byronCliArgs) eRuntime <- runExceptT . retryOnAddressInUseError $ startNode (TmpAbsolutePath tmpAbsPath) nodeName testnetDefaultIpv4Address port testnetMagic $ @@ -465,6 +491,17 @@ cardanoTestnet throwString $ nodeName <> " was unable to produce any blocks for " <> show timeoutSeconds <> "s" +idToRemoteAddressP2P :: () + => MonadIO m + => HasCallStack + => Map.Map Int PortNumber -> NodeId -> m RelayAccessPoint +idToRemoteAddressP2P portNumbersMap (NodeId i) = case Map.lookup i portNumbersMap of + Just port -> pure $ RelayAccessAddress + (showIpv4Address testnetDefaultIpv4Address) + port + Nothing -> do + throwString $ "Found node id that was unaccounted for: " ++ show i + -- | A convenience wrapper around `createTestnetEnv` and `cardanoTestnet` createAndRunTestnet :: () => HasCallStack diff --git a/cardano-testnet/src/Testnet/Start/Types.hs b/cardano-testnet/src/Testnet/Start/Types.hs index 90acfc8abbc..6f988d2ec0e 100644 --- a/cardano-testnet/src/Testnet/Start/Types.hs +++ b/cardano-testnet/src/Testnet/Start/Types.hs @@ -34,6 +34,7 @@ module Testnet.Start.Types , UserProvidedData(..) , UserProvidedEnv(..) , UserProvidedGeneses(..) + , PraosCredentialsSource(..) , NodeLoggingFormat(..) , Conf(..) @@ -140,6 +141,12 @@ instance Default UserProvidedGeneses where def def +data PraosCredentialsSource = UseKESKeyFile | UseKESSocket + deriving (Eq, Show) + +instance Default PraosCredentialsSource where + def = UseKESKeyFile + -- | An HTTP request to get a file containing up-to-date mainnet on-chain parameters. -- The file should be formatted with Blockfrost format: -- https://docs.blockfrost.io/#tag/cardano--epochs/GET/epochs/latest/parameters @@ -187,6 +194,7 @@ data CardanoTestnetOptions = CardanoTestnetOptions , cardanoEnableNewEpochStateLogging :: Bool -- ^ if epoch state logging is enabled , cardanoEnableTxGenerator :: TxGeneratorSupport -- ^ Options regarding support for the tx-generator on the testnet (config generation, execution, etc.) , cardanoOutputDir :: UserProvidedEnv -- ^ The output directory where to store files, sockets, and so on. If unset, a temporary directory is used. + , cardanoKESSource :: PraosCredentialsSource } deriving (Eq, Show) -- | Path to the configuration file of the node, specified by the user @@ -223,6 +231,7 @@ instance Default CardanoTestnetOptions where , cardanoEnableNewEpochStateLogging = True , cardanoEnableTxGenerator = NoTxGeneratorSupport , cardanoOutputDir = def + , cardanoKESSource = def } -- | Options that are implemented by writing fields in the Shelley genesis file. diff --git a/cardano-testnet/src/Testnet/Types.hs b/cardano-testnet/src/Testnet/Types.hs index 07bfcf709fc..a075f3130ae 100644 --- a/cardano-testnet/src/Testnet/Types.hs +++ b/cardano-testnet/src/Testnet/Types.hs @@ -42,6 +42,7 @@ module Testnet.Types , getStartTime , testnetDefaultIpv4Address , showIpv4Address + , TestnetKESAgent(..) ) where import Cardano.Api @@ -142,6 +143,17 @@ data TestnetNode = TestnetNode , nodeProcessHandle :: !IO.ProcessHandle } +data TestnetKESAgent = TestnetKESAgent + { kesAgentName :: !String + , kesAgentPoolKeys :: Maybe SpoNodeKeys -- ^ Keys are only present for SPO nodes + , kesAgentServiceSprocket :: !Sprocket + , kesAgentControlSprocket :: !Sprocket + , kesAgentStdinHandle :: !IO.Handle + , kesAgentStdout :: !FilePath + , kesAgentStderr :: !FilePath + , kesAgentProcessHandle :: !IO.ProcessHandle + } + isTestnetNodeSpo :: TestnetNode -> Bool isTestnetNodeSpo = isJust . poolKeys @@ -236,4 +248,3 @@ testnetDefaultIpv4Address = tupleToHostAddress (127, 0, 0, 1) showIpv4Address :: IsString s => HostAddress -> s showIpv4Address address = fromString . intercalate "." $ show <$> [a,b,c,d] where (a,b,c,d) = hostAddressToTuple address - diff --git a/cardano-testnet/test/cardano-testnet-golden/files/golden/help.cli b/cardano-testnet/test/cardano-testnet-golden/files/golden/help.cli index 90b3c89d4b7..5a96fef6c1f 100644 --- a/cardano-testnet/test/cardano-testnet-golden/files/golden/help.cli +++ b/cardano-testnet/test/cardano-testnet-golden/files/golden/help.cli @@ -7,6 +7,7 @@ Usage: cardano-testnet cardano [--num-pool-nodes COUNT] [--enable-new-epoch-state-logging] [--generate-tx-generator-config] [--output-dir DIRECTORY] + [--use-kes-agent] [--testnet-magic INT] [--epoch-length SLOTS] [--slot-length SECONDS] @@ -24,6 +25,7 @@ Usage: cardano-testnet create-env [--num-pool-nodes COUNT] [--enable-new-epoch-state-logging] [--generate-tx-generator-config] [--output-dir DIRECTORY] + [--use-kes-agent] [--testnet-magic INT] [--epoch-length SLOTS] [--slot-length SECONDS] diff --git a/cardano-testnet/test/cardano-testnet-golden/files/golden/help/cardano.cli b/cardano-testnet/test/cardano-testnet-golden/files/golden/help/cardano.cli index a4ad433beaa..5f654325670 100644 --- a/cardano-testnet/test/cardano-testnet-golden/files/golden/help/cardano.cli +++ b/cardano-testnet/test/cardano-testnet-golden/files/golden/help/cardano.cli @@ -5,6 +5,7 @@ Usage: cardano-testnet cardano [--num-pool-nodes COUNT] [--enable-new-epoch-state-logging] [--generate-tx-generator-config] [--output-dir DIRECTORY] + [--use-kes-agent] [--testnet-magic INT] [--epoch-length SLOTS] [--slot-length SECONDS] @@ -37,6 +38,8 @@ Available options: --output-dir DIRECTORY Directory where to store files, sockets, and so on. It is created if it doesn't exist. If unset, a temporary directory is used. + --use-kes-agent Get Praos block forging credentials from kes-agent + via the default socket path --testnet-magic INT Specify a testnet magic id. (default: 42) --epoch-length SLOTS Epoch length, in number of slots. Ignored if a node environment is passed. (default: 500) diff --git a/cardano-testnet/test/cardano-testnet-golden/files/golden/help/create-env.cli b/cardano-testnet/test/cardano-testnet-golden/files/golden/help/create-env.cli index 6a9c346496e..61bf8a6c623 100644 --- a/cardano-testnet/test/cardano-testnet-golden/files/golden/help/create-env.cli +++ b/cardano-testnet/test/cardano-testnet-golden/files/golden/help/create-env.cli @@ -5,6 +5,7 @@ Usage: cardano-testnet create-env [--num-pool-nodes COUNT] [--enable-new-epoch-state-logging] [--generate-tx-generator-config] [--output-dir DIRECTORY] + [--use-kes-agent] [--testnet-magic INT] [--epoch-length SLOTS] [--slot-length SECONDS] @@ -36,6 +37,8 @@ Available options: --output-dir DIRECTORY Directory where to store files, sockets, and so on. It is created if it doesn't exist. If unset, a temporary directory is used. + --use-kes-agent Get Praos block forging credentials from kes-agent + via the default socket path --testnet-magic INT Specify a testnet magic id. (default: 42) --epoch-length SLOTS Epoch length, in number of slots. Ignored if a node environment is passed. (default: 500) diff --git a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Api/TxReferenceInputDatum.hs b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Api/TxReferenceInputDatum.hs index 3aa0e5b1a3b..11bb2908424 100644 --- a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Api/TxReferenceInputDatum.hs +++ b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Api/TxReferenceInputDatum.hs @@ -13,7 +13,6 @@ where import Cardano.Api hiding (txId) import qualified Cardano.Api.Ledger as L import qualified Cardano.Api.Network as Net -import qualified Cardano.Api.Network as Net.Tx import qualified Cardano.Api.UTxO as Utxo import Cardano.Testnet @@ -298,8 +297,9 @@ submitTx submitTx sbe connectionInfo tx = withFrozenCallStack $ H.evalIO (submitTxToNodeLocal connectionInfo (TxInMode sbe tx)) >>= \case - Net.Tx.SubmitFail reason -> pure . Left $ reason - Net.Tx.SubmitSuccess -> pure $ Right () + TxSubmitFail reason -> pure . Left $ reason + TxSubmitSuccess -> pure $ Right () + TxSubmitError err -> error $ "submitTxToNodeLocal connection error: " <> show err expectTxSubmissionSuccess :: HasCallStack diff --git a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Cli/KesPeriodInfo.hs b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Cli/KesPeriodInfo.hs index bdb2b0a1e33..16bdca8c89e 100644 --- a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Cli/KesPeriodInfo.hs +++ b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Cli/KesPeriodInfo.hs @@ -14,9 +14,9 @@ module Cardano.Testnet.Test.Cli.KesPeriodInfo import Cardano.Api as Api import Cardano.CLI.Type.Output -import Cardano.Node.Configuration.TopologyP2P import Cardano.Testnet import Cardano.Testnet.Test.Misc +import Ouroboros.Network.PeerSelection.RelayAccessPoint (RelayAccessPoint (..)) import Prelude diff --git a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Cli/LeadershipSchedule.hs b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Cli/LeadershipSchedule.hs index 6c44f25017b..70fbf358315 100644 --- a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Cli/LeadershipSchedule.hs +++ b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Cli/LeadershipSchedule.hs @@ -16,8 +16,8 @@ module Cardano.Testnet.Test.Cli.LeadershipSchedule import Cardano.Api import qualified Cardano.Api as Api -import Cardano.Node.Configuration.TopologyP2P import Cardano.Testnet +import Ouroboros.Network.PeerSelection.RelayAccessPoint (RelayAccessPoint (..)) import Prelude diff --git a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/DumpConfig.hs b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/DumpConfig.hs index 32f91d89bda..7d57787f183 100644 --- a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/DumpConfig.hs +++ b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/DumpConfig.hs @@ -56,7 +56,7 @@ hprop_dump_config = integrationRetryWorkspace 2 "dump-config-files" $ \tmpDir -> H.threadDelay $ double2Int $ realToFrac startTimeOffsetSeconds * 1_000_000 * 1.2 currentTime <- H.noteShowIO Time.getCurrentTime - startTime <- H.noteShow $ Time.addUTCTime startTimeOffsetSeconds currentTime + startTime <- H.noteShow $ Time.addUTCTime (fromIntegral startTimeOffsetSeconds) currentTime -- Update start time in Byron genesis file eByron <- runExceptT $ Byron.readGenesisData byronGenesisFile diff --git a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/ProposeNewConstitution.hs b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/ProposeNewConstitution.hs index 0ba47e4853d..d9385fe5db6 100644 --- a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/ProposeNewConstitution.hs +++ b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/ProposeNewConstitution.hs @@ -363,7 +363,7 @@ filterRatificationState c guardRailScriptHash (AnyNewEpochState sbe newEpochStat constitution = rState ^. Ledger.rsEnactStateL . Ledger.ensConstitutionL constitutionAnchorHash = Ledger.anchorDataHash $ Ledger.constitutionAnchor constitution L.ScriptHash constitutionScriptHash = fromMaybe (error "filterRatificationState: constitution does not have a guardrail script") - $ strictMaybeToMaybe $ constitution ^. Ledger.constitutionScriptL + $ strictMaybeToMaybe $ constitution ^. Ledger.constitutionGuardrailsScriptHashL Text.pack c == renderSafeHashAsHex constitutionAnchorHash && L.hashToTextAsHex constitutionScriptHash == Text.pack guardRailScriptHash ) diff --git a/cardano-tracer/cardano-tracer.cabal b/cardano-tracer/cardano-tracer.cabal index 33f5cd51571..48fc156cf2f 100644 --- a/cardano-tracer/cardano-tracer.cabal +++ b/cardano-tracer/cardano-tracer.cabal @@ -172,12 +172,13 @@ library , bimap , blaze-html , bytestring + , cardano-diffusion ^>= 1.0 , cborg ^>= 0.2.4 , containers , contra-tracer , directory , ekg-core - , ekg-forward >= 1.0 + , ekg-forward >= 1.2 , ekg-wai , extra , filepath @@ -186,9 +187,7 @@ library , network , network-mux >= 0.8 , optparse-applicative - , ouroboros-network ^>= 0.22.6 - , ouroboros-network-api ^>= 0.16 - , ouroboros-network-framework + , ouroboros-network:{api, framework} ^>= 1.1 , signal , slugify , smtp-mail ^>= 0.5 @@ -254,8 +253,7 @@ library demo-forwarder-lib , network , network-mux , optparse-applicative - , ouroboros-network-api - , ouroboros-network-framework + , ouroboros-network:{api, framework} , tasty-quickcheck , text , time @@ -299,7 +297,7 @@ library demo-acceptor-lib , filepath , generic-data , optparse-applicative - , ouroboros-network-api + , ouroboros-network:api , stm <2.5.2 || >=2.5.3 , tasty-quickcheck , text @@ -360,8 +358,7 @@ test-suite cardano-tracer-test , network , network-mux , optparse-applicative - , ouroboros-network-api - , ouroboros-network-framework + , ouroboros-network:{api, framework} , stm <2.5.2 || >=2.5.3 , tasty , tasty-quickcheck @@ -405,6 +402,7 @@ test-suite cardano-tracer-test-ext build-depends: aeson , async , bytestring + , cardano-diffusion , cardano-tracer , cborg , containers @@ -420,9 +418,7 @@ test-suite cardano-tracer-test-ext , network , network-mux , optparse-applicative - , ouroboros-network ^>= 0.22.6 - , ouroboros-network-api - , ouroboros-network-framework + , ouroboros-network:{api, framework} , process , QuickCheck , tasty diff --git a/cardano-tracer/configuration/metrics_help.json b/cardano-tracer/configuration/metrics_help.json index ba7420f6c13..8abcff03307 100644 --- a/cardano-tracer/configuration/metrics_help.json +++ b/cardano-tracer/configuration/metrics_help.json @@ -29,7 +29,6 @@ "cardano_version_major": "Cardano node version information", "cardano_version_minor": "Cardano node version information", "cardano_version_patch": "Cardano node version information", - "connectedPeers": "Number of connected peers", "density": "The actual number of blocks created over the maximum expected number of blocks that could be created over the span of the last @k@ blocks.", "epoch": "In which epoch is the tip of the current chain.", "forgedSlotLast": "Slot number of the last forged block", diff --git a/cardano-tracer/src/Cardano/Tracer/Acceptors/Server.hs b/cardano-tracer/src/Cardano/Tracer/Acceptors/Server.hs index 37c0470c7e2..ef70df89185 100644 --- a/cardano-tracer/src/Cardano/Tracer/Acceptors/Server.hs +++ b/cardano-tracer/src/Cardano/Tracer/Acceptors/Server.hs @@ -123,6 +123,8 @@ doListenToForwarderLocal doListenToForwarderLocal snocket address netMagic timeLimits app = do void $ Server.with snocket + nullTracer + Mux.nullTracers makeLocalBearer mempty -- LocalSocket does not need to be configured address @@ -153,6 +155,8 @@ doListenToForwarderSocket doListenToForwarderSocket snocket address netMagic timeLimits app = do void $ Server.with snocket + nullTracer + Mux.nullTracers makeSocketBearer mempty -- LocalSocket does not need to be configured address diff --git a/cardano-tracer/src/Cardano/Tracer/Handlers/ReForwarder.hs b/cardano-tracer/src/Cardano/Tracer/Handlers/ReForwarder.hs index b94e072ab29..b3ca20a6a6e 100644 --- a/cardano-tracer/src/Cardano/Tracer/Handlers/ReForwarder.hs +++ b/cardano-tracer/src/Cardano/Tracer/Handlers/ReForwarder.hs @@ -24,7 +24,7 @@ import Cardano.Tracer.Configuration import Cardano.Tracer.Handlers.Utils (normalizeNamespace) import Cardano.Tracer.MetaTrace import Ouroboros.Network.Magic (NetworkMagic (..)) -import Ouroboros.Network.NodeToClient (withIOManager) +import Cardano.Network.NodeToClient (withIOManager) import Control.Exception (SomeException (..)) import Control.Monad (when) diff --git a/cardano-tracer/test/Cardano/Tracer/Test/Forwarder.hs b/cardano-tracer/test/Cardano/Tracer/Test/Forwarder.hs index de95bef2a5d..90a277c8683 100644 --- a/cardano-tracer/test/Cardano/Tracer/Test/Forwarder.hs +++ b/cardano-tracer/test/Cardano/Tracer/Test/Forwarder.hs @@ -272,6 +272,8 @@ doListenToAcceptor TestSetup{..} withAsync (traceObjectsWriter sink) $ \_ -> void $ Server.with snocket + nullTracer + Mux.nullTracers muxBearer mempty address diff --git a/cardano-tracer/test/cardano-tracer-test-ext.hs b/cardano-tracer/test/cardano-tracer-test-ext.hs index 244e6b8c65f..2341361362b 100644 --- a/cardano-tracer/test/cardano-tracer-test-ext.hs +++ b/cardano-tracer/test/cardano-tracer-test-ext.hs @@ -9,7 +9,7 @@ import Cardano.Tracer.Test.ForwardingStressTest.Script import Cardano.Tracer.Test.ForwardingStressTest.Types import Cardano.Tracer.Test.Utils import Ouroboros.Network.Magic (NetworkMagic (..)) -import Ouroboros.Network.NodeToClient (withIOManager) +import Cardano.Network.NodeToClient (withIOManager) import Control.Concurrent (threadDelay) import Control.Exception diff --git a/flake.lock b/flake.lock index 7c09d075789..cf36655f340 100644 --- a/flake.lock +++ b/flake.lock @@ -3,11 +3,11 @@ "CHaP": { "flake": false, "locked": { - "lastModified": 1772623894, - "narHash": "sha256-95NCPKIcDnQ+vja6ofTsnFJKoH9AjT0opOj8zdGvWSw=", + "lastModified": 1773919794, + "narHash": "sha256-uIGg1jpaQUnGsL9ryTh10qCFDYQeowhnH7V+D/xHwmE=", "owner": "intersectmbo", "repo": "cardano-haskell-packages", - "rev": "e140e457e9c9db8591f0d8b0c35597ffb65955fc", + "rev": "8f90512a19f6921a1229abcdda3f15e815f141ab", "type": "github" }, "original": { @@ -273,11 +273,11 @@ "hackageNix_2": { "flake": false, "locked": { - "lastModified": 1772713531, - "narHash": "sha256-XPoLj/4nHhOc8tPEkrOhpmCjDvNZ7ZYcda0e4TY2RI4=", + "lastModified": 1771502057, + "narHash": "sha256-XwoLg6wftnU50KPn5jY4jtuGulyNPyspB4lSDSrmR1g=", "owner": "input-output-hk", "repo": "hackage.nix", - "rev": "ee54e2182f57a1e937b33eb64bcce67b81722ef7", + "rev": "e6bb05af1f45a616f534798263a5a13f2299e3bc", "type": "github" }, "original": { diff --git a/flake.nix b/flake.nix index edfb1e89323..142d99015f5 100644 --- a/flake.nix +++ b/flake.nix @@ -113,6 +113,13 @@ // final.cardanoLib // import ./nix/svclib.nix {inherit (final) pkgs;}; }) + (final: prev: { + # For musl builds, make sure the static `liburing.a` file is not deleted in `postInstall` + # ex: https://github.com/NixOS/nixpkgs/blob/f84a9816b2d5f7caade4b2fab16a66486abb7038/pkgs/by-name/li/liburing/package.nix#L43-L45 + liburing = prev.liburing.overrideAttrs (attrs: final.lib.optionalAttrs final.stdenv.hostPlatform.isMusl { + postInstall = builtins.replaceStrings [ "rm $out/lib/liburing*.a" ] [ "" ] attrs.postInstall; + }); + }) (import ./nix/pkgs.nix) abseilOverlay self.overlay @@ -126,7 +133,7 @@ // (with project.hsPkgs; { # Add some executables from other relevant packages inherit (bech32.components.exes) bech32; - inherit (ouroboros-consensus-cardano.components.exes) db-analyser db-synthesizer db-truncater snapshot-converter; + inherit (ouroboros-consensus.components.exes) db-analyser db-synthesizer db-truncater snapshot-converter; # Add cardano-node, cardano-cli and tx-generator with their git revision stamp. # Keep available an alternative without the git revision, like the other # passthru (profiled and asserted in nix/haskell.nix) that diff --git a/nix/haskell.nix b/nix/haskell.nix index fcb73320ab1..b5cb8a374e5 100644 --- a/nix/haskell.nix +++ b/nix/haskell.nix @@ -138,9 +138,9 @@ let packages.cardano-ledger-conway.components.library.doHaddock = false; packages.cardano-ledger-shelley.components.library.doHaddock = false; packages.cardano-protocol-tpraos.components.library.doHaddock = false; - packages.ouroboros-consensus-cardano.components.library.doHaddock = false; packages.ouroboros-consensus.components.library.doHaddock = false; packages.ouroboros-network.components.library.doHaddock = false; # Currently broken + packages.cardano-diffusion.components.library.doHaddock = false; # Currently broken packages.plutus-ledger-api.components.library.doHaddock = false; }) ({ lib, pkgs, ...}: lib.mkIf (pkgs.stdenv.hostPlatform.isWindows) { @@ -311,11 +311,13 @@ let export WORKDIR=$TMP/testTracerExt ''; }) - ({ lib, pkgs, ... }: lib.mkIf (!pkgs.stdenv.hostPlatform.isDarwin) { + ({ lib, pkgs, ... }: lib.mkIf (!pkgs.stdenv.hostPlatform.isDarwin && !pkgs.stdenv.hostPlatform.isMusl) { # Needed for profiled builds to fix an issue loading recursion-schemes part of makeBaseFunctor # that is missing from the `_p` output. See https://gitlab.haskell.org/ghc/ghc/-/issues/18320 # This work around currently breaks regular builds on macOS with: # : error: ghc: ghc-iserv terminated (-11) + # Excluded for musl: ghc-iserv (musl binary) crashes with SIGILL on musl targets. + # Musl builds are same-arch cross-compiles so GHC can run TH in-process (glibc) instead. packages.plutus-core.components.library.ghcOptions = [ "-fexternal-interpreter" ]; }) ({ config, lib, ... }@args: { @@ -359,12 +361,6 @@ let packages.terminal-size.components.library.build-tools = lib.mkForce [ ]; packages.network.components.library.build-tools = lib.mkForce [ ]; }) - ({ ... }: { - # TODO: requires - # https://github.com/input-output-hk/ouroboros-network/pull/4673 or - # a newer ghc - packages.ouroboros-network-framework.doHaddock = false; - }) # TODO add flags to packages (like cs-ledger) so we can turn off tests that will # not build for windows on a per package bases (rather than using --disable-tests). # configureArgs = lib.optionalString stdenv.hostPlatform.isWindows "--disable-tests"; @@ -386,7 +382,6 @@ project.appendOverlays (with haskellLib.projectOverlays; [ packages = final.pkgs.lib.genAttrs [ "cardano-node" "cardano-tracer" - "trace-dispatcher" "trace-forward" "trace-resources" ] @@ -397,7 +392,6 @@ project.appendOverlays (with haskellLib.projectOverlays; [ modules = [{ packages = lib.genAttrs [ "ouroboros-consensus" - "ouroboros-consensus-cardano" "ouroboros-network" "network-mux" ] diff --git a/nix/workbench/shell.nix b/nix/workbench/shell.nix index 9a66740e0d1..1f3f426cd7a 100644 --- a/nix/workbench/shell.nix +++ b/nix/workbench/shell.nix @@ -151,7 +151,7 @@ project.shellFor { ++ (with project.hsPkgs; [ # A `notGitRev` version, faster to enter a workbench after a new commit. cardano-cli.components.exes.cardano-cli - ouroboros-consensus-cardano.components.exes.db-analyser + ouroboros-consensus.components.exes.db-analyser ]) ++ (with workbench-runner; [ workbench-interactive-start diff --git a/trace-dispatcher/.gitignore b/trace-dispatcher/.gitignore deleted file mode 100644 index e825f8bed1c..00000000000 --- a/trace-dispatcher/.gitignore +++ /dev/null @@ -1,11 +0,0 @@ -.cabal-sandbox -dist -cabal.sandbox.config -TAGS -.stack-work/ -*.o -*.hi -*.dyn_o -*.dyn_hi -stack.yaml.lock -*.pdf diff --git a/trace-dispatcher/CHANGELOG.md b/trace-dispatcher/CHANGELOG.md deleted file mode 100644 index f0dbe121e8f..00000000000 --- a/trace-dispatcher/CHANGELOG.md +++ /dev/null @@ -1,102 +0,0 @@ -# Revision history for trace-dispatcher - -## 2.11.1 -- Feb 2026 - -* Add strict `contramap'` (infix alias `>!$!<`) to the API, capturing a common pattern to avoid unintentional space leaks when composing tracers -* Increase `PrometheusSimple` robustness by restarting the backend upon crash, adding start/stop traces and more eagerly reaping of dangling sockets -* Setting the `TRACE_DISPATCHER_LOGGING_HOSTNAME` environment variable will override the system hostname in trace messages. -* Increased strictness when storing traced `DataPoints` -* Drastically reduced fallback value for forwarding queue capacity to minimize impact of forwarding service interruption on heap size and retention -* Removed `TraceConfig.tcPeerFrequency` and hence `TraceOptionPeerFrequency` from config representation -* Removed unused module `Cardano.Logging.Types.NodePeers` - -## 2.11.0 -- Nov 2025 - -* `class LogFormatting`: remove redundant `forHumanFromMachine` and `forHumanOrMachine` (the system already does that inherently) -* Introduce type `Cardano.Logging.Types.TraceMessage.TraceMessage` with explicit codecs for JSON and CBOR -* Rework `PreFormatted` type and formatters to use `TraceMessage`; slightly optimize `humanFormatter'` -* Add CBOR formatting via `FormattedMessage.FormattedCBOR` constructor and a `cborFormatter'` function -* Replaced both `disconnectedQueueSize` and `connectedQueueSize` with `queueSize` in `TraceOptionForwarder` while keeping config parsing backwards compatible -* Add retry delay reset in `runInLoop` when the action runs sufficiently long -* Safely stop `standardTracer`'s stdout thread when there are no more producers - -## 2.10.0 -- July, 2025 -* Forwarding protocol supports connections over TCP socket, in addition to Unix domain sockets. -* Failure to initialise the `PrometheusSimple` backend is now lenient - i.e., won't result in an exception being propagated. -* `trace-forward` now depends on `trace-dispatcher`, and not the other way round. -* Improves the structure and metadata of generated tracer documentation. -* Drop unnecessary dependency on `io-classes`. - -## 2.9.2 -- May 2025 -* New config field `traceOptionLedgerMetricsFrequency`. - -## 2.9.1 -- Apr 2025 -* Removed `cardano-node' as a dependency from `cardano-tracer'. This necessitated moving `NodeInfo` - (from `cardano-tracer:Cardano.Node.Startup` to `trace-dispatcher:Cardano.Logging.Types.NodeInfo`), `NodePeers` - (from `cardano-node:Cardano.Node.Tracing.Peers` to `trace-dispatcher:Cardano.Logging.Types.NodePeers`), and - `NodeStartupInfo` (from `cardano-tracer:Cardano.Node.Startup` to `cardano-node:Cardano.Node.Tracing.NodeStartupInfo.hs`). - -## 2.9 -- Mar 2025 - -* New `PrometheusSimple` backend which runs a simple TCP server for direct exposition of metrics, without forwarding. -* New `maxReconnectDelay` config option in `TraceOptionForwarder`: Specifies maximum delay (seconds) between (re-)connection attempts of a forwarder (default: 60s). -* Introduce `forHumanFromMachine :: a -> Text` into `class LogFormatting a` as a safe drop-in `forMachine` definition in instances. -* Optimize data sharing in formatters. -* Remove unused optional namespace prefix argument from formatters. -* Updated to use `ekg-forward-0.9`. -* Remove `ekg-wai` from dependencies. - -## 2.8.1 -- Feb 2025 - -* Updated to `ouroboros-network-framework-0.16` - -## 2.8.0 -- Jan 2025 - -* Change dependency `ekg` to `ekg-wai`, replacing `snap-server` based web stack with `warp / wai`. -* Add `initForwardingDelayed` which allows for deferred start of forwarding after initialization, instead of tying both together. - -## 2.7.0 -- Sep 2024 - -* Add `docuResultsToMetricsHelptext` for JSON output of metrics docs; required - by `cardano-node` command `trace-documentation --output-metric-help` - -## 2.6.0 - -* With a metrics prefix that can be set in the configuration (tcMetricsPrefix) - Metrics gets a type postfix (_int,_real, _counter) - -## 2.5.7 - -* With a prometheus metric with key label pairs. The value will always be "1" - -## 2.5.2 -- Dec 2023 - -* ForHuman Color, Increased Consistency Checks, and Non-empty Inner Workspace Validation - -## 2.5.1 -- Dec 2023 - -* Rewrite of examples as unit tests - -## 2.4.1 -- Nov 2023 - -* Updated to `ouroboros-network-0.10` - -## 2.1.0 -- Sep 2023 - -* Updated to `ouroboros-network-0.9.1.0` - -## 2.0.0 -- May 2023 - -* First version that diverges from cardano-node versioning scheme - -* GHC-9.2 support - -* Many undocumented changes - -## 1.35.4 -- November 2022 - -* Undocumented changes - -## 1.29.0 -- September 2021 - -* Initial version. diff --git a/trace-dispatcher/LICENSE b/trace-dispatcher/LICENSE deleted file mode 100644 index f433b1a53f5..00000000000 --- a/trace-dispatcher/LICENSE +++ /dev/null @@ -1,177 +0,0 @@ - - Apache License - Version 2.0, January 2004 - http://www.apache.org/licenses/ - - TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION - - 1. Definitions. - - "License" shall mean the terms and conditions for use, reproduction, - and distribution as defined by Sections 1 through 9 of this document. - - "Licensor" shall mean the copyright owner or entity authorized by - the copyright owner that is granting the License. - - "Legal Entity" shall mean the union of the acting entity and all - other entities that control, are controlled by, or are under common - control with that entity. For the purposes of this definition, - "control" means (i) the power, direct or indirect, to cause the - direction or management of such entity, whether by contract or - otherwise, or (ii) ownership of fifty percent (50%) or more of the - outstanding shares, or (iii) beneficial ownership of such entity. - - "You" (or "Your") shall mean an individual or Legal Entity - exercising permissions granted by this License. - - "Source" form shall mean the preferred form for making modifications, - including but not limited to software source code, documentation - source, and configuration files. - - "Object" form shall mean any form resulting from mechanical - transformation or translation of a Source form, including but - not limited to compiled object code, generated documentation, - and conversions to other media types. - - "Work" shall mean the work of authorship, whether in Source or - Object form, made available under the License, as indicated by a - copyright notice that is included in or attached to the work - (an example is provided in the Appendix below). - - "Derivative Works" shall mean any work, whether in Source or Object - form, that is based on (or derived from) the Work and for which the - editorial revisions, annotations, elaborations, or other modifications - represent, as a whole, an original work of authorship. For the purposes - of this License, Derivative Works shall not include works that remain - separable from, or merely link (or bind by name) to the interfaces of, - the Work and Derivative Works thereof. - - "Contribution" shall mean any work of authorship, including - the original version of the Work and any modifications or additions - to that Work or Derivative Works thereof, that is intentionally - submitted to Licensor for inclusion in the Work by the copyright owner - or by an individual or Legal Entity authorized to submit on behalf of - the copyright owner. For the purposes of this definition, "submitted" - means any form of electronic, verbal, or written communication sent - to the Licensor or its representatives, including but not limited to - communication on electronic mailing lists, source code control systems, - and issue tracking systems that are managed by, or on behalf of, the - Licensor for the purpose of discussing and improving the Work, but - excluding communication that is conspicuously marked or otherwise - designated in writing by the copyright owner as "Not a Contribution." - - "Contributor" shall mean Licensor and any individual or Legal Entity - on behalf of whom a Contribution has been received by Licensor and - subsequently incorporated within the Work. - - 2. Grant of Copyright License. Subject to the terms and conditions of - this License, each Contributor hereby grants to You a perpetual, - worldwide, non-exclusive, no-charge, royalty-free, irrevocable - copyright license to reproduce, prepare Derivative Works of, - publicly display, publicly perform, sublicense, and distribute the - Work and such Derivative Works in Source or Object form. - - 3. Grant of Patent License. Subject to the terms and conditions of - this License, each Contributor hereby grants to You a perpetual, - worldwide, non-exclusive, no-charge, royalty-free, irrevocable - (except as stated in this section) patent license to make, have made, - use, offer to sell, sell, import, and otherwise transfer the Work, - where such license applies only to those patent claims licensable - by such Contributor that are necessarily infringed by their - Contribution(s) alone or by combination of their Contribution(s) - with the Work to which such Contribution(s) was submitted. If You - institute patent litigation against any entity (including a - cross-claim or counterclaim in a lawsuit) alleging that the Work - or a Contribution incorporated within the Work constitutes direct - or contributory patent infringement, then any patent licenses - granted to You under this License for that Work shall terminate - as of the date such litigation is filed. - - 4. Redistribution. You may reproduce and distribute copies of the - Work or Derivative Works thereof in any medium, with or without - modifications, and in Source or Object form, provided that You - meet the following conditions: - - (a) You must give any other recipients of the Work or - Derivative Works a copy of this License; and - - (b) You must cause any modified files to carry prominent notices - stating that You changed the files; and - - (c) You must retain, in the Source form of any Derivative Works - that You distribute, all copyright, patent, trademark, and - attribution notices from the Source form of the Work, - excluding those notices that do not pertain to any part of - the Derivative Works; and - - (d) If the Work includes a "NOTICE" text file as part of its - distribution, then any Derivative Works that You distribute must - include a readable copy of the attribution notices contained - within such NOTICE file, excluding those notices that do not - pertain to any part of the Derivative Works, in at least one - of the following places: within a NOTICE text file distributed - as part of the Derivative Works; within the Source form or - documentation, if provided along with the Derivative Works; or, - within a display generated by the Derivative Works, if and - wherever such third-party notices normally appear. The contents - of the NOTICE file are for informational purposes only and - do not modify the License. You may add Your own attribution - notices within Derivative Works that You distribute, alongside - or as an addendum to the NOTICE text from the Work, provided - that such additional attribution notices cannot be construed - as modifying the License. - - You may add Your own copyright statement to Your modifications and - may provide additional or different license terms and conditions - for use, reproduction, or distribution of Your modifications, or - for any such Derivative Works as a whole, provided Your use, - reproduction, and distribution of the Work otherwise complies with - the conditions stated in this License. - - 5. Submission of Contributions. Unless You explicitly state otherwise, - any Contribution intentionally submitted for inclusion in the Work - by You to the Licensor shall be under the terms and conditions of - this License, without any additional terms or conditions. - Notwithstanding the above, nothing herein shall supersede or modify - the terms of any separate license agreement you may have executed - with Licensor regarding such Contributions. - - 6. Trademarks. This License does not grant permission to use the trade - names, trademarks, service marks, or product names of the Licensor, - except as required for reasonable and customary use in describing the - origin of the Work and reproducing the content of the NOTICE file. - - 7. Disclaimer of Warranty. Unless required by applicable law or - agreed to in writing, Licensor provides the Work (and each - Contributor provides its Contributions) on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or - implied, including, without limitation, any warranties or conditions - of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A - PARTICULAR PURPOSE. You are solely responsible for determining the - appropriateness of using or redistributing the Work and assume any - risks associated with Your exercise of permissions under this License. - - 8. Limitation of Liability. In no event and under no legal theory, - whether in tort (including negligence), contract, or otherwise, - unless required by applicable law (such as deliberate and grossly - negligent acts) or agreed to in writing, shall any Contributor be - liable to You for damages, including any direct, indirect, special, - incidental, or consequential damages of any character arising as a - result of this License or out of the use or inability to use the - Work (including but not limited to damages for loss of goodwill, - work stoppage, computer failure or malfunction, or any and all - other commercial damages or losses), even if such Contributor - has been advised of the possibility of such damages. - - 9. Accepting Warranty or Additional Liability. While redistributing - the Work or Derivative Works thereof, You may choose to offer, - and charge a fee for, acceptance of support, warranty, indemnity, - or other liability obligations and/or rights consistent with this - License. However, in accepting such obligations, You may act only - on Your own behalf and on Your sole responsibility, not on behalf - of any other Contributor, and only if You agree to indemnify, - defend, and hold each Contributor harmless for any liability - incurred by, or claims asserted against, such Contributor by reason - of your accepting any such warranty or additional liability. - - END OF TERMS AND CONDITIONS diff --git a/trace-dispatcher/NOTICE b/trace-dispatcher/NOTICE deleted file mode 100644 index bb48c5475b3..00000000000 --- a/trace-dispatcher/NOTICE +++ /dev/null @@ -1,13 +0,0 @@ -Copyright 2020-2023 Input Output Global Inc (IOG), 2023-2026 Intersect. - -Licensed under the Apache License, Version 2.0 (the "License"); -you may not use this file except in compliance with the License. -You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - -Unless required by applicable law or agreed to in writing, software -distributed under the License is distributed on an "AS IS" BASIS, -WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -See the License for the specific language governing permissions and -limitations under the License. diff --git a/trace-dispatcher/README.md b/trace-dispatcher/README.md deleted file mode 100644 index 97a32221f38..00000000000 --- a/trace-dispatcher/README.md +++ /dev/null @@ -1,12 +0,0 @@ -trace-dispatcher - -We integrated contra-tracer-0.1.0.0 into the source tree, because the -iohk-monitoring framework depends on the non-arrow based contra-tracer framework. -This should become a dependency later. - -The documentation can currently be found under: docs/trace-dispatcher.md - -## Developers - -Benchmarking team is responsible for this library. -The primary developer is [@JürgenNF](https://github.com/jutaro). diff --git a/trace-dispatcher/bench/trace-dispatcher-bench.hs b/trace-dispatcher/bench/trace-dispatcher-bench.hs deleted file mode 100644 index 9c1bda5c520..00000000000 --- a/trace-dispatcher/bench/trace-dispatcher-bench.hs +++ /dev/null @@ -1,125 +0,0 @@ -import Cardano.Logging hiding (stdoutTracer) -import Cardano.Logging.Test.Config -import Cardano.Logging.Test.Tracer -import Cardano.Logging.Test.Types - -import Data.IORef -import System.Metrics (newStore) - -import Criterion.Main - - --- Can be run with: --- cabal bench trace-dispatcher-bench --benchmark-option='-o benchmark-trace.html' - -main :: IO () -main = do - configState <- emptyConfigReflection - stdioTr <- standardTracer - tr <- stdoutTracers configState stdioTr - filtr <- filterTracers configState stdioTr - imtr <- inMemoryTracers configState - tlTr <- timeLimitedTracers configState stdioTr - ekgTr <- ekgTracers configState - defaultMain [ - bgroup "tracer" [ - bench "sendMessageStdout1" $ whnfIO (sendMessage 1 tr) - , bench "sendMessageStdout10" $ whnfIO (sendMessage 10 tr) - , bench "sendMessageStdout100" $ whnfIO (sendMessage 100 tr) - , bench "sendMessageStdout1000" $ whnfIO (sendMessage 1000 tr) - - , bench "sendMessageInMemory1" $ whnfIO (sendMessage 1 imtr) - , bench "sendMessageInMemory10" $ whnfIO (sendMessage 10 imtr) - , bench "sendMessageInMemory100" $ whnfIO (sendMessage 100 imtr) - , bench "sendMessageInMemory1000" $ whnfIO (sendMessage 1000 imtr) - - , bench "sendMessageFiltered1" $ whnfIO (sendMessage 1 filtr) - , bench "sendMessageFiltered10" $ whnfIO (sendMessage 10 filtr) - , bench "sendMessageFiltered100" $ whnfIO (sendMessage 100 filtr) - , bench "sendMessageFiltered1000" $ whnfIO (sendMessage 1000 filtr) - - , bench "sendMessageTimeLimited1000_100" $ whnfIO (sendMessage 1000 tlTr) - , bench "sendMessageTimeLimited10000_100" $ whnfIO (sendMessage 10000 tlTr) - - , bench "sendEKG 5/1" $ whnfIO (sendMessage 1 ekgTr) - , bench "sendEKG 5/10" $ whnfIO (sendMessage 10 ekgTr) - , bench "sendEKG 5/100" $ whnfIO (sendMessage 100 ekgTr) - , bench "sendEKG 5/1000" $ whnfIO (sendMessage 1000 ekgTr) - ] - ] - -stdoutTracers :: ConfigReflection -> Trace IO FormattedMessage -> IO (Trace IO Message) -stdoutTracers confState stdoutTracer = do - forwardTrRef <- newIORef [] - forwardTracer' <- testTracer forwardTrRef - tr <- mkCardanoTracer - stdoutTracer - forwardTracer' - Nothing - ["Test"] - configureTracers confState config1 [tr] - pure tr - -filterTracers :: ConfigReflection -> Trace IO FormattedMessage -> IO (Trace IO Message) -filterTracers confState stdoutTracer = do - forwardTrRef <- newIORef [] - forwardTracer' <- testTracer forwardTrRef - tr <- mkCardanoTracer - stdoutTracer - forwardTracer' - Nothing - ["Test"] - configureTracers confState config2 [tr] - pure tr - -inMemoryTracers :: ConfigReflection -> IO (Trace IO Message) -inMemoryTracers confState = do - stdoutTrRef <- newIORef [] - stdoutTracer' <- testTracer stdoutTrRef - forwardTrRef <- newIORef [] - forwardTracer' <- testTracer forwardTrRef - tr <- mkCardanoTracer - stdoutTracer' - forwardTracer' - Nothing - ["Test"] - configureTracers confState config1 [tr] - pure tr - -timeLimitedTracers :: ConfigReflection -> Trace IO FormattedMessage -> IO (Trace IO Message) -timeLimitedTracers confState stdoutTracer = do - forwardTrRef <- newIORef [] - forwardTracer' <- testTracer forwardTrRef - tr <- mkCardanoTracer - stdoutTracer - forwardTracer' - Nothing - ["Test"] - configureTracers confState config3 [tr] - pure tr - -ekgTracers :: ConfigReflection -> IO (Trace IO Message) -ekgTracers confState = do - stdoutTrRef <- newIORef [] - stdoutTracer' <- testTracer stdoutTrRef - forwardTrRef <- newIORef [] - forwardTracer' <- testTracer forwardTrRef - store <- newStore - trEkg <- ekgTracer emptyTraceConfig store - tr <- mkCardanoTracer - stdoutTracer' - forwardTracer' - (Just trEkg) - ["Test"] - configureTracers confState config4 [tr] - pure tr - -timesRepeat :: Int -> IO () -> IO () -timesRepeat 0 _ = pure () -timesRepeat n action = do - action - timesRepeat (n - 1) action - -sendMessage :: Int -> Trace IO Message -> IO () -sendMessage n tr = - timesRepeat n (traceWith tr (Message1 1 1)) diff --git a/trace-dispatcher/doc/config.json b/trace-dispatcher/doc/config.json deleted file mode 100644 index 5dac88a9edd..00000000000 --- a/trace-dispatcher/doc/config.json +++ /dev/null @@ -1,62 +0,0 @@ -{ - "TraceOptions": { - "Node": { - "severity": "Notice", - "detail": "DNormal", - "backends": [ - "Stdout MachineFormat", - "EKGBackend", - "Forwarder" - ] - }, - "Node.ChainDB": { - "severity": "Info" - }, - "Node.AcceptPolicy": { - "severity": "Info" - }, - "Node.DNSResolver": { - "severity": "Info" - }, - "Node.DNSSubscription": { - "severity": "Info" - }, - "Node.DiffusionInit": { - "severity": "Info" - }, - "Node.ErrorPolicy": { - "severity": "Info" - }, - "Node.Forge": { - "severity": "Info" - }, - "Node.IpSubscription": { - "severity": "Info" - }, - "Node.LocalErrorPolicy": { - "severity": "Info" - }, - "Node.Mempool": { - "severity": "Info" - }, - "Node.Resources": { - "severity": "Info" - }, - "Node.ChainDB.AddBlockEvent.AddedBlockToQueue": { - "maxFrequency": 2 - }, - "Node.ChainDB.AddBlockEvent.AddedBlockToVolatileDB": { - "maxFrequency": 2 - }, - "Node.ChainDB.CopyToImmutableDBEvent.CopiedBlockToImmutableDB": { - "maxFrequency": 2 - }, - "Node.ChainDB.AddBlockEvent.AddBlockValidation.ValidCandidate": { - "maxFrequency": 2 - }, - "Node.BlockFetchClient.CompletedBlockFetch": { - "maxFrequency": 2 - } - }, - "TraceOptionResourceFrequency": 5000 -} diff --git a/trace-dispatcher/doc/config.nix b/trace-dispatcher/doc/config.nix deleted file mode 100644 index be29752abbc..00000000000 --- a/trace-dispatcher/doc/config.nix +++ /dev/null @@ -1,17 +0,0 @@ -To add in node-services.nix - - TraceOptionSeverity = [ - {ns = ""; severity = "Info";} - {ns = "AcceptPolicy"; severity = "Silence";} - {ns = "ChainDB"; severity = "Debug";} - ]; - - TraceOptionDetail = [ - {ns = ""; detail = "DNormal";} - {ns = "BlockFetchClient"; detail = "DMinimal";} - ]; - - TraceOptionBackend = [ - {ns = ""; backends = ["Stdout HumanFormatColoured"; "Forwarder"; "EKGBackend"];} - {ns = "ChainDB"; backends = ["Forwarder"];} - ]; diff --git a/trace-dispatcher/doc/config.yaml b/trace-dispatcher/doc/config.yaml deleted file mode 100644 index c9d5cb22869..00000000000 --- a/trace-dispatcher/doc/config.yaml +++ /dev/null @@ -1,64 +0,0 @@ -UseTraceDispatcher: True - -TraceOptions: - "": - severity: Notice - detail: DNormal - backends: - - Stdout MachineFormat - - EKGBackend - - Forwarder - -# More interesting tracers - - ChainDB: - severity: Info - - AcceptPolicy: - severity: Info - - DNSResolver: - severity: Info - - DNSSubscription: - severity: Info - - DiffusionInit: - severity: Info - - ErrorPolicy: - severity: Info - - Forge: - severity: Info - - IpSubscription: - severity: Info - - LocalErrorPolicy: - severity: Info - - Mempool: - severity: Info - - Resources: - severity: Info - -#--------------------------- -# Frequency limited tracer - ChainDB.AddBlockEvent.AddedBlockToQueue: - maxFrequency: 2.0 - - ChainDB.AddBlockEvent.AddedBlockToVolatileDB: - maxFrequency: 2.0 - - ChainDB.CopyToImmutableDBEvent.CopiedBlockToImmutableDB: - maxFrequency: 2.0 - - ChainDB.AddBlockEvent.AddBlockValidation.ValidCandidate: - maxFrequency: 2.0 - - BlockFetchClient.CompletedBlockFetch: - maxFrequency: 2.0 - -TraceOptionResourceFrequency: 5000 diff --git a/trace-dispatcher/doc/trace-dispatcher.md b/trace-dispatcher/doc/trace-dispatcher.md deleted file mode 100644 index 2282e2eddb6..00000000000 --- a/trace-dispatcher/doc/trace-dispatcher.md +++ /dev/null @@ -1,773 +0,0 @@ -# trace-dispatcher: efficient, simple and flexible program tracing - -`trace-dispatcher` is a library that enables definition of __tracing systems__ -- systems that collect and manage traces -- as evidence of program execution. - -- [trace-dispatcher: efficient, simple and flexible program tracing](#trace-dispatcher-efficient-simple-and-flexible-program-tracing) -- [Introduction](#introduction) - - [Rationale](#rationale) - - [Transition Period](#transition-period) - - [Key Recommendations for Developers](#key-recommendations-for-developers) -- [Basic Tracer Topics](#basic-tracer-topics) - - [Tracer Construction Basics](#tracer-construction-basics) - - [Namespace Concept Explanation](#namespace-concept-explanation) - - [Typeclasses Overview](#typeclasses-overview) - - [LogFormatting Typeclass](#logformatting-typeclass) - - [MetaTrace Typeclass](#metatrace-typeclass) - - [Metrics Integration](#metrics-integration) - - [Frequency Limiting in Trace Filtering](#frequency-limiting-in-trace-filtering) - - [Configuration](#configuration) -- [Advanced Tracer Topics](#advanced-tracer-topics) - - [Integrating a New Tracer into cardano-node](#integrating-a-new-tracer-into-cardano-node) - - [Message Filtering based on Severity](#message-filtering-based-on-severity) - - [Comprehensive Trace Filtering](#comprehensive-trace-filtering) - - [Privacy Annotations](#privacy-annotations) - - [Detail Level in Trace Presentation](#detail-level-in-trace-presentation) - - [Fold-Based Aggregation](#fold-based-aggregation) - - [Dispatcher Routing Mechanism](#dispatcher-routing-mechanism) - - [Documentation Generation](#documentation-generation) - - [Consistency Checking](#consistency-checking) - - [Trace Backends Overview](#trace-backends-overview) - - [Data Points Overview and Deprecation Notice](#data-points-overview-and-deprecation-notice) -- [Appendix](#appendix) - - [References](#references) - - [Future work](#future-work) - - [Versioning](#versioning) - - [Trace Consumers](#trace-consumers) - -# Introduction - -## Rationale - -The `trace-dispatcher` library serves as a sophisticated solution for streamlined and effective tracing systems. Built upon the arrow-based `contra-tracer` framework, it surpasses the capabilities of the `iohk-monitoring` framework with the following enhancements: - -- Persistent activation of all tracers, adhering to the configured severity levels. - -- Granular configuration (such as filtering, limiting) of individual tracers based on hierarchical namespaces, extending down to individual messages. - -- Seamless transmission of traces to a dedicated `cardano-tracer` process capable of handling traces from multiple nodes. - -- Dynamic reconfiguration (i.e. hot-reloading) of tracing settings within a running node (after removal of legacy tracing). - -- Automatic generation of comprehensive documentation encompassing all trace messages, metrics, and datapoints. - -- Sanity and consistency checking of tracer implementations and tracing settings based on the system's introspective capability. - -## Transition Period - -During the transitional phase, both legacy tracing, based on the `iohk-monitoring` framework, and new tracing, leveraging `trace-dispatcher` and `cardano-tracer`, will coexist. - -This interim period provides an opportunity to thoroughly test and enhance the new tracing system. Given the extensive repertoire of over 600 trace messages, the possibility of uncovering regressions and bugs is anticipated. Your assistance in identifying and rectifying these issues is invaluable. - -Please be aware that, owing to compatibility with the legacy system, the new tracing functionality will be slightly constrained during this transitional phase. Certain features, such as dynamic reconfiguration of a running node, will be temporarily unavailable. Additionally, there may be redundant implementations that are currently necessary but slated for refinement. - -To activate new tracing, set the `UseTraceDispatcher` in the node's config file value to `true`. When making this switch, ensure that the configuration file includes the requisite values for the new tracing setup, as detailed in the subsequent section. - -## Key Recommendations for Developers - -Kindly consider the following important suggestions: - -- The current tracing system employs two methods for message identification: a hierarchical name known as its Namespace and the Kind field in machine representation. Our implementation is rooted in the namespace, and we are actively moving towards deprecating the Kind field for a singular reliance on namespaces. Therefore, we strongly recommend utilizing namespaces for any trace analysis tools, as the _Kind field will be phased out in the near future_. - -- Avoid using strictness annotations for trace types. Given that trace messages are either promptly discarded or instantly converted to another format without storage, strictness annotations introduce unnecessary inefficiencies without tangible benefits. - -- When developing new tracers, consider creating the new tracers first and subsequently mapping to old tracers. You can refer to numerous examples in `cardano-node` under `Cardano.Node.Tracing.Tracers`. - -- For inquiries and reviews, please reach out to the Performance & Tracing team. Your collaboration and questions are welcome to ensure a seamless transition and optimal utilization of the new tracing framework. - -# Basic Tracer Topics - -## Tracer Construction Basics - -1. Define an Algebraic Data Type (ADT) and assign distinct constructors to each trace message. - -An example is: - -```haskell -data TraceAddBlockEvent blk = - IgnoreBlockOlderThanK (RealPoint blk) - | IgnoreBlockAlreadyInVolatileDB (RealPoint blk) - ... -``` - -2. Create a tracer for this data type using the provided Haskell function: - -```haskell --- | Generate a tracer conforming to the cardano node requirements. --- The tracer must be an instance of LogFormatting for message display --- and an instance of MetaTrace for meta-information such as --- severity, privacy, details, and backends. --- The tracer receives those backends as arguments: --- * 'trStdout': stdout tracing --- * 'trForward': trace forwarding --- * 'mbTrEkg': (optional) EKG monitoring --- The tracer is supplied with a 'name' as an array of text, which is prepended to its namespace. --- This function returns the new tracer. - -mkCardanoTracer :: forall evt. - ( LogFormatting evt - , MetaTrace evt ) - => Trace IO FormattedMessage - -> Trace IO FormattedMessage - -> Maybe (Trace IO FormattedMessage) - -> [Text] - -> IO (Trace IO evt) -``` - -It is imperative that the tracer backends (the first three parameters) remain consistent across all tracers. For example, only one stdout backend is permitted for use in any program. - -3. Configure the returned tracer with: - -```haskell --- | Invoke this function during initialization (and potentially later for reconfiguration). --- ConfigReflection is utilized to gather information about the tracers --- and is employed to optimize the tracers. --- TraceConfig represents the configuration, typically loaded from a configuration file. --- While it is feasible to provide more than one tracer of the same type, --- this scenario is not common. --- This function does not return a value. - -configureTracers :: forall a m. - ( MetaTrace a - , MonadIO m ) - => ConfigReflection - -> TraceConfig - -> [Trace m a] - -> m () -``` - -4. Trace Emission Process - -To emit a trace, employing a message and its corresponding tracer, utilize the `traceWith` function: - -```haskell -traceWith :: Trace m a -> a -> m () --- For example: -addBlockTracer <- mkCardanoTracer trStdout trForward (Just trEkg) ["ChainDB"] -configureTracers configReflect config [addBlockTracer] -.. -traceWith addBlockTracer (IgnoreBlockOlderThanK p) -``` - -## Namespace Concept Explanation - -Understanding the concept of namespaces is crucial for comprehending the tracing system and the `MetaTrace` typeclass. Tracers are systematically organized within a hierarchical tracer namespace, with tree nodes and leaves identified by `Text` name components. - -The trace dispatcher requires careful organization to ensure that all messages possess a unique name within this namespace. Moreover, the same tracer type can be utilized in different contexts, such as for local and remote messages. To enable this flexibility, the 'inner' namespace is prefixed by the namespace passed to a tracer during construction (refer to `mkCardanoTracer` example above). - -```haskell --- A unique identifier for every message, composed of arrays of text --- A namespace can also appear with the tracer name (e.g., "ChainDB.OpenEvent.OpenedDB"), --- or more prefixes; currently, a NamespaceOuter is used. --- The inner namespace may not be empty. -data Namespace a = Namespace { - nsPrefix :: [Text] - , nsInner :: [Text]} -``` - -Every namespace is composed of: - -- system namespace (empty for cardano, but was cardano in old tracing) -- tracer namespace (argument of mkCardanoTracer) -- inner namespace (provided by the MetaTrace typeclass) - -The tracer namespace serves pivotal roles in: - -- __Documentation__: It defines the overall structure of the generated documentation output. - -- __Configuration__: It allows reference to tracers that need reconfiguration, such as altering their severity. - -- __Output__: The messages carry the tracer namespace, providing clarity and context in the output. - -## Typeclasses Overview - -For the effective integration of trace messages into the tracing system, two essential typeclasses must be implemented: one for message formatting and another for meta-information. - -### LogFormatting Typeclass - -The `LogFormatting` typeclass governs the presentation of trace messages, encompassing the mapping of traces to metrics and messages. It includes the following methods: - -- The `forMachine` method caters to a machine-readable representation, adaptable based on the detail level. Implementation is mandatory for the trace author. The system will render this, -along with trace metadata, as JSON of type `Cardano.Logging.Types.TraceMessage.TraceMessage`. - -- The `forHuman` method renders the message in a human-readable form. Its default implementation is an -empty text. Whenever the system encounters the empty text, it will replace it with the machine-readable JSON, rendering it as a value in `{"data": }`, preventing potential loss of log information - -- The `asMetrics` method portrays the message as 0 to n metrics. The default implementation assumes no metrics. Each metric can optionally specify a hierarchical identifier as a `[Text]`. - -```haskell -class LogFormatting a where - -- Machine readable representation with varying details based on the detail level. - forMachine :: DetailLevel -> a -> Aeson.Object - - -- Human readable representation. - forHuman :: a -> Text - forHuman _v = "" - - -- Metrics representation. - asMetrics :: a -> [Metric] - asMetrics _v = [] -``` - -Metrics, represented as numbers, serve to monitor the running system and can be accessed, for example, through Prometheus. - -```haskell -data Metric - -- Integer metric with a named identifier. - = IntM Text Integer - -- Double metric with a named identifier. - | DoubleM Text Double - -- Counter metric with a named identifier and an optional limit. - | CounterM Text (Maybe Int) - deriving (Show, Eq) -``` - -### MetaTrace Typeclass - -The `MetaTrace` typeclass plays a pivotal role in providing meta-information for trace messages. It includes the following methods: - -- __namespaceFor__: Offers a distinct (inner) namespace for each trace message. - -- __severityFor__: Provides severity for a given namespace. As some severities depend not only on the message type but also on the individual message, the actual message may be passed as well. - -- __privacyFor__: Determines whether a message is `Private` or `Public`. Private messages are not sent to `cardano-tracer` and are only displayed on the stdout trace. If no implementation is given, `Public` is chosen. - -- __detailsFor__: Specifies the level of details for printing messages. Options include `DMinimal`, `DNormal`, `DDetailed`, and `DMaximum`. If no implementation is given, `DNormal` is chosen. - -- __documentFor__: Allows the addition of optional documentation for messages as text. See section [Documentation Generation](#documentation-generation) later in this document. - -- __metricsDocFor__: Enables the addition of documentation for metrics carried by the respective message. If no implementation is given, the default is no metrics. - -- __allNamespaces__: Must return an array with all namespaces of this trace type. - -```haskell -class MetaTrace a where - namespaceFor :: a -> Namespace a - - severityFor :: Namespace a -> Maybe a -> Maybe SeverityS - - privacyFor :: Namespace a -> Maybe a -> Maybe Privacy - privacyFor _ _ = Just Public - - detailsFor :: Namespace a -> Maybe a -> Maybe DetailLevel - detailsFor _ _ = Just DNormal - - documentFor :: Namespace a -> Maybe Text - - metricsDocFor :: Namespace a -> [(Text, Text)] - metricsDocFor _ = [] - - allNamespaces :: [Namespace a] -``` - -## Metrics Integration - -Metrics are seamlessly incorporated into the system through regular trace messages implementing the `asMetrics` function within the `LogFormatting` typeclass. Unlike other trace components, metrics are not subjected to filtering and are consistently provided. This occurs as long as the `EKGBackend` is configured for the message. The `EKGBackend` then forwards these metrics to `cardano-tracer` for additional processing. Subsequently, they are dispatched as Prometheus metrics, extending their utility and visibility. - -It is essential to implement the metricsDoc function of the MetaTrace typeclass, as this information is utilized to optimize system performance. - -The configuration option TraceOptionMetricsPrefix can be used to prepend a prefix to any metrics name. For example, the prefix could be "cardano.node". - -## Frequency Limiting in Trace Filtering - -Frequency filtering is an integral aspect of trace filtering, offering an optional mechanism to limit the observable frequency of individual trace messages. - -In essence, this involves a fair and probabilistic suppression of messages within a particular trace when their moving-average frequency surpasses a specified threshold parameter. - -The frequency limiter, in addition to controlling message frequency, emits a suppression summary message under specific conditions: - -- When message suppression commences. -- Every 10 seconds during active limiting, providing the count of suppressed messages. -- When message suppression concludes, indicating the total number of suppressed messages. - -Usually frequency limiters can be just added by configuration, for special cases you -can construct them in your code. Each frequency limiter is assigned a name for identification purposes: - -```haskell -limitFrequency - :: forall a m . MonadUnliftIO m - => Double -- messages per second - -> Text -- name of this limiter - -> Trace m TraceDispatcherMessage -- the limiter's messages - -> Trace m a -- the trace subject to limitation - -> m (Trace m a) -- the original trace -``` - -It is important to note that frequency filtering is designed to be applied selectively to a subset of traces, specifically those identified as potentially noisy. The configuration of frequency limits can thus be tailored to this subset of traces. - -## Configuration - -The configurability of dispatchers provided by this library relies on: - -1. __Tracer Namespace-based Configurability__: Configurable down to single message granularity based on tracer namespaces. - -2. __Runtime Reconfigurability__: Triggered by invoking `configureTracers`, enabling changes during program execution. - -The usual form to provide a configuration is via a configuration file, which can be in JSON or YAML format. The options that -can be given based on a namespace are: `severity`, `detail`, `backends` and `limiter`. - -Backends can be a combination of `Forwarder`, `EKGBackend`, `PrometheusSimple [suffix|nosuffix] [bindhost] ` and -one of `Stdout MachineFormat`, `Stdout HumanFormatColoured` and `Stdout HumanFormatUncoloured`. - -The connection for the `Forwarder` backend is provided on the application command line. It is a socket path over which applications like `cardano-node` connect with `cardano-tracer`. `--tracer-socket-path-connect /path/to/forward.sock` sets -the backends's role to `Initiator`, whereas `--tracer-socket-path-accept /path/to/forward.sock` sets it to `Responder`. Except for debugging purposes, the former should be chosen: the application takes the `Initiator` role, and `cardano-tracer` is -in the `Responder` role, which means setting its network `tag` to `AcceptAt` in its config (see there). - -The `PrometheusSimple` backend provides Prometheus metrics _directly from the process_, without forwarding. It always applies to all tracers globally, and should only be configured once. -Providing an available port number in the connection string is mandatory; this will bind to localhost only by default. By specifying a bind host, the metrics can be queried remotely, e.g. over IPv4 by -binding to `0.0.0.0`, or IPv6 by binding to `::`. Metrics will be available under the URL `/metrics`. -The `nosuffix` modifier removes suffixes like `_int` from metrics names, making them more similar to those in the old system; `suffix` is the implicit default and can be omitted. - -*CAUTION*: Generally allowing remote queries of Prometheus metrics is risky and should only be done in an environment you control. - -```yaml -# Use new tracing -UseTraceDispatcher: True - -TraceOptions: - "": # Options for all tracers, if not overwritten: - severity: Notice - detail: DNormal - backends: - - Stdout MachineFormat - - EKGBackend - - Forwarder - - 'PrometheusSimple :: 1234' # Prometheus metrics available over IPv6 (and localhost) on port 1234 - - ChainDB: # Show as well messages with severity Info for all ChainDB traces. - severity: Info - detail: DDetailed - - ChainDB.AddBlockEvent.AddedBlockToQueue: # Limit the AddedBlockToQueue events to a maximum of two per second. - maxFrequency: 2.0 - -TraceOptionForwarder: # Configure the forwarder - maxReconnectDelay: 20 - -# Any metrics emitted will get this prefix -TraceOptionMetricsPrefix: "cardano.node.metrics." -``` - -The same in JSON looks like this: - -```json -{ - "UseTraceDispatcher": true, - "TraceOptions": { - "": { - "severity": "Notice", - "detail": "DNormal", - "backends": [ - "Stdout MachineFormat", - "EKGBackend", - "Forwarder", - "PrometheusSimple :: 1234" - ] - }, - "ChainDB": { - "severity": "Info", - "detail": "DDetailed" - }, - "ChainDB.AddBlockEvent.AddedBlockToQueue": { - "maxFrequency": 2.0 - } - }, - "TraceOptionForwarder": { - "maxReconnectDelay": 20 - }, - "TraceOptionMetricsPrefix": "cardano.node.metrics." -} -``` - -For explanations of the trace forwarder option refer to the following document: - -[New Tracing Quickstart](https://github.com/input-output-hk/cardano-node-wiki/wiki/New-Tracing-Quickstart) - -When `TraceOptions` is empty, or other entries are missing in the configuration file, default entries are taken from -[Cardano.Node.Tracing.DefaultTraceConfig](https://github.com/intersectmbo/cardano-node/blob/master/cardano-node/src/Cardano/Node/Tracing/DefaultTraceConfig.hs) module. - -# Advanced Tracer Topics - -The functionality of the new tracing system is composable using basic combinators defined on contravariant tracing. -In this part of the document we introduce the underlying functions. You should look here if you want to -implement some advanced functionality. - -## Integrating a New Tracer into cardano-node - -Presently, the process of adding a new tracer involves making changes in three specific modules. However, we anticipate that this requirement will be simplified once the old tracing system is phased out. The current modules where modifications are needed to add a new tracer are: - -- __Cardano.Node.Tracing.Tracers__ - -- __Cardano.Node.Tracing.Documentation__ - -- __Cardano.Node.Tracing.Consistency__ - -## Message Filtering based on Severity - -The concept of severity in the new system is articulated through an enumeration outlined in [section 6.2.1 of RFC 5424](https://tools.ietf.org/html/rfc5424#section-6.2.1). The severity levels, ranging from the least severe (`Debug`) to the most severe (`Emergency`), provide a framework for ignoring messages with severity levels below a globally configured severity cutoff. - -To enhance severity filtering, we introduce the option of `Silence`. This addition allows for the unconditional silencing of a specific trace, essentially representing the deactivation of tracers — a semantic continuation of the functionality in the legacy system. - -The following trace combinators play a role in modifying the annotated severity of a trace: - -```haskell --- Sets severities for the messages in this trace based on the MetaTrace class -withSeverity :: forall m a. (Monad m, MetaTrace a) => Trace m a -> Trace m a - --- Sets severity for the messages in this trace -setSeverity :: Monad m => SeverityS -> Trace m a -> Trace m a - --- Filters out messages with a severity less than the given one -filterTraceBySeverity :: Monad m - => Maybe SeverityF - -> Trace m a - -> Trace m a -``` - -When these combinators are applied multiple times to a single trace, only the outermost application has an effect, rendering subsequent applications inconsequential. - -In the absence of trace context or configured severity overrides, `Info` serves as the default severity. - -## Comprehensive Trace Filtering - -A versatile filtering mechanism is provided, granting access to both the object and a `LoggingContext`, encompassing the namespace along with optional severity, privacy, and detail level: - -```haskell --- Don't process further if the result of the selector function --- is False. -filterTrace :: (Monad m) - => ((LoggingContext, a) -> Bool) - -> Trace m a - -> Trace m a - --- Context carried by any log message -data LoggingContext = LoggingContext { - lcNSInner :: [Text] - , lcNSPrefix :: [Text] - , lcSeverity :: Maybe SeverityS - , lcPrivacy :: Maybe Privacy - , lcDetails :: Maybe DetailLevel - } -``` - -For instance, you can create a filter function to display only _Public_ messages: - -```haskell -filterTrace (\(c, _) -> case lcPrivacy c of - Just s -> s == Public - Nothing -> False) -- privacy unknown, don't send out -``` - -This capability allows for flexible and fine-grained control over the inclusion or exclusion of messages based on a variety of contextual criteria. - -## Privacy Annotations - -In our tracing system, privacy annotations empower the distinction of messages that remain within the system and are not sent over the network, but are solely displayed on stdout. This privacy feature is defined through the following enumeration: - -```haskell -data Privacy - = Confidential | Public -``` - -When a trace carries a __Confidential__ privacy level, it implies that the trace remains internalized within the system, with the exception of being displayed via standard output. - -The annotation mechanism for privacy mirrors that of severity: - -```haskell --- Sets privacy for the messages in this trace based on the MetaTrace class -withPrivacy :: forall m a. (Monad m, MetaTrace a) => Trace m a -> Trace m a - --- Sets privacy Confidential for the messages in this trace -privately :: Monad m => Trace m a -> Trace m a - --- Only processes messages further with a privacy greater than the given one -filterTraceByPrivacy :: (Monad m) => - Maybe Privacy - -> Trace m a - -> Trace m a -``` - -In the absence of privacy annotations, `Public` serves as the default privacy level. - -Trace privacy, unlike severity, is not configurable. - -Trace filtering responds to privacy context as follows: - -1. Traces marked as `Confidential` can solely reach the `stdout` trace-out. -2. Traces marked as `Public` reach both the `stdout` and `trace-forwarder` trace-outs. - -Effectively, preventing leaks of `Confidential` traces due to logging misconfiguration is inherent — any potential leak can only occur if the user explicitly permits network access to the standard output of the traced program. - -## Detail Level in Trace Presentation - -A crucial facet of trace presentation is the degree of detail provided for each trace. This consideration holds significance because the generated program traces may inherently include exhaustive details. Presenting every intricate detail in its entirety could impose a considerable burden on trace handling. - -To address this, a configurable mechanism for controlling the level of detail is introduced, allowing customization down to specific messages. - -The control over detail levels is manifested through the following enumeration: - -```haskell -data DetailLevel = DMinimal | DNormal | DDetailed | DMaximum -``` - -This detail level control ensures that the presentation of traces strikes a balance between informativeness and efficiency, catering to diverse needs and preferences. - -## Fold-Based Aggregation - -When there is a need for aggregating information from multiple consecutive messages, the following fold functions can be employed: - -```haskell --- Folds the monadic cata function with acc over a. --- Uses an MVar to store the state -foldTraceM :: forall a acc m . (MonadUnliftIO m) - => (acc -> LoggingContext -> a -> m acc) - -> acc - -> Trace m (Folding a acc) - -> m (Trace m a) - --- Like foldTraceM, but filters the trace by a predicate. -foldCondTraceM :: forall a acc m . (MonadUnliftIO m) - => (acc -> LoggingContext -> a -> m acc) - -> acc - -> (a -> Bool) - -> Trace m (Folding a acc) - -> m (Trace m a) -``` - -To facilitate typechecking, the `Folding` type is utilized, and it can be removed by the `unfold` function: - -```haskell -newtype Folding a acc = Folding acc - -unfold :: Folding a b -> b -unfold (Folding b) = b -``` - -Given that tracers can be invoked from different threads, an `MVar` is internally employed to ensure correct behavior. - -As an illustrative example, let's consider a scenario where we want to log a measurement value along with the sum of all measurements recorded thus far. We define a `Stats` type to store the sum alongside the measurement, and a `fold`-compatible function to calculate new `Stats` from old `Stats` and `Measure`: - -```haskell -data Stats = Stats { - sMeasure :: Double, - sSum :: Double - } - -calculateS :: MonadIO m => Stats -> LoggingContext -> Double -> m Stats -calculateS Stats{..} _ val = pure $ Stats val (sSum + val) -``` - -With these components in place, we can define the aggregation tracer using the `foldTraceM` procedure. Subsequently, when we log measurement values, the tracer outputs the corresponding `Stats`: - -```haskell -aggregationTracer <- foldTraceM calculateS (Stats 0.0 0.0) exampleTracer -traceWith 1.1 aggregationTracer -- measure: 1.1 sum: 1.1 -traceWith 2.0 aggregationTracer -- measure: 2.0 sum: 3.1 -``` - -This demonstrates how fold-based aggregation facilitates the accumulation of information over consecutive messages, enabling insightful data summaries. - -## Dispatcher Routing Mechanism - -In the process of defining the trace dispatcher, it can be advantageous to employ a set of functions for routing messages. When there's a need to dispatch a trace message to different tracers based on specific criteria, the following function proves valuable: - -```haskell --- Allows routing to different tracers, based on the message being processed. --- The second argument must mappend all possible tracers of the first --- argument to one tracer. This is required for the configuration! -routingTrace :: forall m a. Monad m - => (a -> m (Trace m a)) - -> Trace m a - -> Trace m a - -let resTrace = routingTrace routingFunction (tracer1 <> tracer2) - where - routingFunction LO1 {} = tracer1 - routingFunction LO2 {} = tracer2 -``` - -In this context, the second argument must encapsulate the combination (using `mappend`) of all tracers utilized in the routing trace function into a single tracer. This amalgamation is crucial for the subsequent configuration steps. - -While a more secure interface could be constructed using a map of values to tracers, the choice here prioritizes the ability for comprehensive pattern matching. The flexibility offered by full pattern matching outweighs the potential disadvantages, given the context. - -Similarly, to route a single trace to multiple tracers simultaneously, the fact that `Tracer` is a `Semigroup` allows us to utilize the `<>` operator or `mconcat` for lists of tracers: - -```haskell -(<>) :: Monoid m => m -> m -> m -mconcat :: Monoid m => [m] -> m -``` - -For instance, to direct messages from one trace to two tracers simultaneously, we can use: - -```haskell -let resTrace = tracer1 <> tracer2 -``` - -## Documentation Generation - -The documentation for tracers is periodically generated and can be accessed in the cardano-node-wiki repository at the following path: [cardano-node-wiki/tracers_doc_generated.md](https://github.com/input-output-hk/cardano-node-wiki/blob/main/docs/new-tracing/tracers_doc_generated.md). - -To generate the documentation within GHCi, load the `Cardano.Node.Tracing.Documentation` module and execute the `runTraceDocumentationCmd` function with the appropriate parameters: - -```haskell -data TraceDocumentationCmd - = TraceDocumentationCmd - { tdcConfigFile :: FilePath -- file path to a node config file - , tdcOutput :: FilePath -- file path to output the documentation - } - -runTraceDocumentationCmd - :: TraceDocumentationCmd - -> IO () -``` - -The self-documentation capabilities of `trace-dispatcher` rely on documentation annotations provided by the `documentFor` and `metricsDocFor` methods within the `MetaTrace` typeclass. Additionally, a specialized dispatcher execution mode emits documentation for all annotated traces, utilizing the tracer namespace to structure the document. - -To generate the documentation, first, call `documentTracer` for each message type with the associated tracers, then use `docuResultsToText` with the accumulated lists. - -```haskell --- This function calls document tracers and returns a DocTracer result -documentTracer :: forall a. - MetaTrace a - => Trace IO a - -> IO DocTracer - --- Finally, generate text from all the builders -docuResultsToText :: DocTracer -> TraceConfig -> IO Text - --- For example - b1 <- documentTracer traceForgeEventDocu [t1, t2] - b2 <- documentTracer .. .. - .. - bn <- documentTracer .. .. - writeFile "Docu.md" (docuResultsToText (b1 ++ b2 ++ ... ++ bn)) -``` - -A generated documentation snippet for a simple message may appear as follows: - -__Forge.Loop.StartLeadershipCheck__ - -> Start of the leadership check. - -Severity: `Info` -Privacy: `Public` -Details: `DNormal` - -From the current configuration: - -Backends: - `EKGBackend`, - `Stdout MachineFormat`, - `Forwarder` -Filtered `Visible` by config value: `Info` - -## Consistency Checking - -As namespaces are essentially strings, the type system doesn't inherently ensure the consistency of namespaces. To address this concern, we have incorporated consistency check functionality into `trace-dispatcher`. Within the node, you can invoke the following procedure from the `Cardano.Node.Tracing.Consistency` module. It returns an array of `Text`, an empty list indicating that everything is in order. - -```haskell --- | Check the configuration in the given file. --- Check the general structure of namespaces. --- An empty return list means everything is well. -checkNodeTraceConfiguration :: - FilePath -- path to a node configuration file - -> IO [Text] -``` - -An example text is "Config namespace error: i.am.an.invalid.namespace" . - -This check is performed within a `cardano-node` test case (`Test.Cardano.Tracing.NewTracing.Consistency.tests`), ensuring that it is automatically verified with each pull request. - -The consistency checks cover the following aspects: - -- Every namespace in `all namespaces` must be unique. - -- Each namespace is a terminal and is not a part of another namespace. - -- Namespaces in the `severityFor`, `privacyFor`, `detailsFor`, `documentFor`, and `metricsDocFor` functions are consistent with the `allNamespaces` definition. - -- Any namespace in the configuration must be found by a hierarchical lookup in `all namespaces`. - -If the checker encounters any problems it emits a `TracerConsistencyWarnings` message through the -`Cardano.Logging.TraceDispatcherMessage` type. The message is routed via the `Reflection` namespace -and carries `Warning` severity so that misconfigured namespaces are surfaced prominently in both the -logs and forwarded tracing output. - -## Trace Backends Overview - -As mentioned earlier, trace backends serve as the final destinations for all traces once they have undergone trace interpretation, resulting in metrics and messages. The system defines three trace backends: - -1. __Standard Tracer:__ This is the fundamental standard output tracer. Notably, it can accept both regular and confidential traces. - - ```haskell - standardTracer :: forall m. (MonadIO m) - => m (Trace m FormattedMessage) - ``` - -2. __Trace-Forward Tracer:__ This is a network-only sink dedicated to forwarding messages using typed protocols over TCP or local sockets. It exclusively handles public traces. - - ```haskell - forwardTracer :: forall m. (MonadIO m) - => ForwardSink TraceObject - -> Trace m FormattedMessage - ``` - -3. __EKG Tracer:__ This tracer submits metrics to a local EKG store (which then can be exposed directly via the `PrometheusSimple` backend and/or forwarded). - - ```haskell - ekgTracer :: MonadIO m - => Metrics.Store - -> m (Trace m FormattedMessage) - ``` - -It's imperative to note that constructing more than one instance of each tracer in an application should absolutely be avoided, as it may result in unexpected behaviour. - -## Data Points Overview and Deprecation Notice - -In the imminent future, `DataPoint`s will be deprecated and replaced by a subscription model. - -`DataPoint`s provide a means for processes outside of `cardano-node` to inquire about the node's runtime state. Essentially similar to metrics, `DataPoint`s, however, have an Algebraic Data Type (ADT) structure, allowing them to represent structured information beyond simple metrics. This feature enables external processes to query and access specific details of a running cardano-node, such as the node's basic information. - -Implemented as special tracers, `DataPoint`s package objects into `DataPoint` constructors and necessitate a `ToJSON` instance for these objects. The set of `DataPoint`s provided by the node follows the same namespace structure as metrics and log messages. While `DataPoint`s operate independently of tracing, they are stored locally, facilitating on-demand queries for the latest values of a specific `DataPoint`. - -It is important to note that DataPoints will soon be deprecated, and a subscription model will take their place. Additionally, detailed information on accepting DataPoints from an external process can be found in [this document](https://github.com/input-output-hk/cardano-node-wiki/wiki/cardano-node-and-DataPoints:-demo). The [`demo-acceptor`](https://github.com/intersectmbo/cardano-node/blob/master/cardano-tracer/demo/acceptor.hs) application is available for requesting specific DataPoints by name and displaying their values. - -```haskell --- A simple dataPointTracer supporting the construction of a namespace. -mkDataPointTracer :: forall dp. (ToJSON dp, MetaTrace dp, NFData dp) - => Trace IO DataPoint - -> IO (Trace IO dp) -``` - -# Appendix - -## References - -The following document is periodically regenerated to provide comprehensive documentation for all trace messages, metrics, and data points within `cardano-node`. It also outlines the handling of these messages based on the current default configuration: - -[Generated Cardano Trace Documentation](https://github.com/input-output-hk/cardano-node-wiki/wiki/tracers_doc_generated) - -For a quick start for administrators transitioning to the new tracing system, refer to the following document: - -[New Tracing Quickstart](https://github.com/input-output-hk/cardano-node-wiki/wiki/New-Tracing-Quickstart) - -Additionally, this document delves into `cardano-tracer`, a separate application designed for logging and monitoring Cardano nodes: - -[Cardano Tracer](https://github.com/intersectmbo/cardano-node/blob/master/cardano-tracer/docs/cardano-tracer.md) - -## Future work - -### Versioning - -Versioning for trace messages stands as a crucial component that significantly contributes to the functionality and maintainability of our system. We acknowledge the importance of associating version numbers with log messages, ensuring transparency and consistency throughout the application lifecycle. - -Adhering to a change protocol and establishing a clear correlation between node version numbers and trace version numbers is a prudent strategy. This approach aids in the effective management and communication of updates, alterations, and improvements to our tracing system. Such alignment guarantees that any modifications to the tracing system are accurately reflected and comprehended by both the development team and the broader Cardano community. - -Anticipating the forthcoming development phase, we are eager to design and implement this versioning feature. Our goal is to seamlessly integrate it into our overall system architecture, bolstering our capacity to adapt and evolve. This ensures a clear, consistent, and structured approach to trace messages, enhancing our system's resilience and comprehensibility. - -### Trace Consumers - -We are excited to introduce the innovative concept of "trace consumers" into the Cardano Tracer system. This novel approach empowers trace consumers to register with the `cardano-tracer` application and selectively receive messages based on their subscriptions. We anticipate that this concept will significantly improve the efficiency and flexibility of our tracing system. - -The introduction of trace consumers represents a robust and tailored approach to message retrieval, aligning seamlessly with the evolving needs of our network. This concept provides consumers with the ability to specify their message preferences, ensuring that they receive only the data directly relevant to their operations. - -As part of this development initiative, we plan to phase out the use of data points. We believe that this evolution will render data points redundant in future versions of the tracing system. The transition to trace consumers aims to streamline our data retrieval processes, eliminating the need for unnecessary data points and offering a more sophisticated and focused mechanism for trace message consumption. diff --git a/trace-dispatcher/src/Cardano/Logging.hs b/trace-dispatcher/src/Cardano/Logging.hs deleted file mode 100644 index 9ae3531d7d6..00000000000 --- a/trace-dispatcher/src/Cardano/Logging.hs +++ /dev/null @@ -1,21 +0,0 @@ -module Cardano.Logging ( - module X - ) where - -import Cardano.Logging.Configuration as X -import Cardano.Logging.ConfigurationParser as X -import Cardano.Logging.Consistency as X -import Cardano.Logging.DocuGenerator as X -import Cardano.Logging.Formatter as X -import Cardano.Logging.FrequencyLimiter as X -import Cardano.Logging.Trace as X -import Cardano.Logging.TraceDispatcherMessage as X -import Cardano.Logging.Tracer.Composed as X -import Cardano.Logging.Tracer.DataPoint as X -import Cardano.Logging.Tracer.EKG as X -import Cardano.Logging.Tracer.Forward as X -import Cardano.Logging.Tracer.Standard as X -import Cardano.Logging.Types as X -import Cardano.Logging.Utils as X - -import Control.Tracer as X hiding (Tracer, nullTracer, traceWith) diff --git a/trace-dispatcher/src/Cardano/Logging/Configuration.hs b/trace-dispatcher/src/Cardano/Logging/Configuration.hs deleted file mode 100644 index 501ce7d22de..00000000000 --- a/trace-dispatcher/src/Cardano/Logging/Configuration.hs +++ /dev/null @@ -1,428 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE ScopedTypeVariables #-} - - -module Cardano.Logging.Configuration - ( ConfigReflection (..) - , emptyConfigReflection - , configureTracers - , withNamespaceConfig - , filterSeverityFromConfig - , withDetailsFromConfig - , withBackendsFromConfig - , withLimitersFromConfig - - , maybeSilent - , isSilentTracer - , hasNoMetrics - - , getSeverity - , getDetails - , getBackends - ) where - -import Cardano.Logging.DocuGenerator (addFiltered, addLimiter, addSilent) -import Cardano.Logging.FrequencyLimiter (limitFrequency) -import Cardano.Logging.Trace -import Cardano.Logging.TraceDispatcherMessage -import Cardano.Logging.Types - -import Control.Monad (unless) -import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.IO.Unlift (MonadUnliftIO) -import qualified Control.Tracer as T -import Data.IORef (IORef, modifyIORef, newIORef, readIORef, writeIORef) -import Data.List (maximumBy, nub) -import qualified Data.Map as Map -import Data.Maybe (fromMaybe, mapMaybe) -import qualified Data.Set as Set -import Data.Text (Text, intercalate, unpack) - - --- | Call this function at initialisation, and later for reconfiguration. --- Config reflection is used to optimise the tracers and has to collect --- information about the tracers. Although it is possible to give more then --- one tracer of the same time, it is not a common case to do this. -configureTracers :: forall a m. - (MetaTrace a - , MonadIO m) - => ConfigReflection - -> TraceConfig - -> [Trace m a] - -> m () -configureTracers cr config tracers = do - mapM_ (\t -> do - configureTrace TCReset t - configureAllTrace (TCConfig config) t - configureTrace (TCOptimize cr) t) - tracers - where - configureTrace control (Trace tr) = - T.traceWith tr (emptyLoggingContext, Left control) - configureAllTrace control (Trace tr) = - mapM_ (\ ns -> - T.traceWith - tr - (emptyLoggingContext - { lcNSInner = nsInner ns} - , Left control)) - (allNamespaces :: [Namespace a]) - --- | Switch off any message of a particular tracer based on the configuration. --- If the top tracer is silent and no subtracer is not silent, then switch it off -maybeSilent :: forall m a. (MonadIO m) => - ( TraceConfig -> Namespace a -> Bool) - -> [Text] - -> Bool - -> Trace m a - -> m (Trace m a) -maybeSilent selectorFunc prefixNames isMetrics (Trace tr) = do - ref <- liftIO (newIORef Nothing) - contramapMCond (Trace tr) (mapFunc ref) - where - mapFunc ref = - \case - (lc, Right a) -> do - silence <- liftIO $ readIORef ref - if silence == Just True - then pure Nothing - else pure $ Just (lc, Right a) - (lc, Left (TCConfig c)) -> do - silence <- liftIO $ readIORef ref - case silence of - Nothing -> do - let val = selectorFunc c (Namespace prefixNames [] :: Namespace a) - liftIO $ writeIORef ref (Just val) - Just _ -> pure () - pure $ Just (lc, Left (TCConfig c)) - (lc, Left TCReset) -> do - liftIO $ writeIORef ref Nothing - pure $ Just (lc, Left TCReset) - (lc, Left (TCOptimize cr)) -> do - silence <- liftIO $ readIORef ref - case silence of - Just True -> liftIO $ if isMetrics - then modifyIORef (crNoMetrics cr) (Set.insert prefixNames) - else modifyIORef (crSilent cr) (Set.insert prefixNames) - _ -> pure () - liftIO $ modifyIORef (crAllTracers cr) (Set.insert prefixNames) - pure $ Just (lc, Left (TCOptimize cr)) - (lc, Left c@TCDocument {}) -> do - silence <- liftIO $ readIORef ref - unless isMetrics - (addSilent c silence) - pure $ Just (lc, Left c) - - --- When all messages are filtered out, it is silent -isSilentTracer :: forall a. MetaTrace a => TraceConfig -> Namespace a -> Bool -isSilentTracer tc (Namespace prefixNS _) = - let allNS = allNamespaces :: [Namespace a] - in all (\ (Namespace _ innerNS) -> - isFiltered (Namespace prefixNS innerNS :: Namespace a)) - allNS - where - isFiltered :: Namespace a -> Bool - isFiltered ns = - let msgSeverity = severityFor ns Nothing - severityFilter = getSeverity tc ns - in case severityFilter of - SeverityF Nothing -> True -- silent config - SeverityF (Just sevF) -> - case msgSeverity of - Just msev -> sevF > msev - Nothing -> False -- Impossible case - --- When all messages are filtered out, it is silent -hasNoMetrics :: forall a. MetaTrace a => TraceConfig -> Namespace a -> Bool -hasNoMetrics _tc _ns = - let allNS = allNamespaces :: [Namespace a] - in all (null . metricsDocFor) allNS - --- | Take a selector function called 'extract'. --- Take a function from trace to trace with this config dependent value. --- In this way construct a trace transformer with a config value -withNamespaceConfig :: forall m a b c. (MonadIO m, Ord b) => - String - -> (TraceConfig -> Namespace a -> m b) - -> (Maybe b -> Trace m c -> m (Trace m a)) - -> Trace m c - -> m (Trace m a) -withNamespaceConfig name extract withConfig tr = do - ref <- liftIO (newIORef (Left (Map.empty, Nothing))) - pure $ contramapM' (mapFunc ref) - where - mapFunc ref = - \case - (lc, Right a) -> do - eitherConf <- liftIO $ readIORef ref - case eitherConf of - Right val -> do - tt <- withConfig (Just val) tr - T.traceWith (unpackTrace tt) (lc, Right a) - Left (cmap, Just v) -> - case Map.lookup (lcNSPrefix lc ++ lcNSInner lc) cmap of - Just val -> do - tt <- withConfig (Just val) tr - T.traceWith (unpackTrace tt) (lc, Right a) - Nothing -> do - tt <- withConfig (Just v) tr - T.traceWith (unpackTrace tt) (lc, Right a) - -- This can happen during reconfiguration, so we don't throw an error any more - Left (_cmap, Nothing) -> pure () - (lc, Left TCReset) -> do - liftIO $ writeIORef ref (Left (Map.empty, Nothing)) - tt <- withConfig Nothing tr - T.traceWith (unpackTrace tt) (lc, Left TCReset) - (lc, Left (TCConfig c)) -> do - let nst = lcNSPrefix lc ++ lcNSInner lc - !val <- extract c (Namespace (lcNSPrefix lc) (lcNSInner lc)) - eitherConf <- liftIO $ readIORef ref - case eitherConf of - Left (cmap, Nothing) -> - case Map.lookup nst cmap of - Nothing -> do - liftIO - $ writeIORef ref (Left (Map.insert nst val cmap, Nothing)) - tt <- withConfig (Just val) tr - T.traceWith (unpackTrace tt) (lc, Left (TCConfig c)) - Just v -> do - if v == val - then do - Trace tt <- withConfig (Just val) tr - T.traceWith tt (lc, Left (TCConfig c)) - else error $ "Inconsistent trace configuration with context " - ++ show nst - Right _val -> error $ "Trace not reset before reconfiguration (1)" - ++ show nst - Left (_cmap, Just _v) -> error $ "Trace not reset before reconfiguration (2)" - ++ show nst - (lc, Left (TCOptimize cr)) -> do - eitherConf <- liftIO $ readIORef ref - let nst = lcNSPrefix lc ++ lcNSInner lc - case eitherConf of - Left (cmap, Nothing) -> - case nub (Map.elems cmap) of - [] -> pure () - [val] -> do - liftIO $ writeIORef ref $ Right val - Trace tt <- withConfig (Just val) tr - T.traceWith tt (lc, Left (TCOptimize cr)) - _ -> let decidingDict = - foldl - (\acc e -> Map.insertWith (+) e (1 :: Int) acc) - Map.empty - (Map.elems cmap) - (mostCommon, _) = maximumBy - (\(_, n') (_, m') -> compare n' m') - (Map.assocs decidingDict) - newmap = Map.filter (/= mostCommon) cmap - in do - liftIO $ writeIORef ref (Left (newmap, Just mostCommon)) - Trace tt <- withConfig Nothing tr - T.traceWith tt (lc, Left (TCOptimize cr)) - Right _val -> error $ "Trace not reset before reconfiguration (3)" - ++ show nst - Left (_cmap, Just _v) -> - error $ "Trace not reset before reconfiguration (4)" - ++ show nst - (lc, Left dc@TCDocument {}) -> do - eitherConf <- liftIO $ readIORef ref - let nst = lcNSPrefix lc ++ lcNSInner lc - case eitherConf of - Right val -> do - tt <- withConfig (Just val) tr - T.traceWith - (unpackTrace tt) (lc, Left dc) - Left (cmap, Just v) -> - case Map.lookup nst cmap of - Just val -> do - tt <- withConfig (Just val) tr - T.traceWith (unpackTrace tt) (lc, Left dc) - Nothing -> do - tt <- withConfig (Just v) tr - T.traceWith (unpackTrace tt) (lc, Left dc) - Left (_cmap, Nothing) -> error ("Missing configuration(2) " <> name <> " ns " <> show nst) - - --- | Filter a trace by severity and take the filter value from the config -filterSeverityFromConfig :: (MonadIO m) => - Trace m a - -> m (Trace m a) -filterSeverityFromConfig = - withNamespaceConfig - "severity" - getSeverity' - (\sev tr -> contramapMCond tr (mapF sev)) - where - mapF confSev = - \case - (lc, Right cont) -> do - let visible = case lcSeverity lc of - (Just s) -> case confSev of - Just (SeverityF (Just fs)) -> s >= fs - Just (SeverityF Nothing) -> False - Nothing -> True - Nothing -> True - if visible - then pure $ Just (lc, Right cont) - else pure Nothing - (lc, Left c@TCDocument {}) -> do - addFiltered c confSev - pure (Just (lc, Left c)) - (lc, anx) -> do - pure (Just (lc, anx)) - - --- | Set detail level of a trace from the config -withDetailsFromConfig :: (MonadIO m) => - Trace m a - -> m (Trace m a) -withDetailsFromConfig = - withNamespaceConfig - "details" - getDetails' - (\mbDtl b -> case mbDtl of - Just dtl -> pure $ setDetails dtl b - Nothing -> pure $ setDetails DNormal b) - --- | Routing and formatting of a trace from the config -withBackendsFromConfig :: (MonadIO m) => - (Maybe [BackendConfig] -> Trace m FormattedMessage -> m (Trace m a)) - -> m (Trace m a) -withBackendsFromConfig rappendPrefixNameAndFormatter = - withNamespaceConfig - "backends" - getBackends' - rappendPrefixNameAndFormatter - (Trace T.nullTracer) - -data Limiter m a = Limiter Text Double (Trace m a) - -instance Eq (Limiter m a) where - Limiter t1 _ _ == Limiter t2 _ _ = t1 == t2 - -instance Ord (Limiter m a) where - Limiter t1 _ _ <= Limiter t2 _ _ = t1 <= t2 - -instance Show (Limiter m a) where - show (Limiter name _ _) = "Limiter " <> unpack name - - --- | Routing and formatting of a trace from the config -withLimitersFromConfig :: forall a m . (MonadUnliftIO m) - => Trace m TraceDispatcherMessage - -> Trace m a - -> m (Trace m a) -withLimitersFromConfig tri tr = do - ref <- liftIO $ newIORef Map.empty - withNamespaceConfig - "limiters" - (getLimiter ref) - withLimiter - tr - where - -- | May return a limiter, which is a stateful transformation from trace to trace - getLimiter :: - IORef (Map.Map Text (Limiter m a)) - -> TraceConfig - -> Namespace a - -> m (Maybe (Limiter m a)) - getLimiter stateRef config ns = - case getLimiterSpec config ns of - Nothing -> pure Nothing - Just (name, frequency) -> - if frequency == 0 - then pure Nothing - else do - state <- liftIO $ readIORef stateRef - case Map.lookup name state of - Just limiter -> pure $ Just limiter - Nothing -> do - limiterTrace <- limitFrequency frequency name tri tr - let limiter = Limiter name frequency limiterTrace - liftIO $ writeIORef stateRef (Map.insert name limiter state) - pure $ Just limiter - - withLimiter :: - Maybe (Maybe (Limiter m a)) - -> Trace m a - -> m (Trace m a) - withLimiter Nothing tr' = pure tr' - withLimiter (Just Nothing) tr' = pure tr' - withLimiter (Just (Just (Limiter n d (Trace trli)))) (Trace tr') = - pure $ contramapM' (mapFunc (Limiter n d (Trace trli)) (Trace tr')) - mapFunc (Limiter n d (Trace trli)) (Trace tr') = - \case - (lc, Right v) -> - T.traceWith trli (lc, Right v) - (lc, Left c@TCDocument {}) -> do - addLimiter c (n, d) - T.traceWith tr' (lc, Left c) - (lc, Left c) -> - T.traceWith tr' (lc, Left c) - --------------------------------------------------------- - --- | If no severity can be found in the config, it is set to Warning -getSeverity :: TraceConfig -> Namespace a -> SeverityF -getSeverity config ns = - fromMaybe (SeverityF (Just Warning)) - (getOption severitySelector config (nsGetComplete ns)) - where - severitySelector :: ConfigOption -> Maybe SeverityF - severitySelector (ConfSeverity s) = Just s - severitySelector _ = Nothing - -getSeverity' :: Applicative m => TraceConfig -> Namespace a -> m SeverityF -getSeverity' config ns = pure $ getSeverity config ns - --- | If no details can be found in the config, it is set to DNormal -getDetails :: TraceConfig -> Namespace a -> DetailLevel -getDetails config ns = - fromMaybe DNormal (getOption detailSelector config (nsGetComplete ns)) - where - detailSelector :: ConfigOption -> Maybe DetailLevel - detailSelector (ConfDetail d) = Just d - detailSelector _ = Nothing - -getDetails' :: Applicative m => TraceConfig -> Namespace a -> m DetailLevel -getDetails' config n = pure $ getDetails config n - --- | If no backends can be found in the config, it is set to --- [EKGBackend, Forwarder, Stdout HumanFormatColoured] -getBackends :: TraceConfig -> Namespace a -> [BackendConfig] -getBackends config ns = - fromMaybe [EKGBackend, Forwarder, Stdout HumanFormatColoured] - (getOption backendSelector config (nsGetComplete ns)) - where - backendSelector :: ConfigOption -> Maybe [BackendConfig] - backendSelector (ConfBackend s) = Just s - backendSelector _ = Nothing - -getBackends' :: Applicative m => TraceConfig -> Namespace a -> m [BackendConfig] -getBackends' config ns = pure $ getBackends config ns - --- | May return a limiter specification -getLimiterSpec :: TraceConfig -> Namespace a -> Maybe (Text, Double) -getLimiterSpec config ns = getOption limiterSelector config (nsGetComplete ns) - where - limiterSelector :: ConfigOption -> Maybe (Text, Double) - limiterSelector (ConfLimiter f) = Just (intercalate "." (nsPrefix ns ++ nsInner ns), f) - limiterSelector _ = Nothing - --- | Searches in the config to find an option -getOption :: (ConfigOption -> Maybe a) -> TraceConfig -> [Text] -> Maybe a -getOption sel config [] = - case Map.lookup [] (tcOptions config) of - Nothing -> Nothing - Just options -> case mapMaybe sel options of - [] -> Nothing - (opt : _) -> Just opt -getOption sel config ns = - case Map.lookup ns (tcOptions config) of - Nothing -> getOption sel config (init ns) - Just options -> case mapMaybe sel options of - [] -> getOption sel config (init ns) - (opt : _) -> Just opt diff --git a/trace-dispatcher/src/Cardano/Logging/ConfigurationParser.hs b/trace-dispatcher/src/Cardano/Logging/ConfigurationParser.hs deleted file mode 100644 index a006aa15473..00000000000 --- a/trace-dispatcher/src/Cardano/Logging/ConfigurationParser.hs +++ /dev/null @@ -1,197 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} - -{-# OPTIONS_GHC -Wno-orphans #-} - -module Cardano.Logging.ConfigurationParser - ( - readConfiguration - , readConfigurationWithDefault - , configToRepresentation - ) where - -import Cardano.Logging.Types - -import Control.Applicative ((<|>)) -import Control.Exception (throwIO) -import qualified Data.Aeson as AE -import Data.ByteString (ByteString) -import qualified Data.ByteString.Char8 as BS -import Data.List as List (foldl') -import qualified Data.Map.Strict as Map -import Data.Maybe (catMaybes, listToMaybe) -import Data.Text (Text, intercalate, split) -import Data.Yaml - --- ----------------------------------------------------------------------------- --- Configuration file - --- | The external representation of a configuration file -data ConfigRepresentation = ConfigRepresentation { - traceOptions :: OptionsRepresentation - , traceOptionForwarder :: Maybe TraceOptionForwarder - , traceOptionNodeName :: Maybe Text - , traceOptionMetricsPrefix :: Maybe Text - , traceOptionResourceFrequency :: Maybe Int - , traceOptionLedgerMetricsFrequency :: Maybe Int - } - deriving (Eq, Ord, Show) - -instance AE.FromJSON ConfigRepresentation where - parseJSON (Object obj) = ConfigRepresentation - <$> obj .: "TraceOptions" - <*> obj .:? "TraceOptionForwarder" - <*> obj .:? "TraceOptionNodeName" - <*> obj .:? "TraceOptionMetricsPrefix" - <*> obj .:? "TraceOptionResourceFrequency" - <*> obj .:? "TraceOptionLedgerMetricsFrequency" - parseJSON _ = mempty - -instance AE.ToJSON ConfigRepresentation where - toJSON ConfigRepresentation{..} = object - [ "TraceOptions" .= traceOptions - , "TraceOptionForwarder" .= traceOptionForwarder - , "TraceOptionNodeName" .= traceOptionNodeName - , "TraceOptionMetricsPrefix" .= traceOptionMetricsPrefix - , "TraceOptionResourceFrequency" .= traceOptionResourceFrequency - , "TraceOptionLedgerMetricsFrequency" .= traceOptionLedgerMetricsFrequency - ] - -type OptionsRepresentation = Map.Map Text ConfigOptionRep - --- | In the external configuration representation for configuration files --- all options for a namespace are part of a record -data ConfigOptionRep = ConfigOptionRep - { severity :: Maybe SeverityF - , detail :: Maybe DetailLevel - , backends :: Maybe [BackendConfig] - , maxFrequency :: Maybe Double - } - deriving (Eq, Ord, Show) - -instance AE.FromJSON ConfigOptionRep where - parseJSON (Object obj) = ConfigOptionRep - <$> obj .:? "severity" - <*> obj .:? "detail" - <*> obj .:? "backends" - <*> obj .:? "maxFrequency" - - parseJSON _ = mempty - -instance AE.ToJSON ConfigOptionRep where - toJSON ConfigOptionRep{..} = object (conss []) - where - consMay attr = maybe id ((:) . (attr .=)) - conss = consMay "severity" severity - . consMay "detail" detail - . consMay "backends" backends - . consMay "maxFrequency" maxFrequency - -instance AE.ToJSON TraceConfig where - toJSON tc = toJSON (configToRepresentation tc) - --- | Read a configuration file and returns the internal representation -readConfiguration :: FilePath -> IO TraceConfig -readConfiguration fp = - either throwIO pure . parseRepresentation =<< BS.readFile fp - --- | Read a configuration file and returns the internal representation --- Uses values which are not in the file from the defaultConfig -readConfigurationWithDefault :: FilePath -> TraceConfig -> IO TraceConfig -readConfigurationWithDefault fp defaultConf = do - fileConf <- either throwIO pure . parseRepresentation =<< BS.readFile fp - pure $ mergeWithDefault fileConf - where - mergeWithDefault :: TraceConfig -> TraceConfig - mergeWithDefault fileConf = - TraceConfig - (if (not . Map.null) (tcOptions fileConf) - then tcOptions fileConf - else tcOptions defaultConf) - (tcForwarder fileConf <|> tcForwarder defaultConf) - (tcNodeName fileConf <|> tcNodeName defaultConf) - (tcMetricsPrefix fileConf <|> tcMetricsPrefix defaultConf) - (tcResourceFrequency fileConf <|> tcResourceFrequency defaultConf) - (tcLedgerMetricsFrequency fileConf <|> tcLedgerMetricsFrequency defaultConf) - --- | Parse the byteString as external representation and converts to internal --- representation -parseRepresentation :: ByteString -> Either ParseException TraceConfig -parseRepresentation bs = transform (decodeEither' bs) - where - transform :: - Either ParseException ConfigRepresentation - -> Either ParseException TraceConfig - transform (Left e) = Left e - transform (Right rl) = Right $ transform' emptyTraceConfig rl - transform' :: TraceConfig -> ConfigRepresentation -> TraceConfig - transform' TraceConfig {tcOptions=to'} cr = - let to'' = List.foldl' (\ tci (nsp, opts') -> - let ns' = split (=='.') nsp - ns'' = if ns' == [""] then [] else ns' - ns''' = case ns'' of - "Cardano" : tl -> tl - other -> other - in Map.insertWith - (++) - ns''' - (toConfigOptions opts') - tci) - to' (Map.toList (traceOptions cr)) - in TraceConfig - to'' - (traceOptionForwarder cr) - (traceOptionNodeName cr) - (traceOptionMetricsPrefix cr) - (traceOptionResourceFrequency cr) - (traceOptionLedgerMetricsFrequency cr) - - - -- | Convert from external to internal representation - toConfigOptions :: ConfigOptionRep -> [ConfigOption] - toConfigOptions ConfigOptionRep {..} = - catMaybes - [ ConfSeverity <$> severity - , ConfDetail <$> detail - , ConfBackend <$> backends - , ConfLimiter <$> maxFrequency] - - --- | Convert from internal to external representation -configToRepresentation :: TraceConfig -> ConfigRepresentation -configToRepresentation traceConfig = - ConfigRepresentation - (toOptionRepresentation (tcOptions traceConfig)) - (tcForwarder traceConfig) - (tcNodeName traceConfig) - (tcMetricsPrefix traceConfig) - (tcResourceFrequency traceConfig) - (tcLedgerMetricsFrequency traceConfig) - where - toOptionRepresentation :: Map.Map [Text] [ConfigOption] - -> Map.Map Text ConfigOptionRep - toOptionRepresentation internalOptMap = - List.foldl' conversion Map.empty (Map.toList internalOptMap) - - conversion :: Map.Map Text ConfigOptionRep - -> ([Text],[ConfigOption]) - -> Map.Map Text ConfigOptionRep - conversion accuMap (ns, options) = - let nssingle = intercalate "." ns - optionRep = fromOptions options - in Map.insert nssingle optionRep accuMap - - fromOptions :: [ConfigOption] -> ConfigOptionRep - fromOptions opts = - ConfigOptionRep - { severity = listToMaybe [d | ConfSeverity d <- opts] - , detail = listToMaybe [d | ConfDetail d <- opts] - , backends = listToMaybe [d | ConfBackend d <- opts] - , maxFrequency = listToMaybe [d | ConfLimiter d <- opts] - } - - - - - diff --git a/trace-dispatcher/src/Cardano/Logging/Consistency.hs b/trace-dispatcher/src/Cardano/Logging/Consistency.hs deleted file mode 100644 index 440f7fc6658..00000000000 --- a/trace-dispatcher/src/Cardano/Logging/Consistency.hs +++ /dev/null @@ -1,104 +0,0 @@ -module Cardano.Logging.Consistency ( - NSWarnings - , checkTraceConfiguration - , checkTraceConfiguration' -) where - -import Cardano.Logging.ConfigurationParser -import Cardano.Logging.Types - -import Data.Foldable as Foldable (foldl') -import qualified Data.Map.Strict as Map -import Data.Maybe (mapMaybe) -import qualified Data.Text as T - --- | Warnings as a list of text -type NSWarnings = [T.Text] - --- | A data structure for the lookup of namespaces as nested maps -newtype NSLookup = NSLookup (Map.Map T.Text NSLookup) - deriving Show - - --- | Checks if all namespaces in this configuration are legal. --- Legal in this case means that it can be found by a hierarchical --- lookup in all namespaces. --- Warns if namespaces in all namespaces are not unique, --- Warns if namespaces in all namespaces are ending in the --- middle of another namespace. --- The namespaces in allNamespaces are consistent with the namespaces for the --- severityFor, privacyFor, detailsFor, documentFor and metricsDocFor functions. -checkTraceConfiguration :: - FilePath - -> TraceConfig - -> [([T.Text], [T.Text])] - -> IO NSWarnings -checkTraceConfiguration configFileName defaultTraceConfig allNamespaces' = do - trConfig <- readConfigurationWithDefault configFileName defaultTraceConfig - pure $ checkTraceConfiguration' trConfig allNamespaces' - -checkTraceConfiguration' :: - TraceConfig - -> [([T.Text], [T.Text])] - -> NSWarnings -checkTraceConfiguration' trConfig allNamespaces' = - let configNS = Map.keys (tcOptions trConfig) - emptyInner = filter (null . snd) allNamespaces' - allNamespaces'' = map (uncurry (<>)) allNamespaces' - (nsLookup, systemWarnings) = asNSLookup allNamespaces'' - configWarnings = mapMaybe (checkNamespace nsLookup) configNS - allWarnings = map ("System namespace error: "<>) systemWarnings - ++ map (\(ns, _) -> "Empty inner namespace: " - <> T.intercalate "." ns) emptyInner - ++ map ("Config namespace error: " <>) configWarnings - in allWarnings - --- | Check if a single namespace is legal. Legal in this case means that --- it can be found by a hierarchical lookup in all namespaces -checkNamespace :: NSLookup -> [T.Text] -> Maybe T.Text -checkNamespace nsLookup ns = go nsLookup ns - where - go :: NSLookup -> [T.Text] -> Maybe T.Text - go _ [] = Nothing - go (NSLookup l) (nshd : nstl) = case Map.lookup nshd l of - Nothing -> Just ("Illegal namespace " - <> T.intercalate "." ns) - Just l2 -> go l2 nstl - --- | Warns if namespaces in all namespaces are not unique, --- Warns as well if namespaces in all namespaces are ending in the --- middle of another namespace. -asNSLookup :: [[T.Text]] -> (NSLookup, NSWarnings) -asNSLookup = Foldable.foldl' (fillLookup []) (NSLookup Map.empty, []) - where - fillLookup :: [T.Text] -> (NSLookup, NSWarnings) -> [T.Text] -> (NSLookup, NSWarnings) - fillLookup _nsFull (NSLookup nsl, nsw) [] = (NSLookup nsl, nsw) - fillLookup nsFull (NSLookup nsl, nsw) (ns1 : nstail) = - case Map.lookup ns1 nsl of - Nothing -> let nsNew = Map.empty - (NSLookup nsl2, nsw2) = fillLookup - (nsFull <> [ns1]) - (NSLookup nsNew, []) - nstail - res = NSLookup (Map.insert ns1 (NSLookup nsl2) nsl) - newWarnings = nsw <> nsw2 - in (res, newWarnings) - Just (NSLookup nsm) - -> let (NSLookup nsl2, nsw2) = fillLookup - (nsFull <> [ns1]) - (NSLookup nsm, []) - nstail - res = NSLookup (Map.insert ns1 (NSLookup nsl2) nsl) - condWarning = if null nstail - then - if Map.null nsm - then Just ("Duplicate namespace " - <> T.intercalate "." (nsFull <> [ns1])) - else Just ("Inner namespace duplicate " - <> T.intercalate "." (nsFull <> [ns1])) - else Nothing - newWarnings = case condWarning of - Nothing -> nsw <> nsw2 - Just w -> w : (nsw <> nsw2) - in (res, newWarnings) - diff --git a/trace-dispatcher/src/Cardano/Logging/DocuGenerator.hs b/trace-dispatcher/src/Cardano/Logging/DocuGenerator.hs deleted file mode 100644 index c337b74d38c..00000000000 --- a/trace-dispatcher/src/Cardano/Logging/DocuGenerator.hs +++ /dev/null @@ -1,598 +0,0 @@ -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} - -{- HLINT ignore "Use map" -} -{- HLINT ignore "Use map with tuple-section" -} - -module Cardano.Logging.DocuGenerator ( - -- First call documentTracer for every tracer and then - -- docuResultToText on all results - documentTracer - , documentTracer' - , docuResultsToText - , docuResultsToMetricsHelptext - -- Callbacks - , docTracer - , docTracerDatapoint - , docIt - , addFiltered - , addLimiter - , addSilent - , addDocumentedNamespace - , DocuResult - , DocTracer(..) -) where - -import Cardano.Logging.ConfigurationParser () -import Cardano.Logging.DocuGenerator.Tree -import Cardano.Logging.DocuGenerator.Result (DocuResult (..)) -import qualified Cardano.Logging.DocuGenerator.Result as DocuResult -import Cardano.Logging.Types - -import Prelude hiding (lines, unlines) - -import Control.Monad (mfilter) -import Control.Monad.IO.Class (MonadIO, liftIO) -import qualified Control.Tracer as TR -import Data.Aeson (ToJSON) -import qualified Data.Aeson.Encode.Pretty as AE -import Data.IORef (modifyIORef, newIORef, readIORef) -import Data.List (find, groupBy, intersperse, isPrefixOf, nub, sortBy) -import qualified Data.Map.Strict as Map -import Data.Maybe (fromJust, fromMaybe, mapMaybe) -import Data.Text (split) -import Data.Text as T (Text, empty, intercalate, lines, pack, stripPrefix, toLower, - unlines) -import Data.Text.Internal.Builder (toLazyText) -import Data.Text.Lazy (toStrict) -import Data.Text.Lazy.Builder (Builder, fromString, fromText, singleton) - -type InconsistencyWarning = Text - -utf16CircledT :: Text -utf16CircledT = "\x24E3" - -utf16CircledS :: Text -utf16CircledS = "\x24E2" - -utf16CircledM :: Text -utf16CircledM = "\x24DC" - --- | Convenience function for adding a namespace prefix to a documented -addDocumentedNamespace :: [Text] -> Documented a -> Documented a -addDocumentedNamespace out (Documented list) = - Documented $ map - (\ dm@DocMsg {} -> dm {dmNamespace = nsReplacePrefix out (dmNamespace dm)}) - list - -data DocTracer = DocTracer { - dtTracerNames :: [[Text]] - , dtSilent :: [[Text]] - , dtNoMetrics :: [[Text]] - , dtBuilderList :: [([Text], DocuResult)] - , dtWarnings :: [InconsistencyWarning] -} deriving (Show) - -instance Semigroup DocTracer where - dtl <> dtr = DocTracer - (dtTracerNames dtl <> dtTracerNames dtr) - (dtSilent dtl <> dtSilent dtr) - (dtNoMetrics dtl <> dtNoMetrics dtr) - (dtBuilderList dtl <> dtBuilderList dtr) - (dtWarnings dtl <> dtWarnings dtr) - -documentTracer' :: forall a a1. - MetaTrace a - => (Trace IO a1 -> IO (Trace IO a)) - -> Trace IO a1 - -> IO DocTracer -documentTracer' hook tracer = do - tr' <- hook tracer - documentTracer tr' - --- This function calls document tracers and returns a DocTracer result -documentTracer :: forall a. - MetaTrace a - => Trace IO a - -> IO DocTracer -documentTracer tracer = do - DocCollector docRef <- documentTracersRun [tracer] - items <- fmap Map.toList (liftIO (readIORef docRef)) - let sortedItems = sortBy - (\ (_,l) (_,r) -> compare (ldNamespace l) (ldNamespace r)) - items - let messageDocs = map (\(i, ld) -> case ldNamespace ld of - (prn,pon) : _ -> (prn ++ pon, documentItem (i, ld)) - [] -> (["No ns"], documentItem (i, ld))) sortedItems - metricsItems = map snd $ filter (not . Map.null . ldMetricsDoc . snd) sortedItems - metricsDocs = documentMetrics metricsItems - tracerName = case sortedItems of - ((_i, ld) : _) -> case ldNamespace ld of - (prn, _pon) : _ -> prn - [] -> [] - [] -> [] - silent = case sortedItems of - ((_i, ld) : _) -> ldSilent ld - [] -> False - hasNoMetrics = null metricsItems - warnings = concatMap (\(i, ld) -> case ldNamespace ld of - (_,_): _ -> warningItem (i, ld) - [] -> (pack "No ns for " <> ldDoc ld) : - warningItem (i, ld)) sortedItems - pure $ DocTracer - [tracerName] - [tracerName | silent] - [tracerName | hasNoMetrics] - (messageDocs ++ metricsDocs) - warnings - - where - documentItem :: (Int, LogDoc) -> DocuResult - documentItem (_idx, ld@LogDoc {..}) = - case ldBackends of - [DatapointBackend] -> DocuDatapoint $ - mconcat $ intersperse (fromText "\n\n") - [ namespacesBuilder (nub ldNamespace) - , accentuated ldDoc - ] - _ -> DocuTracer $ - mconcat $ intersperse (fromText "\n\n") - [ namespacesBuilder (nub ldNamespace) - , accentuated ldDoc - , propertiesBuilder ld - , configBuilder ld - ] - - warningItem :: (Int, LogDoc) -> [InconsistencyWarning] - warningItem (_idx, ld@LogDoc {..}) = - case ldBackends of - [DatapointBackend] -> namespacesWarning (nub ldNamespace) ld - _ -> namespacesWarning (nub ldNamespace) ld - ++ propertiesWarning ld - - documentMetrics :: [LogDoc] -> [([Text],DocuResult)] - documentMetrics logDocs = - let nameCommentNamespaceList = - concatMap (\ld -> zip (Map.toList (ldMetricsDoc ld)) (repeat (ldNamespace ld))) logDocs - sortedNameCommentNamespaceList = - sortBy (\a b -> compare ((fst . fst) a) ((fst . fst) b)) nameCommentNamespaceList - groupedNameCommentNamespaceList = - groupBy (\a b -> (fst . fst) a == (fst . fst) b) sortedNameCommentNamespaceList - in mapMaybe documentMetrics' groupedNameCommentNamespaceList - - documentMetrics' :: [( (Text, Text) , [([Text],[Text])] )] -> Maybe ([Text], DocuResult) - documentMetrics' ncns@(((name, comment), _) : _tail) = - Just ([name], DocuMetric - $ mconcat $ intersperse (fromText "\n\n") - [ metricToBuilder (name,comment) - , namespacesMetricsBuilder (nub (concatMap snd ncns)) - ]) - documentMetrics' [] = Nothing - - namespacesBuilder :: [([Text], [Text])] -> Builder - namespacesBuilder [ns] = namespaceBuilder ns - namespacesBuilder [] = fromText "__Warning__: namespace missing" - namespacesBuilder nsl = - mconcat (intersperse (singleton '\n') (map namespaceBuilder nsl)) - - namespaceBuilder :: ([Text], [Text]) -> Builder - namespaceBuilder (nsPr, nsPo) = fromText "### " <> - mconcat (intersperse (singleton '.') (map fromText (nsPr ++ nsPo))) - - namespacesMetricsBuilder :: [ ([Text], [Text])] -> Builder - namespacesMetricsBuilder [ns] = fromText "Dispatched by: \n" <> namespaceMetricsBuilder ns - namespacesMetricsBuilder [] = mempty - namespacesMetricsBuilder nsl = fromText "Dispatched by: \n" <> - mconcat (intersperse (singleton '\n') (map namespaceMetricsBuilder nsl)) - - namespaceMetricsBuilder :: ([Text], [Text]) -> Builder - namespaceMetricsBuilder (nsPr, nsPo) = mconcat (intersperse (singleton '.') - (map fromText (nsPr ++ nsPo))) - - namespacesWarning :: [([Text], [Text])] -> LogDoc -> [InconsistencyWarning] - namespacesWarning [] ld = ["Namespace missing " <> ldDoc ld] - namespacesWarning _ _ = [] - - propertiesBuilder :: LogDoc -> Builder - propertiesBuilder LogDoc {..} = - case ldSeverityCoded of - Just s -> fromText "Severity: " <> asCode (fromString (show s)) <> "\n" - Nothing -> fromText "Severity missing: " <> "\n" - <> - case ldPrivacyCoded of - Just p -> fromText "Privacy: " <> asCode (fromString (show p)) <> "\n" - Nothing -> fromText "Privacy missing: " <> "\n" - <> - case ldDetailsCoded of - Just d -> fromText "Details: " <> asCode (fromString (show d)) <> "\n" - Nothing -> fromText "Details missing: " <> "\n" - - propertiesWarning :: LogDoc ->[InconsistencyWarning] - propertiesWarning LogDoc {..} = - case ldSeverityCoded of - Just _s -> [] - Nothing -> map (\ns -> pack "Severity missing: " <> nsRawToText ns) ldNamespace - <> - case ldPrivacyCoded of - Just _p -> [] - Nothing -> map (\ns -> pack "Privacy missing: " <> nsRawToText ns) ldNamespace - <> - case ldDetailsCoded of - Just _d -> [] - Nothing -> map (\ns -> pack "Details missing: " <> nsRawToText ns) ldNamespace - - configBuilder :: LogDoc -> Builder - configBuilder LogDoc {..} = - fromText "From current configuration:\n" - <> case nub ldDetails of - [] -> mempty - [d] -> if Just d /= ldDetailsCoded - then fromText "Details: " - <> asCode (fromString (show d)) - else mempty - l -> fromText "Details: " - <> mconcat (intersperse (fromText ",\n ") - (map (asCode . fromString . show) l)) - <> fromText "\n" - <> backendsBuilder (nub ldBackends) - <> fromText "\n" - <> filteredBuilder (nub ldFiltered) ldSeverityCoded - <> limiterBuilder (nub ldLimiter) - - backendsBuilder :: [BackendConfig] -> Builder - backendsBuilder [] = fromText "No backends found" - backendsBuilder l = fromText "Backends:\n " - <> mconcat (intersperse (fromText ",\n ") - (map backendFormatToText l)) - - backendFormatToText :: BackendConfig -> Builder - backendFormatToText be = asCode (fromString (show be)) - - filteredBuilder :: [SeverityF] -> Maybe SeverityS -> Builder - filteredBuilder [] _ = mempty - filteredBuilder _ Nothing = mempty - filteredBuilder l (Just r) = - fromText "Filtered " - <> case l of - [SeverityF (Just lh)] -> - if fromEnum r >= fromEnum lh - then (asCode . fromString) "Visible" - else (asCode . fromString) "Invisible" - [SeverityF Nothing] -> "Invisible" - _ -> mempty - <> fromText " by config value: " - <> mconcat (intersperse (fromText ", ") - (map (asCode . fromString . show) l)) - - limiterBuilder :: - [(Text, Double)] - -> Builder - limiterBuilder [] = mempty - limiterBuilder l = - mconcat (intersperse (fromText ", ") - (map (\ (n, d) -> fromText "\nLimiter " - <> (asCode . fromText) n - <> fromText " with frequency " - <> (asCode . fromString. show) d) - l)) - - metricToBuilder :: (Text, Text) -> Builder - metricToBuilder (name, text) = - fromText "### " - <> fromText name - <> fromText "\n" - <> accentuated text - - - --- | Calls the tracers in a documentation control mode, --- and returns a DocCollector, from which the documentation gets generated -documentTracersRun :: forall a. MetaTrace a => [Trace IO a] -> IO DocCollector -documentTracersRun tracers = do - let nss = allNamespaces :: [Namespace a] - nsIdx = zip nss [0..] - coll <- fmap DocCollector (liftIO $ newIORef (Map.empty :: Map.Map Int LogDoc)) - mapM_ (docTrace nsIdx coll) tracers - pure coll - where - docTrace nsIdx dc@(DocCollector docRef) (Trace tr) = - mapM_ - (\ (ns, idx) -> do - let condDoc = documentFor ns - doc = fromMaybe mempty condDoc - - modifyIORef docRef - (Map.insert - idx - ((emptyLogDoc - doc - (metricsDocFor ns)) - { ldSeverityCoded = severityFor ns Nothing - , ldPrivacyCoded = privacyFor ns Nothing - , ldDetailsCoded = detailsFor ns Nothing - })) - TR.traceWith tr (emptyLoggingContext {lcNSInner = nsInner ns}, - Left (TCDocument idx dc))) - nsIdx - --------------------- Callbacks --------------------------- - -docTracer :: MonadIO m => - BackendConfig - -> Trace m FormattedMessage -docTracer backendConfig = Trace $ TR.arrow $ TR.emit output - where - output p@(_, Left TCDocument {}) = - docIt backendConfig p - output (_, _) = pure () - -docTracerDatapoint :: MonadIO m => - BackendConfig - -> Trace m a -docTracerDatapoint backendConfig = Trace $ TR.arrow $ TR.emit output - where - output p@(_, Left TCDocument {}) = - docItDatapoint backendConfig p - output (_, _) = pure () - - --- | Callback for doc collection -addFiltered :: MonadIO m => TraceControl -> Maybe SeverityF -> m () -addFiltered (TCDocument idx (DocCollector docRef)) (Just sev) = do - liftIO $ modifyIORef docRef (\ docMap -> - Map.insert - idx - ((\e -> e { ldFiltered = seq sev (sev : ldFiltered e)}) - (case Map.lookup idx docMap of - Just e -> e - Nothing -> error "DocuGenerator>>missing log doc")) - docMap) -addFiltered _ _ = pure () - --- | Callback for doc collection -addLimiter :: MonadIO m => TraceControl -> (Text, Double) -> m () -addLimiter (TCDocument idx (DocCollector docRef)) (ln, lf) = do - liftIO $ modifyIORef docRef (\ docMap -> - Map.insert - idx - ((\e -> e { ldLimiter = seq ln (seq lf ((ln, lf) : ldLimiter e))}) - (case Map.lookup idx docMap of - Just e -> e - Nothing -> error "DocuGenerator>>missing log doc")) - docMap) -addLimiter _ _ = pure () - -addSilent :: MonadIO m => TraceControl -> Maybe Bool -> m () -addSilent (TCDocument idx (DocCollector docRef)) (Just silent) = do - liftIO $ modifyIORef docRef (\ docMap -> - Map.insert - idx - ((\e -> e { ldSilent = silent}) - (case Map.lookup idx docMap of - Just e -> e - Nothing -> error "DocuGenerator>>missing log doc")) - docMap) -addSilent _ _ = pure () - --- | Callback for doc collection -docIt :: MonadIO m - => BackendConfig - -> (LoggingContext, Either TraceControl a) - -> m () -docIt EKGBackend (LoggingContext{}, - Left (TCDocument idx (DocCollector docRef))) = do - liftIO $ modifyIORef docRef (\ docMap -> - Map.insert - idx - ((\e -> e { ldBackends = EKGBackend : ldBackends e - }) - (case Map.lookup idx docMap of - Just e -> e - Nothing -> error "DocuGenerator>>missing log doc")) - docMap) -docIt backend (LoggingContext {..}, - Left (TCDocument idx (DocCollector docRef))) = do - liftIO $ modifyIORef docRef (\ docMap -> - Map.insert - idx - ((\e -> e { ldBackends = backend : ldBackends e - , ldNamespace = nub ((lcNSPrefix,lcNSInner) : ldNamespace e) - , ldDetails = case lcDetails of - Nothing -> ldDetails e - Just d -> d : ldDetails e - }) - (case Map.lookup idx docMap of - Just e -> e - Nothing -> error "DocuGenerator>>missing log doc")) - docMap) -docIt _ (_, _) = pure () - --- | Callback for doc collection -docItDatapoint :: MonadIO m => - BackendConfig - -> (LoggingContext, Either TraceControl a) - -> m () -docItDatapoint _backend (LoggingContext {..}, - Left (TCDocument idx (DocCollector docRef))) = do - liftIO $ modifyIORef docRef (\ docMap -> - Map.insert - idx - ((\e -> e { ldNamespace = nub ((lcNSPrefix, lcNSInner) : ldNamespace e) - , ldBackends = [DatapointBackend] - }) - (case Map.lookup idx docMap of - Just e -> e - Nothing -> error "DocuGenerator>>missing log doc")) - docMap) -docItDatapoint _backend (LoggingContext {}, _) = pure () - - --- Finally generate a text from all the builders -docuResultsToText :: DocTracer -> TraceConfig -> Text -docuResultsToText dt@DocTracer {..} configuration = - let traceBuilders = sortBy (\ (l,_) (r,_) -> compare l r) - (filter (DocuResult.isTracer . snd) dtBuilderList) - metricsBuilders = sortBy (\ (l,_) (r,_) -> compare l r) - (filter (DocuResult.isMetric .snd) dtBuilderList) - datapointBuilders = sortBy (\ (l,_) (r,_) -> compare l r) - (filter (DocuResult.isDatapoint . snd) dtBuilderList) - header = fromText "# Cardano Trace Documentation\n\n" - header1 = fromText "## Table Of Contents\n\n" - toc = generateTOC dt - (map fst traceBuilders) - (map fst metricsBuilders) - (map fst datapointBuilders) - - header2 = fromText "\n## Trace Messages\n\n" - contentT = mconcat $ intersperse (fromText "\n\n") - (map (DocuResult.unpackDocu . snd) traceBuilders) - header3 = fromText "\n## Metrics\n\n" - contentM = mconcat $ intersperse (fromText "\n\n") - (map (DocuResult.unpackDocu . snd) metricsBuilders) - header4 = fromText "\n## Datapoints\n\n" - contentD = mconcat $ intersperse (fromText "\n\n") - (map (DocuResult.unpackDocu . snd) datapointBuilders) - config = fromText "\n## Configuration: \n```\n" - <> AE.encodePrettyToTextBuilder configuration - <> fromText "\n```\n" - numbers = fromString $ show (length traceBuilders) <> " log messages, " <> "\n" <> - show (length metricsBuilders) <> " metrics," <> "\n" <> - show (length datapointBuilders) <> " datapoints." <> "\n\n" - - legend = fromText $ utf16CircledT <> "- This is the root of a tracer\n\n" <> - utf16CircledS <> "- This is the root of a tracer that is silent because of the current configuration\n\n" <> - utf16CircledM <> "- This is the root of a tracer, that provides metrics\n\n" in - toStrict $ toLazyText $ - header - <> header1 - <> toc - <> header2 - <> contentT - <> header3 - <> contentM - <> header4 - <> contentD - <> config - <> numbers - <> legend - -generateTOC :: DocTracer -> [[Text]] -> [[Text]] -> [[Text]] -> Builder -generateTOC DocTracer {..} traces metrics datapoints = - generateTOCTraces - <> generateTOCMetrics - <> generateTOCDatapoints - <> generateTOCRest - where - tracesTree = mapMaybe (trim []) (toForest traces) - metricsTree = toForest (fmap splitToNS metrics) - datapointsTree = toForest datapoints - - generateTOCTraces = - fromText "### [Trace Messages](#trace-messages)\n\n" - <> mconcat (map (namespaceToToc traces False []) tracesTree) - <> fromText "\n" - generateTOCMetrics = - fromText "### [Metrics](#metrics)\n\n" - <> mconcat (map (namespaceToToc (fmap splitToNS metrics) True []) metricsTree) - <> fromText "\n" - generateTOCDatapoints = - fromText "### [Datapoints](#datapoints)\n\n" - <> mconcat (map (namespaceToToc datapoints True []) datapointsTree) - <> fromText "\n" - generateTOCRest = - fromText "### [Configuration](#configuration)\n\n" - <> fromText "\n" - - splitToNS :: [Text] -> [Text] - splitToNS [sym] = split (== '.') sym - splitToNS other = other - - isTracerSymbol :: [Text] -> Bool - isTracerSymbol tracer = tracer `elem` dtTracerNames - - -- Modify the given tracer tree so that the result is a tree where entries which - -- are not tracers are removed. In case the whole tree doesn't contain a tracer, return Nothing. - trim :: [Text] {- accumulated namespace in reverse -} -> Tree Text -> Maybe (Tree Text) - trim ns (Node x nested) = - let that = reverse (x : ns) - -- List of all nested tracers that we shall render - nestedTrimmed = mapMaybe (trim (x : ns)) nested in - mfilter (\_ -> not (null nestedTrimmed) || isTracerSymbol that) (Just (Node x nestedTrimmed)) - - namespaceToToc :: - [[Text]] - -> Bool - -> [Text] {- Accumulated namespace in reverse -} - -> Tree Text - -> Builder - namespaceToToc allTracers skipSymbols accns (Node x nested) = text - where - ns = reverse (x : accns) - - inner = mconcat (map (namespaceToToc allTracers skipSymbols (x : accns)) nested) - - indent lvl txt = mconcat (replicate lvl "\t") <> txt - - text :: Builder - text = - indent (length accns) - ( - "1. " - <> "[" <> fromText x <> fromText symbolsText <> "]" - <> "(#" <> link <> ")\n" - ) <> inner - - symbolsText :: Text - symbolsText = if skipSymbols then "" else - let isTracer = elem ns dtTracerNames - isSilent = elem ns dtSilent - isMetric = notElem ns dtNoMetrics - in - (if isTracer then utf16CircledT else "") - <> (if isSilent then utf16CircledS else "") - <> (if isMetric then utf16CircledM else "") - - -- The link to the description of the first tracer in that namespace - link :: Builder - link = mconcat (map (fromText . toLower) firstTracer) - - -- The first tracer in the list of tracers that has that namespace prefix - firstTracer :: [Text] - firstTracer = fromJust $ find (ns `isPrefixOf`) allTracers - - -asCode :: Builder -> Builder -asCode b = singleton '`' <> b <> singleton '`' - -accentuated :: Text -> Builder -accentuated t = if t == "" - then fromText "\n" - else fromText "\n" - <> fromText (unlines $ map addAccent (lines t)) - where - addAccent :: Text -> Text - addAccent t' = if t' == "" - then ">" - else "> " <> t' - --- this reflects the type cardano-tracer expects the metrics help texts to be serialized from: --- simple key-value map -newtype MetricsHelp = MH (Map.Map Text Text) - deriving ToJSON via (Map.Map Text Text) - -docuResultsToMetricsHelptext :: DocTracer -> Text -docuResultsToMetricsHelptext DocTracer{dtBuilderList} = - toStrict $ toLazyText $ - AE.encodePrettyToTextBuilder' conf mh - where - conf = AE.defConfig { AE.confCompare = compare, AE.confTrailingNewline = True } - mh = MH $ Map.fromList - [(intercalate "." ns, fromMaybe T.empty x) - | (ns, DocuMetric helpDescr) <- dtBuilderList - - -- for now, just extract the helptext (if any) from the markdown paragraph: - -- it's the line that starts with "> " - , let xs = T.lines $ toStrict $ toLazyText helpDescr - , let x = mconcat $ map (stripPrefix "> ") xs - ] diff --git a/trace-dispatcher/src/Cardano/Logging/DocuGenerator/Result.hs b/trace-dispatcher/src/Cardano/Logging/DocuGenerator/Result.hs deleted file mode 100644 index f66c22f04ca..00000000000 --- a/trace-dispatcher/src/Cardano/Logging/DocuGenerator/Result.hs +++ /dev/null @@ -1,27 +0,0 @@ -module Cardano.Logging.DocuGenerator.Result (DocuResult(..), unpackDocu, isTracer, isMetric, isDatapoint) where - -import Data.Text.Internal.Builder - -data DocuResult = - DocuTracer Builder - | DocuMetric Builder - | DocuDatapoint Builder - deriving (Show) - -unpackDocu :: DocuResult -> Builder -unpackDocu (DocuTracer b) = b -unpackDocu (DocuMetric b) = b -unpackDocu (DocuDatapoint b) = b - -isTracer :: DocuResult -> Bool -isTracer DocuTracer {} = True -isTracer _ = False - -isMetric :: DocuResult -> Bool -isMetric DocuMetric {} = True -isMetric _ = False - -isDatapoint :: DocuResult -> Bool -isDatapoint DocuDatapoint {} = True -isDatapoint _ = False - diff --git a/trace-dispatcher/src/Cardano/Logging/DocuGenerator/Tree.hs b/trace-dispatcher/src/Cardano/Logging/DocuGenerator/Tree.hs deleted file mode 100644 index fc0f5be6dca..00000000000 --- a/trace-dispatcher/src/Cardano/Logging/DocuGenerator/Tree.hs +++ /dev/null @@ -1,40 +0,0 @@ -module Cardano.Logging.DocuGenerator.Tree (Tree (..), foldTree, printTree, printList, toForest) where - -import Data.Function (on) -import Data.List (groupBy, intersperse) -import Data.Text.Internal (Text) -import Data.Text.Internal.Builder (Builder) -import Data.Tree (Forest, Tree (..), foldTree, unfoldForest) - --- T ::= ∙ x --- | --- ∙ x --- T --- T --- ... --- T --- --- Example: --- --- ∙ BlockFetch --- ∙ Client --- ∙ AcknowledgedFetchRequest --- ∙ AddedFetchRequest --- ∙ ClientMetrics --- ∙ Decision --- ∙ Remote -printTree :: Tree Text -> Text -printTree = - foldTree (\x -> mconcat . intersperse "\n" . ("∙ " <> x :) . map ("\t" <>)) - -printList :: (a -> Builder) -> [a] -> Builder -printList fmt = mconcat . intersperse "\n" . map fmt - --- Convert a list of namespaces to a tree representation -toForest :: [[Text]] -> Forest Text -toForest = unfoldForest build . groupByHead - where - groupByHead = groupBy (on (==) head) - - build :: [[Text]] -> (Text, [[[Text]]]) - build group@(representative : _) = (head representative, (groupByHead . filter (not . null) . map tail) group) diff --git a/trace-dispatcher/src/Cardano/Logging/Formatter.hs b/trace-dispatcher/src/Cardano/Logging/Formatter.hs deleted file mode 100644 index 429543b007b..00000000000 --- a/trace-dispatcher/src/Cardano/Logging/Formatter.hs +++ /dev/null @@ -1,282 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE PartialTypeSignatures #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} - -{-# OPTIONS_GHC -Wno-orphans #-} - -module Cardano.Logging.Formatter ( - metricsFormatter - , preFormatted - , forwardFormatter - , forwardFormatter' - , machineFormatter - , machineFormatter' - , cborFormatter - , cborFormatter' - , humanFormatter - , humanFormatter' -) where - -import Cardano.Logging.Trace (contramapM) -import Cardano.Logging.Types -import Cardano.Logging.Types.TraceMessage - -import Codec.Serialise (serialise) -import Control.Concurrent (myThreadId) -import Control.Monad.IO.Class (MonadIO, liftIO) -import qualified Control.Tracer as T -import Data.Aeson ((.=)) -import qualified Data.Aeson as AE -import qualified Data.Aeson.Encoding as AE -import qualified Data.ByteString.Lazy as BL (toStrict) -import Data.Functor.Contravariant -import Data.Maybe (fromMaybe) -import Data.Text as T (Text, intercalate, null, pack) -import Data.Text.Lazy (toStrict) -import Data.Text.Lazy.Builder as TB -import Data.Text.Lazy.Encoding (decodeUtf8) -import Data.Time (defaultTimeLocale, formatTime, getCurrentTime) -import Network.HostName -import System.Environment (lookupEnv) -import System.IO.Unsafe (unsafePerformIO) - - --- | If the @TRACE_DISPATCHER_LOGGING_HOSTNAME@ environment variable is set, --- it overrides the system hostname in the trace message. This is useful when --- multiple instances of a service or application on the same host. -hostname :: Text -{-# NOINLINE hostname #-} -hostname = unsafePerformIO $ - lookupEnv "TRACE_DISPATCHER_LOGGING_HOSTNAME" >>= maybe hostNameOnly (pure . T.pack) - where - -- disregard FQDNs - hostNameOnly = T.pack . takeWhile (/= '.') <$> getHostName - - --- | Format this trace as metrics -metricsFormatter - :: forall a m . (LogFormatting a, MonadIO m) - => Trace m FormattedMessage - -> Trace m a -metricsFormatter (Trace tr) = Trace $ - T.contramap - (\ case - (lc, Right v) -> - let metrics = asMetrics v - in (lc, Right (FormattedMetrics metrics)) - (lc, Left ctrl) -> - (lc, Left ctrl)) - tr - --- | Transform this trace to a preformatted message, so that double serialization --- is avoided -preFormatted :: - ( LogFormatting a - , MonadIO m) - => Bool - -> Trace m PreFormatted - -> m (Trace m a) -preFormatted withForHuman = - flip contramapM - (\case - (lc, Right msg) -> do - time <- liftIO getCurrentTime - threadId <- liftIO myThreadId - let - pf = PreFormatted - { pfTime = time - , pfNamespace = intercalate "." (lcNSPrefix lc ++ lcNSInner lc) - , pfThreadId = T.pack $ drop 9 $ show threadId -- drop "ThreadId " prefix - , pfForHuman = if withForHuman then (let txt = forHuman msg in if T.null txt then Nothing else Just txt) else Nothing - , pfForMachineObject = forMachine (fromMaybe DNormal (lcDetails lc)) msg - } - pure (lc, Right pf) - - (lc, Left ctrl) -> - pure (lc, Left ctrl) - ) - --- | Format this trace as TraceObject for the trace forwarder -forwardFormatter' - :: forall m . - MonadIO m - => Trace m FormattedMessage - -> Trace m PreFormatted -forwardFormatter' (Trace tr) = Trace $ - contramap - (\ case - (lc, Right v) -> - let - jsonObj = TraceMessage - { tmsgAt = pfTime v - , tmsgNS = pfNamespace v - , tmsgData = pfForMachineObject v - , tmsgSev = fromMaybe Info $ lcSeverity lc - , tmsgThread = pfThreadId v - , tmsgHost = hostname - } - to = TraceObject - { toHuman = pfForHuman v - , toMachine = (toStrict . decodeUtf8 . AE.encode) jsonObj - -- backwards compatible to not break ForwardingV_1 protocol' type: value used to be segmented (["name", "space"]) - , toNamespace = [pfNamespace v] - , toSeverity = fromMaybe Info (lcSeverity lc) - , toDetails = fromMaybe DNormal (lcDetails lc) - , toTimestamp = pfTime v - , toHostname = hostname - , toThreadId = pfThreadId v - } - in (lc, Right (FormattedForwarder to)) - (lc, Left ctrl) -> (lc, Left ctrl)) - tr - --- | Format this trace as TraceObject for machine-readable text output (JSON) -machineFormatter' - :: forall m . - MonadIO m - => Trace m FormattedMessage - -> Trace m PreFormatted -machineFormatter' (Trace tr) = Trace $ - contramap - (\ case - (lc, Right v) -> - let - msg = TraceMessage - { tmsgAt = pfTime v - , tmsgNS = pfNamespace v - , tmsgData = pfForMachineObject v - , tmsgSev = fromMaybe Info $ lcSeverity lc - , tmsgThread = pfThreadId v - , tmsgHost = hostname - } - in (lc, Right (FormattedMachine (toStrict . decodeUtf8 $ AE.encode msg))) - (lc, Left ctrl) -> (lc, Left ctrl)) - tr - --- | Format this trace in binary serialisation (CBOR) -cborFormatter' - :: forall m . - MonadIO m - => Trace m FormattedMessage - -> Trace m PreFormatted -cborFormatter' (Trace tr) = Trace $ - contramap - (\ case - (lc, Right v) -> - let - cborObj = TraceMessage - { tmsgAt = pfTime v - , tmsgNS = pfNamespace v - , tmsgData = pfForMachineObject v - , tmsgSev = fromMaybe Info $ lcSeverity lc - , tmsgThread = pfThreadId v - , tmsgHost = hostname - } - in (lc, Right (FormattedCBOR $ BL.toStrict $ serialise cborObj)) - (lc, Left ctrl) -> (lc, Left ctrl)) - tr - --- | Format this trace in human readable text output -humanFormatter' - :: forall m . - MonadIO m - => Bool - -> Trace m FormattedMessage - -> Trace m PreFormatted -humanFormatter' withColor (Trace tr) = - Trace $ - contramap - (\ case - (lc, Right v) -> - let sev = fromMaybe Info (lcSeverity lc) - ns = fromText hostname - <> singleton ':' - <> fromText (pfNamespace v) - showTime = formatTime defaultTimeLocale "%F %H:%M:%S%4QZ" - prePart = squareBrackets (fromString $ showTime $ pfTime v) - <> squareBrackets ns - <> roundBrackets - (fromString (show sev) - <> singleton ',' - <> fromText (pfThreadId v)) - dataPart = fromMaybe - (toStrict . decodeUtf8 . AE.encodingToLazyByteString $ - AE.pairs ("data" .= pfForMachineObject v) - ) - (pfForHuman v) - forHuman'' = toStrict - $ toLazyText - (colorBySeverity withColor sev prePart - <> singleton ' ' - <> fromText dataPart) - in (lc, Right (FormattedHuman withColor forHuman'')) - (lc, Left ctrl) -> (lc, Left ctrl)) - tr - -squareBrackets :: Builder -> Builder -squareBrackets b = singleton '[' <> b <> singleton ']' - -roundBrackets :: Builder -> Builder -roundBrackets b = singleton '(' <> b <> singleton ')' - --- | Color a text message based on `Severity`. `Error` and more severe errors --- are colored red, `Warning` is colored yellow, and all other messages are --- rendered in the default color. -colorBySeverity :: Bool -> SeverityS -> Builder -> Builder -colorBySeverity withColor severity' msg = - if withColor - then case severity' of - Emergency -> red msg - Alert -> red msg - Critical -> red msg - Error -> red msg - Warning -> yellow msg - Notice -> magenta msg - Info -> blue msg - Debug -> msg - else msg - where - red = colorize "31" - yellow = colorize "33" - magenta = colorize "35" - blue = colorize "34" - colorize c msg' = "\ESC[" <> c <> "m" <> msg' <> "\ESC[0m" - -humanFormatter - :: forall a m . - MonadIO m - => LogFormatting a - => Bool - -> Trace m FormattedMessage - -> m (Trace m a) -humanFormatter withColor = - preFormatted True . humanFormatter' withColor - -machineFormatter - :: forall a m . - (MonadIO m - , LogFormatting a) - => Trace m FormattedMessage - -> m (Trace m a) -machineFormatter = - preFormatted False . machineFormatter' - -cborFormatter - :: forall a m . - (MonadIO m - , LogFormatting a) - => Trace m FormattedMessage - -> m (Trace m a) -cborFormatter = - preFormatted False . cborFormatter' - -forwardFormatter - :: forall a m . - MonadIO m - => LogFormatting a - => Trace m FormattedMessage - -> m (Trace m a) -forwardFormatter = - preFormatted True . forwardFormatter' diff --git a/trace-dispatcher/src/Cardano/Logging/FrequencyLimiter.hs b/trace-dispatcher/src/Cardano/Logging/FrequencyLimiter.hs deleted file mode 100644 index 92ba20dddf1..00000000000 --- a/trace-dispatcher/src/Cardano/Logging/FrequencyLimiter.hs +++ /dev/null @@ -1,184 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Cardano.Logging.FrequencyLimiter ( - limitFrequency - , LimiterSpec (..) -)where - -import Cardano.Logging.Trace -import Cardano.Logging.TraceDispatcherMessage -import Cardano.Logging.Types - -import Control.Monad.IO.Unlift -import qualified Control.Tracer as T -import Data.Text -import Data.Time.Clock.System - --- | Threshold for starting and stopping of the limiter -budgetLimit :: Double -budgetLimit = 30.0 - --- | After how many seconds a reminder message is send -reminderPeriod :: Double -reminderPeriod = 10.0 - -data MaybeTuple' a b = Nothing' | Just' !a !b - deriving Show - -data LimiterSpec = LimiterSpec { - lsNs :: [Text] - , lsName :: Text - , lsFrequency :: Double -} - -data FrequencyRec a = FrequencyRec { - frMessage :: Maybe a -- ^ The message to pass - , frLastTime :: Double -- ^ The time since the last message did arrive in seconds - , frLastRem :: Double -- ^ The time since the last limiting remainder was send - , frBudget :: Double -- ^ A budget which is used to decide when to start limiting - -- and stop limiting. When messages arrive in shorter frequency then - -- by the given thresholdFrequency budget is earned, and if they - -- arrive in a longer period budget is spend. - , frActive :: !(MaybeTuple' Int Double) - -- ^ Just is active and carries the number - -- of suppressed messages and the time of last send message -} deriving (Show) - --- | Limits the frequency of messages to nMsg which is given per minute. --- --- If the limiter detects more messages, it traces randomly selected --- messages with the given frequency on the 'vtracer' until the --- frequency falls under the threshold long enough.(see below) --- --- Before this the 'ltracer' gets a 'StartLimiting' message. --- In-between you receive 'ContinueLimiting' messages on the 'ltracer' --- every 'reminderPeriod' seconds, with the number of suppressed messages. --- Finally it sends a 'StopLimiting' message on the 'ltracer' and traces all --- messages on the 'vtracer' again. --- --- A budget is used to decide when to start limiting and stop limiting, --- so that the limiter does not get activated if few messages are send in --- high frequency, and doesn't get deactivated if their are only few messages --- which come with low frequency. When messages arrive in shorter frequency then --- by the given 'thresholdFrequency' budget is earned, and if they --- arrive in a longer period budget is spend. If budget is gets higher --- then 'budgetLimit', the limiter starts, and if it falls below minus 'budgetLimit' --- the limiter stops. - --- The budget is calculated by 'thresholdPeriod' / 'elapsedTime', which says how --- many times too quick the message arrives. A value less then 1.0 means the message is --- arriving slower then threshold. This value gets then normalized, so that --- (0.0-10.0) means message arrive quicker then threshold and (0.0..-10.0) --- means that messages arrive slower then threshold. - - -limitFrequency - :: forall a m . MonadUnliftIO m - => Double -- messages per second - -> Text -- name of this limiter - -> Trace m TraceDispatcherMessage -- the limiters messages - -> Trace m a -- the limited trace - -> m (Trace m a) -- the original trace -limitFrequency thresholdFrequency limiterName ltracer vtracer = do - timeNow <- systemTimeToSeconds <$> liftIO getSystemTime - foldTraceM - (checkLimiting (1.0 / thresholdFrequency)) - (FrequencyRec Nothing timeNow 0.0 0.0 Nothing') - (Trace $ T.contramap unfoldTrace (unpackTrace (filterTraceMaybe vtracer))) - where - checkLimiting :: - Double - -> FrequencyRec a - -> LoggingContext - -> a - -> m (FrequencyRec a) - checkLimiting thresholdPeriod fs@FrequencyRec{..} lc message = do - timeNow <- liftIO $ systemTimeToSeconds <$> getSystemTime - let elapsedTime = timeNow - frLastTime - -- How many times too quick does the message arrive (thresholdPeriod / elapsedTime) - -- A value less then 1.0 means the message is - -- arriving slower then threshold - let rawSpendReward = if elapsedTime == 0.0 - then 10.0 - else thresholdPeriod / elapsedTime - let spendReward = if rawSpendReward < 1.0 && rawSpendReward > 0.0 - then 1.0 - (1.0 / rawSpendReward) - else rawSpendReward - 1.0 - -- Normalize so that (0.0-10.0) means message - -- arrive quicker then threshold - -- and (0.0..-10.0) means that messages arrive - -- slower then threshold - let normaSpendReward = min 10.0 (max (-10.0) spendReward) - let newBudget = min budgetLimit (max (-budgetLimit) - (normaSpendReward + frBudget)) - case frActive of - Nothing' -> -- limiter not active - if normaSpendReward + frBudget >= budgetLimit - then do -- start limiting - traceWith - (appendPrefixNames ["Reflection"] - (setSeverity Info (withLoggingContext lc ltracer))) - (StartLimiting limiterName) - pure fs { frMessage = Just message - , frLastTime = timeNow - , frLastRem = timeNow - , frBudget = newBudget - , frActive = Just' 0 timeNow - } - else -- continue without limiting - pure fs { frMessage = Just message - , frLastTime = timeNow - , frLastRem = 0.0 - , frBudget = newBudget - } - Just' nSuppressed lastTimeSend -> -- is active - if normaSpendReward + frBudget <= (- budgetLimit) - then do -- stop limiting - traceWith - (appendPrefixNames ["Reflection"] - (setSeverity Info (withLoggingContext lc ltracer))) - (StopLimiting limiterName nSuppressed) - pure fs { frMessage = Just message - , frLastTime = timeNow - , frBudget = newBudget - , frActive = Nothing' - } - else - let lastPeriod = timeNow - lastTimeSend - lastReminder = timeNow - frLastRem - in do - newFrLastRem <- if lastReminder > reminderPeriod - then do - traceWith - (appendPrefixNames ["Reflection"] - (setSeverity Info - (withLoggingContext lc ltracer))) - (RememberLimiting limiterName nSuppressed) - pure timeNow - else pure frLastRem - if lastPeriod > thresholdPeriod - then -- send - pure fs { frMessage = Just message - , frLastTime = timeNow - , frLastRem = newFrLastRem - , frBudget = newBudget - , frActive = Just' nSuppressed timeNow - } - else -- suppress - pure fs { frMessage = Nothing - , frLastTime = timeNow - , frLastRem = newFrLastRem - , frBudget = newBudget - , frActive = Just' (nSuppressed + 1) lastTimeSend - } - unfoldTrace :: - (LoggingContext, Either TraceControl (Folding a (FrequencyRec a))) - -> (LoggingContext, Either TraceControl (Maybe a)) - unfoldTrace (lc, Right (Folding FrequencyRec {..})) = (lc, Right frMessage) - unfoldTrace (lc, Left ctrl) = (lc, Left ctrl) - - - systemTimeToSeconds :: SystemTime -> Double - systemTimeToSeconds MkSystemTime {..} = - fromIntegral systemSeconds + fromIntegral systemNanoseconds * 1.0E-9 diff --git a/trace-dispatcher/src/Cardano/Logging/Prometheus/Exposition.hs b/trace-dispatcher/src/Cardano/Logging/Prometheus/Exposition.hs deleted file mode 100644 index e07bef42b92..00000000000 --- a/trace-dispatcher/src/Cardano/Logging/Prometheus/Exposition.hs +++ /dev/null @@ -1,98 +0,0 @@ -module Cardano.Logging.Prometheus.Exposition - ( MetricName - , renderExpositionFromSample - , renderExpositionFromSampleWith - ) where - -import Data.Char -import Data.Foldable (asum) -import qualified Data.HashMap.Strict as HM -import Data.List (find) -import Data.Maybe -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Lazy as TL -import Data.Text.Lazy.Builder (Builder) -import qualified Data.Text.Lazy.Builder as TB -import qualified Data.Text.Lazy.Builder.Int as TB -import System.Metrics (Sample, Value (..)) - - -type MetricName = Text - - -renderExpositionFromSample :: Bool -> Sample -> TL.Text -renderExpositionFromSample = renderExpositionFromSampleWith [] - -renderExpositionFromSampleWith - :: [(MetricName, Builder)] - -> Bool - -> Sample - -> TL.Text -renderExpositionFromSampleWith helpTextDict noSuffixes = - TB.toLazyText . (<> buildEOF) . HM.foldlWithKey' buildMetric mempty - where - buildHelpText :: MetricName -> (Builder -> Builder) - buildHelpText name = maybe - (const mempty) - (buildHelp . snd) - (find ((`T.isInfixOf` name) . fst) helpTextDict) - - -- implements the metricsNoSuffix config option - -- must strip all suffixes as per: trace-dispatcher/src/Cardano/Logging/Tracer/EKG.hs > ekgTracer > setIt - stripSuffix :: MetricName -> MetricName - stripSuffix - | noSuffixes = \name -> fromMaybe name $ asum $ map (`T.stripSuffix` name) ["_int", "_counter", "_real"] - | otherwise = id - - prepareName :: MetricName -> MetricName - prepareName = - T.filter (\c -> isAsciiLower c || isAsciiUpper c || isDigit c || c == '_') - . T.replace " " "_" - . T.replace "-" "_" - . T.replace "." "_" - - -- the help annotation line - buildHelp :: Builder -> Builder -> Builder - buildHelp h n = - TB.fromText "# HELP " <> n <> space <> h <> newline - - buildMetric :: TB.Builder -> MetricName -> Value -> TB.Builder - buildMetric acc mName mValue = - acc <> case mValue of - Counter c -> annotate buildCounter <> buildVal space (TB.decimal c) - Gauge g -> annotate buildGauge <> buildVal space (TB.decimal g) - Label l - | Just ('{', _) <- T.uncons l - -> annotate buildInfo <> buildVal mempty (TB.fromText l) - | otherwise - -> helpAnnotation <> buildVal space (TB.fromText l) - _ -> mempty - where - helpAnnotation = - buildHelpText mName buildName - - -- annotates a metric in the order TYPE, UNIT, HELP - -- TODO: UNIT annotation - annotate annType = - buildTypeAnn annType <> helpAnnotation - - -- the metric name for exposition - buildName = - TB.fromText $ prepareName $ stripSuffix mName - - -- the type annotation line - buildTypeAnn t = - TB.fromText "# TYPE " <> buildName <> t <> newline - - -- the actual metric line, optional spacing after name, because of labels: 'metric_name{label_value="foo"} 1' - buildVal spacing v = - buildName <> spacing <> v <> newline - -buildGauge, buildCounter, buildInfo, buildEOF, newline, space :: Builder -buildGauge = TB.fromText " gauge" -buildCounter = TB.fromText " counter" -buildInfo = TB.fromText " info" -buildEOF = TB.fromText "# EOF\n" -newline = TB.singleton '\n' -space = TB.singleton ' ' diff --git a/trace-dispatcher/src/Cardano/Logging/Prometheus/NetworkRun.hs b/trace-dispatcher/src/Cardano/Logging/Prometheus/NetworkRun.hs deleted file mode 100644 index 0bcc40d4ac7..00000000000 --- a/trace-dispatcher/src/Cardano/Logging/Prometheus/NetworkRun.hs +++ /dev/null @@ -1,179 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ViewPatterns #-} - -{-# OPTIONS_GHC -fno-warn-unused-imports #-} - - --- | Run a TCP server, with hardening against connection flooding -module Cardano.Logging.Prometheus.NetworkRun - ( NetworkRunParams (..) - , TimeoutServer - , defaultRunParams - , mkTCPServerRunner - ) where - -import Cardano.Logging.Utils (threadLabelMe) - -import Control.Concurrent (forkFinally, forkIO, threadDelay) -import Control.Concurrent.MVar -import Control.Concurrent.STM (atomically) -import Control.Concurrent.STM.TBQueue -import qualified Control.Exception as E -import Control.Monad (forever, void, when) -import qualified Data.Foldable as F (sum) -import Data.Hashable (hash) -import qualified Data.IntMap.Strict as IM -import qualified Data.List.NonEmpty as NE -import Data.Maybe (fromMaybe) -import Network.Socket -import qualified System.TimeManager as T - - --- | Parameters specifying how the TCP server should be run -data NetworkRunParams = NetworkRunParams - { runSocketTimeout :: !Int -- ^ Release socket after inactivity (seconds) - , runSocketGraceful :: !Int -- ^ Graceful closing of socket (milliseconds), 0 to disable - , runRecvMaxSize :: !Int -- ^ Close socket if more than (runRecvMaxSize - 1) bytes received; choose a small power of 2 - , runRateLimit :: !Double -- ^ Limit requests per second (may be < 0.0), 0.0 to disable - , runConnLimitGlobal :: !Int -- ^ Limit total number of incoming connections, 0 to disable - , runConnLimitPerHost :: !Int -- ^ Limit number of incoming connections from the same host, 0 to disable - , runServerName :: !String -- ^ The server name - exclusively used for labeling GHC threads - } - -defaultRunParams :: String -> NetworkRunParams -defaultRunParams name = NetworkRunParams - { runSocketTimeout = 22 - , runSocketGraceful = 1000 - , runRecvMaxSize = 2048 - , runRateLimit = 3.0 - , runConnLimitGlobal = 12 - , runConnLimitPerHost = 4 - , runServerName = name - } - - --- A server having the run params in scope, as well as an IO action to reset the timeout -type TimeoutServer a - = NetworkRunParams - -> IO () - -> Socket - -> IO a - --- | Returns an IO action that will run a TCP server conforming to the run parameters. --- Will bind to localhost / loopback device only if no host name is specified. --- Will throw an exception when TCP server startup fails - the caller is responsible for appropriately reacting to that. -mkTCPServerRunner - :: NetworkRunParams - -> Maybe HostName - -> PortNumber - -> TimeoutServer () - -> IO (IO ()) -mkTCPServerRunner runParams (fromMaybe "127.0.0.1" -> host) portNo server = do - !sock <- openTCPServerSocket =<< resolve host portNo - let - runner = do - threadLabelMe $ runServerName runParams ++ " server" - runTCPServerWithSocket runParams sock server `E.finally` close sock - pure runner - -runTCPServerWithSocket - :: NetworkRunParams - -> Socket - -> TimeoutServer () - -> IO () -runTCPServerWithSocket runParams@NetworkRunParams{..} sock server = do - rateLimiter <- mkRateLimiter runServerName runRateLimit - ConnLimiter{..} <- mkConnLimiter runConnLimitGlobal runConnLimitPerHost - T.withManager (runSocketTimeout * 1000000) $ \mgr -> forever $ do - waitForLimiter rateLimiter - E.bracketOnError (accept sock) (close . fst) $ \(conn, peer) -> do - noLimitHit <- canServeThisPeer peer - if noLimitHit - then void $ forkFinally (runServer mgr conn) (const $ gclose conn >> releasePeer peer) - else close conn - where - gclose = if runSocketGraceful > 0 then flip gracefulClose runSocketGraceful else close - runServer mgr conn = do - threadLabelMe $ runServerName ++ " timeout server" - T.withHandleKillThread mgr (return ()) $ \timeoutHandle -> - server runParams (T.tickle timeoutHandle) conn - -resolve :: HostName -> PortNumber -> IO AddrInfo -resolve host portNo = - head <$> getAddrInfo (Just hints) (Just host) (Just $ show portNo) - where - hints = defaultHints { addrSocketType = Stream, addrFlags = [AI_PASSIVE] } - -openTCPServerSocket :: AddrInfo -> IO Socket -openTCPServerSocket addr = do - sock <- openServerSocket - listen sock 1024 - return sock - where - openServerSocket = E.bracketOnError (openSocket addr) close $ \sock -> do - setSocketOption sock ReuseAddr 1 -#if !defined(openbsd_HOST_OS) - when (addrFamily addr == AF_INET6) $ setSocketOption sock IPv6Only 1 -#endif - withFdSocket sock setCloseOnExecIfNeeded - bind sock $ addrAddress addr - return sock - -newtype RateLimiter = RateLimiter {waitForLimiter :: IO ()} - -mkRateLimiter :: String -> Double -> IO RateLimiter -mkRateLimiter _ 0.0 = pure $ RateLimiter (pure ()) -mkRateLimiter serverName reqPerSecond = do - lock <- newTBQueueIO queueSize - void . forkIO $ do - threadLabelMe $ serverName ++ " rate limiter" - forever $ do - atomically $ writeTBQueue lock () - threadDelay delay - - pure $ RateLimiter (void $ atomically $ readTBQueue lock) - where - delay = round $ 1000000 / reqPerSecond - queueSize = ceiling reqPerSecond - -data ConnLimiter = ConnLimiter - { canServeThisPeer :: SockAddr -> IO Bool -- ^ Can I serve this peer without hitting a limit? - , releasePeer :: SockAddr -> IO () -- ^ Release peer from the limiter after connection has been closed. - } - -mkConnLimiter :: Int -> Int -> IO ConnLimiter -mkConnLimiter 0 0 = pure $ ConnLimiter (const $ pure True) (const $ pure ()) -mkConnLimiter global perHost = do - lock <- newMVar IM.empty - let - canServeThisPeer (getPeerId -> peerId) = - modifyMVar lock $ \intMap -> - let - intMap' = IM.alter upsert peerId intMap - count' = F.sum intMap' - canServe = didntHitGlobalLimit count' && count' > F.sum intMap - in pure (if canServe then intMap' else intMap, canServe) - releasePeer (getPeerId -> peerId) = - modifyMVar_ lock (pure . IM.alter removeOrDecrease peerId) - - pure ConnLimiter{..} - where - wontHitHostLimit = if perHost == 0 then const True else (< perHost) - didntHitGlobalLimit = if global == 0 then const True else (<= global) - - upsert, removeOrDecrease :: Maybe Int -> Maybe Int - upsert = \case - Just n -> if wontHitHostLimit n then Just (n + 1) else Just n - Nothing -> Just 1 - - removeOrDecrease = \case - Just n | n > 1 -> Just (n - 1) - _ -> Nothing - - getPeerId :: SockAddr -> Int - getPeerId = \case - SockAddrInet _ h -> hash h - SockAddrInet6 _ _ h _ -> hash h - SockAddrUnix s -> hash s diff --git a/trace-dispatcher/src/Cardano/Logging/Prometheus/TCPServer.hs b/trace-dispatcher/src/Cardano/Logging/Prometheus/TCPServer.hs deleted file mode 100644 index 5f218221823..00000000000 --- a/trace-dispatcher/src/Cardano/Logging/Prometheus/TCPServer.hs +++ /dev/null @@ -1,182 +0,0 @@ -{-# LANGUAGE PackageImports #-} - -{-# OPTIONS_GHC -Wno-partial-fields #-} - --- | Run a simple Prometheus TCP server, responding *only* to the '/metrics' URL with current Node metrics -module Cardano.Logging.Prometheus.TCPServer - ( runPrometheusSimple - , runPrometheusSimpleSilent - - , TracePrometheusSimple (..) - ) where - -import Cardano.Logging.Prometheus.Exposition (renderExpositionFromSample) -import Cardano.Logging.Prometheus.NetworkRun -import Cardano.Logging.Types -import Cardano.Logging.Utils (runInLoop, showT) - -import Control.Concurrent.Async (Async, async) -import qualified Control.Exception as E -import Control.Monad (join, when) -import "contra-tracer" Control.Tracer -import Data.Aeson.Types as AE (Value (String), (.=)) -import Data.ByteString (ByteString) -import Data.ByteString.Builder -import qualified Data.ByteString.Char8 as BC -import Data.Int (Int64) -import Data.List (find, intersperse) -import Data.Text as TS (pack) -import Data.Text.Lazy (Text) -import qualified Data.Text.Lazy as T -import qualified Data.Text.Lazy.Encoding as T (encodeUtf8Builder) -import Data.Word (Word16) -import Network.HTTP.Date (epochTimeToHTTPDate, formatHTTPDate) -import Network.Socket (HostName, PortNumber) -import qualified Network.Socket.ByteString as Strict (recv) -import qualified Network.Socket.ByteString.Lazy as Lazy (sendAll) -import System.Metrics as EKG (Store, sampleAll) -import System.Posix.Types (EpochTime) -import System.PosixCompat.Time (epochTime) - - -data TracePrometheusSimple = - TracePrometheusSimpleStart { port :: Word16 } - | TracePrometheusSimpleStop { message :: String } - deriving Show - -instance LogFormatting TracePrometheusSimple where - forMachine _ = \case - TracePrometheusSimpleStart portNo -> mconcat - [ "kind" .= AE.String "PrometheusSimpleStart" - , "port" .= portNo - ] - TracePrometheusSimpleStop message -> mconcat - [ "kind" .= AE.String "TracePrometheusSimpleStop" - , "message" .= message - ] - - forHuman = \case - TracePrometheusSimpleStart portNo -> "PrometheusSimple backend starting on port " <> showT portNo - TracePrometheusSimpleStop message -> "PrometheusSimple backend stop: " <> TS.pack message - - --- Same as below, but will not trace anything -runPrometheusSimpleSilent :: EKG.Store -> (Bool, Maybe HostName, PortNumber) -> IO (Async ()) -runPrometheusSimpleSilent = runPrometheusSimple nullTracer - --- Will retry / restart Prometheus server when an exception occurs, in increasing intervals -runPrometheusSimple :: Tracer IO TracePrometheusSimple -> EKG.Store -> (Bool, Maybe HostName, PortNumber) -> IO (Async ()) -runPrometheusSimple tr ekgStore (noSuffixes, mHost, portNo) = - async $ runInLoop fromScratchThrowing traceInterruption 1 60 - where - traceInterruption (E.SomeException e) = - traceWith tr $ TracePrometheusSimpleStop (E.displayException e) - - fromScratchThrowing = traceWith tr (TracePrometheusSimpleStart $ fromIntegral portNo) >> join createRunner - - getCurrentExposition = renderExpositionFromSample noSuffixes <$> sampleAll ekgStore - createRunner = mkTCPServerRunner (defaultRunParams "PrometheusSimple") mHost portNo (serveAccepted getCurrentExposition) - --- serves an incoming connection; will release socket upon remote close, inactivity timeout or runRecvMaxSize bytes received -serveAccepted :: IO Text -> TimeoutServer () -serveAccepted getCurrentExposition NetworkRunParams{runRecvMaxSize} resetTimeout sock = go - where - go = do - msg <- Strict.recv sock runRecvMaxSize - let len = BC.length msg - when (0 < len && len < runRecvMaxSize) $ do - response <- buildResponse getCurrentExposition $ pseudoParse msg - Lazy.sendAll sock $ toLazyByteString response - resetTimeout - go - - -data Method = GET | HEAD | UNSUPPORTED deriving Eq - -data Accept = TextLike | OpenMetrics | All | Unsupported deriving Eq - --- "parses" a buffer read via TCP into a minimal viable HTTP request (TM): route, HTTP verb, Accept: header -pseudoParse :: ByteString -> Maybe (ByteString, Method, Accept) -pseudoParse request = - case BC.lines request of - requestLine : headers - | method : route : _ <- BC.words requestLine - -> Just (route, readMethod method, readAccept headers) - _ -> Nothing - where - readMethod :: ByteString -> Method - readMethod "GET" = GET - readMethod "HEAD" = HEAD - readMethod _ = UNSUPPORTED - - readAccept :: [ByteString] -> Accept - readAccept headers = - case find (\h -> any (`BC.isPrefixOf` h) caseInsensitive) headers of - Nothing -> All - Just accept - | "application/openmetrics-text" `BC.isInfixOf` accept -> OpenMetrics - | "text/" `BC.isInfixOf` accept -> TextLike - | "*/*" `BC.isInfixOf` accept -> All - | otherwise -> Unsupported - where - caseInsensitive = ["Accept:", "accept:", "ACCEPT:"] - --- builds a minimal complete HTTP response based on route, HTTP verb and requested content type -buildResponse :: IO Text -> Maybe (ByteString, Method, Accept) -> IO Builder -buildResponse getCurrentExposition = \case - Nothing -> pure $ responseError False errorBadRequest - Just (route, method, accept) - | route /= "/metrics" -> pure $ responseError withBody errorNotFound - | method == UNSUPPORTED -> pure $ responseError withBody errorBadMethod - | accept == Unsupported -> pure $ responseError withBody errorBadContent - | otherwise -> - let content = if accept == OpenMetrics then hdrContentTypeOpenMetrics else hdrContentTypePrometheus - in responseMessage withBody content <$> getCurrentExposition <*> epochTime - where withBody = method == GET - -hdrContentTypeText, hdrContentTypePrometheus, hdrContentTypeOpenMetrics :: Builder -hdrContentTypeText = "Content-Type: text/plain;charset=utf-8" -hdrContentTypePrometheus = "Content-Type: text/plain;version=0.0.4;charset=utf-8" -hdrContentTypeOpenMetrics = "Content-Type: application/openmetrics-text;version=1.0.0;charset=utf-8" - -hdrContentLength :: Int64 -> Builder -hdrContentLength len = "Content-Length: " <> int64Dec len - -errorBadRequest, errorNotFound, errorBadMethod, errorBadContent :: (ByteString, ByteString) -errorBadRequest = ("400", "Bad Request") -errorNotFound = ("404", "Not Found") -errorBadMethod = ("405", "Method Not Allowed") -errorBadContent = ("415", "Unsupported Media Type") - --- HTTP header line break -nl :: Builder -nl = char8 '\r' <> char8 '\n' - -responseError :: Bool -> (ByteString, ByteString) -> Builder -responseError withBody (errCode, errMsg) = - mconcat $ intersperse nl $ - "HTTP/1.1 " <> byteString errCode : - if withBody - then [ hdrContentLength (fromIntegral $ BC.length msg) - , hdrContentTypeText - , "" - , byteString msg - ] - else [ hdrContentLength 0 - , nl - ] - where - msg = errCode <> " " <> errMsg - -responseMessage :: Bool -> Builder -> Text -> EpochTime -> Builder -responseMessage withBody contentType msg now = - mconcat $ intersperse nl - [ "HTTP/1.1 200 OK" - , hdrContentLength (T.length msg) - , contentType - , "Date: " <> byteString httpDate - , "" - , if withBody then T.encodeUtf8Builder msg else "" - ] - where - httpDate = formatHTTPDate $ epochTimeToHTTPDate now diff --git a/trace-dispatcher/src/Cardano/Logging/Trace.hs b/trace-dispatcher/src/Cardano/Logging/Trace.hs deleted file mode 100644 index 869dda7ca9b..00000000000 --- a/trace-dispatcher/src/Cardano/Logging/Trace.hs +++ /dev/null @@ -1,389 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} - -module Cardano.Logging.Trace ( - traceWith - , withLoggingContext - - , filterTrace - , filterTraceMaybe - , filterTraceBySeverity - , filterTraceByPrivacy - - , setSeverity - , withSeverity - , privately - , setPrivacy - , withPrivacy - , allPublic - , allConfidential - , setDetails - , withDetails - - , contramapM - , contramapMCond - , contramapM' - , foldTraceM - , foldCondTraceM - , routingTrace - - , withNames - , appendPrefixName - , appendPrefixNames - , appendInnerName - , appendInnerNames - , withInnerNames - - , contramap' - , (>!$!<) - ) where - -import Cardano.Logging.Types - -import Control.Monad (forM_, join) -import Control.Monad.IO.Unlift -import qualified Control.Tracer as T -import Data.Functor.Contravariant as Contr (Contravariant, (>$<)) -import Data.Maybe (isJust) -import Data.Text (Text) - -import UnliftIO.MVar - --- | Adds a message object to a trace -traceWith :: Monad m => Trace m a -> a -> m () -traceWith (Trace tr) a = T.traceWith tr (emptyLoggingContext, Right a) - ---- | Don't process further if the result of the selector function ---- is False. -filterTrace :: (Monad m) - => ((LoggingContext, a) -> Bool) - -> Trace m a - -> Trace m a -filterTrace ff (Trace tr) = Trace $ T.squelchUnless - (\case - (_lc, Left _) -> True - (lc, Right a) -> ff (lc, a)) - tr - ---- | Keep the Just values and forget about the Nothings -filterTraceMaybe :: Monad m - => Trace m a - -> Trace m (Maybe a) -filterTraceMaybe (Trace tr) = Trace $ - T.squelchUnless - (\case - (_lc, Left _ctrl) -> True - (_lc, Right (Just _)) -> True - (_lc, Right Nothing) -> False) - (T.contramap - (\case - ( lc, Right (Just a)) -> (lc, Right a) - (_lc, Right Nothing) -> error "filterTraceMaybe: impossible" - ( lc, Left ctrl) -> (lc, Left ctrl)) - tr) - ---- | Only processes messages further a severity equal or greater as the ---- given one -filterTraceBySeverity :: Monad m - => Maybe SeverityF - -> Trace m a - -> Trace m a -filterTraceBySeverity (Just minSeverity) = - filterTrace - (\(lc, _) -> case lcSeverity lc of - Just s -> case minSeverity of - SeverityF (Just fs) -> s >= fs - SeverityF Nothing -> False - Nothing -> True) - -filterTraceBySeverity Nothing = id - --- | Sets a new logging context for this message -withLoggingContext :: Monad m => LoggingContext -> Trace m a -> Trace m a -withLoggingContext lc (Trace tr) = Trace $ - T.contramap - (\ - (_lc, cont) -> (lc, cont)) - tr - --- | Appends a name to the context. --- E.g. appendName "specific" $ appendName "middle" $ appendName "general" tracer --- give the result: `general.middle.specific`. -appendPrefixName :: Monad m => Text -> Trace m a -> Trace m a -appendPrefixName name (Trace tr) = Trace $ - T.contramap - (\ - (lc, cont) -> (lc {lcNSPrefix = name : lcNSPrefix lc}, cont)) - tr - -appendInnerName :: Monad m => Text -> Trace m a -> Trace m a -appendInnerName name (Trace tr) = Trace $ - T.contramap - (\ - (lc, cont) -> (lc {lcNSInner = name : lcNSInner lc}, cont)) - tr - --- | Appends all names to the context. -{-# INLINE appendPrefixNames #-} -appendPrefixNames :: Monad m => [Text] -> Trace m a -> Trace m a -appendPrefixNames names (Trace tr) = Trace $ - T.contramap - (\ - (lc, cont) -> (lc {lcNSPrefix = names ++ lcNSPrefix lc}, cont)) - tr - --- | Appends all names to the context. -appendInnerNames :: Monad m => [Text] -> Trace m a -> Trace m a -appendInnerNames names (Trace tr) = Trace $ - T.contramap - (\ - (lc, cont) -> (lc {lcNSInner = names ++ lcNSInner lc}, cont)) - tr - --- | Sets names for the messages in this trace based on the selector function -{-# INLINE withInnerNames #-} -withInnerNames :: forall m a. (Monad m, MetaTrace a) => Trace m a -> Trace m a -withInnerNames (Trace tr) = Trace $ - T.contramap - (\case - (lc, Right a) -> (lc {lcNSInner = nsInner (namespaceFor a)}, Right a) - (lc, Left c) -> (lc, Left c)) - tr - --- | Sets names for the messages in this trace based on the selector function --- and appends the provided names to the context. -{-# INLINE withNames #-} -withNames :: forall m a. (Monad m, MetaTrace a) => [Text] -> Trace m a -> Trace m a -withNames names (Trace tr) = Trace $ - T.contramap - (\case - (lc, Right a) -> (lc {lcNSPrefix = names, - lcNSInner = nsInner (namespaceFor a)}, Right a) - (lc, Left c) -> (lc {lcNSPrefix = names}, Left c)) - tr - - --- | Sets severity for the messages in this trace -setSeverity :: Monad m => SeverityS -> Trace m a -> Trace m a -setSeverity s (Trace tr) = Trace $ - T.contramap - (\ (lc, cont) -> if isJust (lcSeverity lc) - then (lc, cont) - else (lc {lcSeverity = Just s}, cont)) - tr - --- | Sets severities for the messages in this trace based on the MetaTrace class -{-# INLINE withSeverity #-} -withSeverity :: forall m a. (Monad m, MetaTrace a) => Trace m a -> Trace m a -withSeverity (Trace tr) = Trace $ - T.contramap - (\case - (lc, Right e) -> process lc (Right e) - (lc, Left c@(TCConfig _)) -> process lc (Left c) - (lc, Left d@(TCDocument _ _)) -> process lc (Left d) - (lc, Left e) -> (lc, Left e)) - tr - where - process lc cont@(Right v) = - if isJust (lcSeverity lc) - then (lc,cont) - else (lc {lcSeverity = severityFor (Namespace [] (lcNSInner lc) - :: Namespace a) (Just v)} , cont) - process lc cont@(Left _) = - if isJust (lcSeverity lc) - then (lc,cont) - else (lc {lcSeverity = severityFor (Namespace [] (lcNSInner lc) - :: Namespace a) Nothing}, cont) - ---- | Only processes messages further with a privacy greater then the given one -filterTraceByPrivacy :: (Monad m) => - Maybe Privacy - -> Trace m a - -> Trace m a -filterTraceByPrivacy (Just minPrivacy) = filterTrace $ - \(lc, _cont) -> - case lcPrivacy lc of - Just s -> fromEnum s >= fromEnum minPrivacy - Nothing -> True -filterTraceByPrivacy Nothing = id - -allPublic :: a -> Privacy -allPublic _ = Public - -allConfidential :: a -> Privacy -allConfidential _ = Confidential - - --- | Sets privacy Confidential for the messages in this trace -privately :: Monad m => Trace m a -> Trace m a -privately = setPrivacy Confidential - --- | Sets privacy for the messages in this trace -setPrivacy :: Monad m => Privacy -> Trace m a -> Trace m a -setPrivacy p (Trace tr) = Trace $ - T.contramap - (\ (lc, cont) -> if isJust (lcPrivacy lc) - then (lc, cont) - else (lc {lcPrivacy = Just p}, cont)) - tr - --- | Sets privacy for the messages in this trace based on the MetaTrace class -withPrivacy :: forall m a. (Monad m, MetaTrace a) => Trace m a -> Trace m a -withPrivacy (Trace tr) = Trace $ - T.contramap - (\case - (lc, Right e) -> process lc (Right e) - (lc, Left c@(TCConfig _)) -> process lc (Left c) - (lc, Left d@(TCDocument _ _)) -> process lc (Left d) - (lc, Left e) -> (lc, Left e)) - tr - where - process lc cont@(Right v) = - if isJust (lcPrivacy lc) - then (lc,cont) - else (lc {lcPrivacy = privacyFor (Namespace [] (lcNSInner lc) - :: Namespace a) (Just v)} , cont) - process lc cont@(Left _) = - if isJust (lcPrivacy lc) - then (lc,cont) - else (lc {lcPrivacy = privacyFor (Namespace [] (lcNSInner lc) - :: Namespace a) Nothing}, cont) - --- | Sets detail level for the messages in this trace -setDetails :: Monad m => DetailLevel -> Trace m a -> Trace m a -setDetails p (Trace tr) = Trace $ - T.contramap - (\ (lc, cont) -> if isJust (lcDetails lc) - then (lc, cont) - else (lc {lcDetails = Just p}, cont)) - tr - --- | Sets detail level for the messages in this trace based on the message -withDetails :: forall m a. (Monad m, MetaTrace a) => Trace m a -> Trace m a -withDetails (Trace tr) = Trace $ - T.contramap - (\case - (lc, Right e) -> process lc (Right e) - (lc, Left c@(TCConfig _)) -> process lc (Left c) - (lc, Left d@(TCDocument _ _)) -> process lc (Left d) - (lc, Left e) -> (lc, Left e)) - tr - where - process lc cont@(Right v) = - if isJust (lcDetails lc) - then (lc,cont) - else (lc {lcDetails = detailsFor (Namespace [] (lcNSInner lc) - :: Namespace a) (Just v)} , cont) - process lc cont@(Left _) = - if isJust (lcDetails lc) - then (lc,cont) - else (lc {lcDetails = detailsFor (Namespace [] (lcNSInner lc) - :: Namespace a) Nothing}, cont) - --- | Contramap a monadic function over a trace -{-# INLINE contramapM #-} -contramapM :: Monad m - => Trace m b - -> ((LoggingContext, Either TraceControl a) - -> m (LoggingContext, Either TraceControl b)) - -> m (Trace m a) -contramapM (Trace tr) mFunc = - pure $ Trace $ T.Tracer $ T.emit rFunc - where - rFunc arg = do - res <- mFunc arg - T.traceWith tr res - --- | Contramap a monadic function over a trace --- Can as well filter out messages -{-# INLINE contramapMCond #-} -contramapMCond :: Monad m - => Trace m b - -> ((LoggingContext, Either TraceControl a) - -> m (Maybe (LoggingContext, Either TraceControl b))) - -> m (Trace m a) -contramapMCond (Trace tr) mFunc = - pure $ Trace $ T.Tracer $ T.emit rFunc - where - rFunc arg = do - condMes <- mFunc arg - forM_ condMes (T.traceWith tr) - -{-# INLINE contramapM' #-} -contramapM' :: Monad m - => ((LoggingContext, Either TraceControl a) - -> m ()) - -> Trace m a -contramapM' rFunc = - Trace $ T.Tracer $ T.emit rFunc - --- | Folds the monadic cata function with acc over a. --- Uses an MVar to store the state -foldTraceM :: forall a acc m . (MonadUnliftIO m) - => (acc -> LoggingContext -> a -> m acc) - -> acc - -> Trace m (Folding a acc) - -> m (Trace m a) -foldTraceM cata initial (Trace tr) = do - ref <- liftIO (newMVar initial) - contramapM (Trace tr) - (\case - (lc, Right v) -> do - x' <- modifyMVar ref $ \x -> do - !accu <- cata x lc v - pure $ join (,) accu - pure (lc, Right (Folding x')) - (lc, Left control) -> do - pure (lc, Left control)) - --- | Like foldTraceM, but filter the trace by a predicate. -foldCondTraceM :: forall a acc m . (MonadUnliftIO m) - => (acc -> LoggingContext -> a -> m acc) - -> acc - -> (a -> Bool) - -> Trace m (Folding a acc) - -> m (Trace m a) -foldCondTraceM cata initial flt (Trace tr) = do - ref <- liftIO (newMVar initial) - contramapMCond (Trace tr) (foldF ref) - where - foldF ref = - \case - (lc, Right v) -> do - x' <- modifyMVar ref $ \x -> do - !accu <- cata x lc v - pure $ join (,) accu - if flt v - then pure $ Just (lc, Right (Folding x')) - else pure Nothing - (lc, Left control) -> do - pure $ Just (lc, Left control) - --- | Allows to route to different tracers, based on the message being processed. --- The second argument must mappend all possible tracers of the first --- argument to one tracer. This is required for the configuration! -routingTrace :: forall m a. Monad m - => (a -> m (Trace m a)) - -> Trace m a - -> Trace m a -routingTrace rf rc = contramapM' - (\case - (lc, Right a) -> do - nt <- rf a - T.traceWith (unpackTrace nt) (lc, Right a) - (lc, Left control) -> - T.traceWith (unpackTrace rc) (lc, Left control)) - --- | A contramap' which is strict in its second argument and its result captures --- a common pattern to avoid unintentionally leaking space when composing tracers. --- The infix alias is (>!$!<). -contramap', (>!$!<) :: Contravariant f => (a' -> a) -> (f a -> f a') - -contramap' a !b = - let !result = a Contr.>$< b - in result - -infixl 4 >!$!< - -(>!$!<) = contramap' diff --git a/trace-dispatcher/src/Cardano/Logging/TraceDispatcherMessage.hs b/trace-dispatcher/src/Cardano/Logging/TraceDispatcherMessage.hs deleted file mode 100644 index f09a930bdc6..00000000000 --- a/trace-dispatcher/src/Cardano/Logging/TraceDispatcherMessage.hs +++ /dev/null @@ -1,188 +0,0 @@ -module Cardano.Logging.TraceDispatcherMessage - ( - UnknownNamespaceKind (..) - , TraceDispatcherMessage (..) - ) where - -import Cardano.Logging.ConfigurationParser () -import Cardano.Logging.Types - -import Data.Aeson hiding (Error) -import Data.ByteString.Lazy (toStrict) -import qualified Data.Map as Map -import Data.Text (Text) -import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text - -data UnknownNamespaceKind = - UKFSeverity - | UKFPrivacy - | UKFDetails - -instance Show UnknownNamespaceKind where - show UKFSeverity = "severity" - show UKFPrivacy = "privacy" - show UKFDetails = "details" - -data TraceDispatcherMessage = - StartLimiting Text - -- ^ This message indicates the start of frequency limiting - | StopLimiting Text Int - -- ^ This message indicates the stop of frequency limiting, - -- and gives the number of messages that has been suppressed - | RememberLimiting Text Int - -- ^ This message remembers of ongoing frequency limiting, - -- and gives the number of messages that has been suppressed - | UnknownNamespace [Text] [Text] UnknownNamespaceKind - -- ^ An internal error was detected - | TracerInfo [Text] [Text] [Text] - -- ^ The first array signifies the namespace of silent tracers - -- The second array signifies the namespace tracers without metrics - -- The third array gives the names of all tracers - | MetricsInfo (Map.Map Text Int) - -- ^ Outputs optional statistics about metrics frequency - | TracerConsistencyWarnings [Text] - -- ^ Consistency check found warnings - | TracerInfoConfig TraceConfig - -- ^ Trace the effective configuration as JSON - deriving Show - -instance LogFormatting TraceDispatcherMessage where - forHuman (StartLimiting txt) = "Start of frequency limiting for " <> txt - forHuman (StopLimiting txt num) = "Stop of frequency limiting for " <> txt <> - ". Suppressed " <> textShow num <> " messages." - forHuman (RememberLimiting txt num) = "Frequency limiting still active for " <> txt <> - ". Suppressed so far " <> textShow num <> " messages." - forHuman (UnknownNamespace nsPrefixNS nsInnerNS qk) = "Unknown namespace detected " - <> Text.intercalate (Text.singleton '.') (nsPrefixNS ++ nsInnerNS) - <> ". Used for querying " <> textShow qk <> "." - forHuman (TracerInfo silent noMetrics allTracers) = "The tracing system has silent the following tracer," - <> " as they will never have any output according to the current config: " - <> Text.intercalate (Text.singleton ' ') silent <> ". The following tracers will not emit metrics " - <> Text.intercalate (Text.singleton ' ') noMetrics <> ". Here is a complete list of all tracers: " - <> Text.intercalate (Text.singleton ' ') allTracers <> "." - forHuman (MetricsInfo mmap) = "Number of metrics delivered, " <> textShow mmap - forHuman (TracerConsistencyWarnings errs) = "Consistency check found warnings: " <> textShow errs - forHuman (TracerInfoConfig tc) = "Effective Tracer config is: " <> Text.decodeUtf8 (toStrict (encode tc)) - - - forMachine _dtl StartLimiting {} = mconcat - [ "kind" .= String "StartLimiting" - ] - forMachine _dtl (StopLimiting _txt num) = mconcat - [ "kind" .= String "StopLimiting" - , "numSuppressed" .= Number (fromIntegral num) - ] - forMachine _dtl (RememberLimiting _txt num) = mconcat - [ "kind" .= String "RememberLimiting" - , "numSuppressed" .= Number (fromIntegral num) - ] - forMachine _dtl (UnknownNamespace nsun nsleg query) = mconcat - [ "kind" .= String "UnknownNamespace" - , "unknownNamespace" .= String (Text.intercalate (Text.singleton '.') nsun) - , "legalNamespace" .= String (Text.intercalate (Text.singleton '.') nsleg) - , "querying" .= String (textShow query) - ] - forMachine _dtl (TracerInfo silent noMetrics allTracers) = mconcat - [ "kind" .= String "TracerMeta" - , "silentTracers" .= String (Text.intercalate (Text.singleton ' ') silent) - , "noMetrics" .= String (Text.intercalate (Text.singleton ' ') noMetrics) - , "allTracers" .= String (Text.intercalate (Text.singleton ' ') allTracers) - ] - forMachine _dtl (MetricsInfo mmap) = mconcat - [ "kind" .= String "MetricsInfo" - , "metrics count" .= String (textShow mmap) - ] - forMachine _dtl (TracerConsistencyWarnings errs) = mconcat - [ "kind" .= String "TracerConsistencyWarnings" - , "errors" .= String (textShow errs) - ] - forMachine _dtl (TracerInfoConfig tc) = mconcat - [ "conf" .= toJSON tc - ] - - - asMetrics StartLimiting {} = [] - asMetrics (StopLimiting txt num) = [IntM - ("SuppressedMessages " <> txt) - (fromIntegral num)] - asMetrics RememberLimiting {} = [] - asMetrics UnknownNamespace {} = [] - asMetrics TracerInfo {} = [] - asMetrics MetricsInfo {} = [] - asMetrics TracerConsistencyWarnings {} = [] - asMetrics TracerInfoConfig {} = [] - -internalRestriction :: Text -internalRestriction = "\nThis internal message can't be filtered by the current configuration" - -instance MetaTrace TraceDispatcherMessage where - namespaceFor StartLimiting {} = Namespace [] ["StartLimiting"] - namespaceFor StopLimiting {} = Namespace [] ["StopLimiting"] - namespaceFor RememberLimiting {} = Namespace [] ["RememberLimiting"] - namespaceFor UnknownNamespace {} = Namespace [] ["UnknownNamespace"] - namespaceFor TracerInfo {} = Namespace [] ["TracerInfo"] - namespaceFor MetricsInfo {} = Namespace [] ["MetricsInfo"] - namespaceFor TracerConsistencyWarnings {} = Namespace [] ["TracerConsistencyWarnings"] - namespaceFor TracerInfoConfig {} = Namespace [] ["TracerConfigInfo"] - - - - severityFor (Namespace _ ["StartLimiting"]) _ = Just Notice - severityFor (Namespace _ ["StopLimiting"]) _ = Just Notice - severityFor (Namespace _ ["RememberLimiting"]) _ = Just Notice - severityFor (Namespace _ ["UnknownNamespace"]) _ = Just Error - severityFor (Namespace _ ["TracerInfo"]) _ = Just Notice - severityFor (Namespace _ ["MetricsInfo"]) _ = Just Debug - severityFor (Namespace _ ["TracerConsistencyWarnings"]) _ = Just Warning - severityFor (Namespace _ ["TracerConfigInfo"]) _ = Just Notice - severityFor _ _ = Nothing - - documentFor (Namespace _ ["StartLimiting"]) = Just $ - "This message indicates the start of frequency limiting" <> internalRestriction - documentFor (Namespace _ ["StopLimiting"]) = Just $ mconcat - [ "This message indicates the stop of frequency limiting," - , " and gives the number of messages that has been suppressed" - ] <> internalRestriction - documentFor (Namespace _ ["RememberLimiting"]) = Just $ mconcat - [ "^ This message remembers of ongoing frequency limiting," - , " and gives the number of messages that has been suppressed" - ] <> internalRestriction - documentFor (Namespace _ ["UnknownNamespace"]) = Just $ mconcat - [ "A value was queried for a namespaces from a tracer," - , "which is unknown. This indicates a bug in the tracer implementation." - ] <> internalRestriction - documentFor (Namespace _ ["TracerInfo"]) = Just $ mconcat - [ "Writes out tracers with metrics and silent tracers." - ] <> internalRestriction - documentFor (Namespace _ ["MetricsInfo"]) = Just $ mconcat - [ "Writes out numbers for metrics delivered." - ] <> internalRestriction - documentFor (Namespace _ ["TracerConsistencyWarnings"]) = Just $ mconcat - [ "Tracer consistency check found errors." - ] <> internalRestriction - documentFor (Namespace _ ["TracerConfigInfo"]) = Just $ mconcat - [ "Trace the tracer configuration which is effectively used." - ] <> internalRestriction - documentFor _ = Nothing - - metricsDocFor (Namespace _ ["StartLimiting"]) = - [("SuppressedMessages...", "Number of suppressed messages of a certain kind")] - metricsDocFor _ = [] - - - allNamespaces = [ - Namespace [] ["StartLimiting"] - , Namespace [] ["StopLimiting"] - , Namespace [] ["RememberLimiting"] - , Namespace [] ["UnknownNamespace"] - , Namespace [] ["TracerInfo"] - , Namespace [] ["MetricsInfo"] - , Namespace [] ["TracerConsistencyWarnings"] - , Namespace [] ["TracerConfigInfo"] - ] - --- `text-2.1.2` provides `Text.show` which can replace this when --- the lower bound for `text` is high enough. -textShow :: Show a => a -> Text -textShow = Text.pack . show diff --git a/trace-dispatcher/src/Cardano/Logging/Tracer/Composed.hs b/trace-dispatcher/src/Cardano/Logging/Tracer/Composed.hs deleted file mode 100644 index a800ffd0f59..00000000000 --- a/trace-dispatcher/src/Cardano/Logging/Tracer/Composed.hs +++ /dev/null @@ -1,248 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ScopedTypeVariables #-} - -{- HLINT ignore "Monad law, left identity" -} - -module Cardano.Logging.Tracer.Composed ( - mkCardanoTracer - , mkCardanoTracer' - , mkMetricsTracer - , traceTracerInfo - , traceConfigWarnings - , traceEffectiveConfiguration - ) where - -import Cardano.Logging.Configuration -import Cardano.Logging.Formatter -import Cardano.Logging.Trace -import Cardano.Logging.TraceDispatcherMessage -import Cardano.Logging.Types - -import Control.Concurrent.MVar -import Control.Monad (when) -import Control.Monad.IO.Class (MonadIO, liftIO) -import qualified Control.Tracer as T -import Data.IORef -import qualified Data.List as L -import qualified Data.Map as Map -import Data.Maybe (fromMaybe, isNothing) -import qualified Data.Set as Set -import Data.Text hiding (map) - - --- | Construct a tracer according to the requirements for cardano node. --- The tracer gets a 'name', which is appended to its namespace. --- The tracer has to be an instance of LogFormatting for the display of --- messages and an instance of MetaTrace for meta information such as --- severity, privacy, details and backends'. --- The tracer gets the backends': 'trStdout', 'trForward' and 'mbTrEkg' --- as arguments. --- The returned tracer needs to be configured with a configuration --- before it is used. -mkCardanoTracer :: forall evt. - ( LogFormatting evt - , MetaTrace evt) - => Trace IO FormattedMessage - -> Trace IO FormattedMessage - -> Maybe (Trace IO FormattedMessage) - -> [Text] - -> IO (Trace IO evt) -mkCardanoTracer trStdout trForward mbTrEkg tracerPrefix = - mkCardanoTracer' trStdout trForward mbTrEkg tracerPrefix noHook - where - noHook :: Trace IO evt -> IO (Trace IO evt) - noHook = pure - --- | Adds the possibility to add special tracers via the hook function -mkCardanoTracer' :: forall evt evt1. - ( LogFormatting evt1 - , MetaTrace evt1 - ) - => Trace IO FormattedMessage - -> Trace IO FormattedMessage - -> Maybe (Trace IO FormattedMessage) - -> [Text] - -> (Trace IO evt1 -> IO (Trace IO evt)) - -> IO (Trace IO evt) -mkCardanoTracer' trStdout trForward mbTrEkg tracerPrefix hook = do - - !internalTr <- backendsAndFormat - trStdout - trForward - Nothing - (Trace T.nullTracer) - >>= addContextAndFilter - - -- handle the messages - !messageTrace <- withBackendsFromConfig (backendsAndFormat trStdout trForward) - >>= withLimitersFromConfig internalTr - >>= traceNamespaceErrors internalTr - >>= addContextAndFilter - >>= maybeSilent isSilentTracer tracerPrefix False - >>= hook - - -- handle the metrics - !metricsTrace <- case mbTrEkg of - Nothing -> pure $ Trace T.nullTracer - Just ekgTrace -> - pure (metricsFormatter ekgTrace) --- >>= recordMetricsStatistics internalTr - >>= maybeSilent hasNoMetrics tracerPrefix True - >>= hook - - pure (messageTrace <> metricsTrace) - - where - {-# INLINE addContextAndFilter #-} - addContextAndFilter :: MetaTrace a => Trace IO a -> IO (Trace IO a) - addContextAndFilter tr = do - tr' <- withDetailsFromConfig - $ withPrivacy - $ withDetails tr - tr'' <- filterSeverityFromConfig tr' - pure $ withNames tracerPrefix - $ withSeverity tr'' - - traceNamespaceErrors :: - Trace IO TraceDispatcherMessage - -> Trace IO evt1 - -> IO (Trace IO evt1) - traceNamespaceErrors internalTr (Trace tr) = do - pure $ Trace (T.arrow (T.emit - (\case - (lc, Right e) -> process lc (Right e) - (lc, Left e) -> T.traceWith tr (lc, Left e)))) - where - process :: LoggingContext -> Either TraceControl evt1 -> IO () - process lc cont = do - when (isNothing (lcPrivacy lc)) $ - traceWith - (appendPrefixNames ["Reflection"] internalTr) - (UnknownNamespace (lcNSPrefix lc) (lcNSInner lc) UKFPrivacy) - when (isNothing (lcSeverity lc)) $ - traceWith - (appendPrefixNames ["Reflection"] internalTr) - (UnknownNamespace (lcNSPrefix lc) (lcNSInner lc) UKFSeverity) - when (isNothing (lcDetails lc)) $ - traceWith - (appendPrefixNames ["Reflection"] internalTr) - (UnknownNamespace (lcNSPrefix lc) (lcNSInner lc) UKFDetails) - T.traceWith tr (lc, cont) - -backendsAndFormat :: - LogFormatting a - => Trace IO FormattedMessage - -> Trace IO FormattedMessage - -> Maybe [BackendConfig] - -> Trace IO x - -> IO (Trace IO a) -backendsAndFormat trStdout trForward mbBackends _ = do - let mbForwardTrace = if forwarder - then Just $ filterTraceByPrivacy (Just Public) - (forwardFormatter' trForward) - else Nothing - mbStdoutTrace | humColoured - = Just (humanFormatter' True trStdout) - | humUncoloured - = Just (humanFormatter' False trStdout) - | Stdout MachineFormat `L.elem` backends' - = Just (machineFormatter' trStdout) - | otherwise = Nothing - case mbForwardTrace <> mbStdoutTrace of - Nothing -> pure $ Trace T.nullTracer - Just tr -> preFormatted (humColoured || humUncoloured || forwarder) tr - where - backends' = fromMaybe - [Forwarder, Stdout MachineFormat] - mbBackends - - humColoured = Stdout HumanFormatColoured `L.elem` backends' - humUncoloured = Stdout HumanFormatUncoloured `L.elem` backends' - forwarder = Forwarder `L.elem` backends' - -traceConfigWarnings :: - Trace IO FormattedMessage - -> Trace IO FormattedMessage - -> [Text] - -> IO () -traceConfigWarnings trStdout trForward errs = do - internalTr <- backendsAndFormat - trStdout - trForward - Nothing - (Trace T.nullTracer) - traceWith ((withInnerNames . appendPrefixNames ["Reflection"]. withSeverity) - internalTr) - (TracerConsistencyWarnings errs) - -traceEffectiveConfiguration :: - Trace IO FormattedMessage - -> Trace IO FormattedMessage - -> TraceConfig - -> IO () -traceEffectiveConfiguration trStdout trForward trConfig = do - internalTr <- backendsAndFormat - trStdout - trForward - Nothing - (Trace T.nullTracer) - traceWith ((withInnerNames . appendPrefixNames ["Reflection"]. withSeverity) - internalTr) - (TracerInfoConfig trConfig) - -traceTracerInfo :: - Trace IO FormattedMessage - -> Trace IO FormattedMessage - -> ConfigReflection - -> IO () -traceTracerInfo trStdout trForward cr = do - internalTr <- backendsAndFormat - trStdout - trForward - Nothing - (Trace T.nullTracer) - silentSet <- readIORef (crSilent cr) - metricSet <- readIORef (crNoMetrics cr) - allTracerSet <- readIORef (crAllTracers cr) - let silentList = map (intercalate (singleton '.')) (Set.toList silentSet) - let metricsList = map (intercalate (singleton '.')) (Set.toList metricSet) - let allTracersList = map (intercalate (singleton '.')) (Set.toList allTracerSet) - traceWith ((withInnerNames . appendPrefixNames ["Reflection"]. withSeverity) - internalTr) - (TracerInfo silentList metricsList allTracersList) - writeIORef (crSilent cr) Set.empty - writeIORef (crNoMetrics cr) Set.empty - writeIORef (crAllTracers cr) Set.empty - --- A basic tracer just for metrics -mkMetricsTracer :: Maybe (Trace IO FormattedMessage) -> Trace IO FormattedMessage -mkMetricsTracer mbTrEkg = case mbTrEkg of - Nothing -> Trace T.nullTracer - Just ekgTrace -> ekgTrace - -_recordMetricsStatistics :: forall a m . (LogFormatting a, MonadIO m) - => Trace m TraceDispatcherMessage - -> Trace m a - -> m (Trace m a) -_recordMetricsStatistics internalTr (Trace tr) = do - ref <- liftIO $ newMVar (0, Map.empty) - pure $ Trace (T.arrow (T.emit - (\case - (lc, Right e) -> process ref lc e - (lc, Left e) -> T.traceWith tr (lc, Left e)))) - where - process :: MVar (Int, Map.Map Text Int) -> LoggingContext -> a -> m () - process ref lc msg = do - let metrics = asMetrics msg - mapM_ (\m -> - let mName = getMetricName m - in liftIO $ modifyMVar ref (\ (i', mmap) -> - case Map.lookup mName mmap of - Nothing -> pure ((i' + 1, Map.insert mName 1 mmap), ()) - Just _ -> pure ((i' + 1, Map.adjust (+1) mName mmap), ()))) metrics - (i,mmap) <- liftIO $ readMVar ref - when (i >= 1000) $ do - traceWith (withInnerNames (appendPrefixNames ["Reflection"] internalTr)) - (MetricsInfo mmap) - liftIO $ modifyMVar ref (\ (_i, mmap') -> pure ((0,mmap'), ())) - T.traceWith tr (lc, Right msg) diff --git a/trace-dispatcher/src/Cardano/Logging/Tracer/DataPoint.hs b/trace-dispatcher/src/Cardano/Logging/Tracer/DataPoint.hs deleted file mode 100644 index bb3416b3bb8..00000000000 --- a/trace-dispatcher/src/Cardano/Logging/Tracer/DataPoint.hs +++ /dev/null @@ -1,91 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Cardano.Logging.Tracer.DataPoint - ( - DataPoint (..) - , DataPointName - , DataPointStore - , initDataPointStore - , writeToStore - , dataPointTracer - , mkDataPointTracer - ) where - -import Cardano.Logging.DocuGenerator -import Cardano.Logging.Trace -import Cardano.Logging.Types - -import Control.Concurrent.STM (atomically) -import Control.Concurrent.STM.TVar -import Control.DeepSeq (NFData, ($!!)) -import Control.Monad.IO.Class -import qualified Control.Tracer as NT -import Data.Aeson -import qualified Data.Map.Strict as M -import Data.Text (Text, intercalate) - ---------------------------------------------------------------------------- --- --- | Type wrapper for some value of type 'v'. The only reason we need this --- wrapper is an ability to store different values in the same 'DataPointStore'. --- --- Please note that when the acceptor application will read the value of type 'v' --- from the store, this value is just as unstructured JSON, but not Haskell --- value of type 'v'. That's why 'FromJSON' instance for type 'v' should be --- available for the acceptor application, to decode unstructured JSON. --- -data DataPoint where - DataPoint :: (ToJSON v, NFData v) => !v -> DataPoint - -type DataPointName = Text -type DataPointStore = TVar (M.Map DataPointName DataPoint) - - -initDataPointStore :: IO DataPointStore -initDataPointStore = newTVarIO M.empty - --- | Write 'DataPoint' to the store. -writeToStore - :: DataPointStore - -> DataPointName - -> DataPoint - -> IO () -writeToStore dpStore dpName (DataPoint obj) = - let !newVal = DataPoint $!! obj - in atomically $ - modifyTVar' dpStore $ - M.insert dpName newVal - -dataPointTracer :: forall m. MonadIO m - => DataPointStore - -> Trace m DataPoint -dataPointTracer dataPointStore = - Trace $ NT.arrow $ NT.emit $ uncurry output - where - output :: - LoggingContext - -> Either TraceControl DataPoint - -> m () - output LoggingContext {..} (Right val) = - liftIO $ writeToStore dataPointStore (nameSpaceToText (lcNSPrefix ++ lcNSInner)) val - output LoggingContext {} (Left TCReset) = liftIO $ do - pure () - output lk (Left c@TCDocument {}) = do - docIt DatapointBackend (lk, Left c) - output LoggingContext {} _ = pure () - - nameSpaceToText :: [Text] -> Text - nameSpaceToText = intercalate "." - --- A simple dataPointTracer which supports building a namespace. -mkDataPointTracer :: forall dp. (ToJSON dp, MetaTrace dp, NFData dp) - => Trace IO DataPoint - -> IO (Trace IO dp) -mkDataPointTracer trDataPoint = do - let tr = NT.contramap DataPoint trDataPoint - pure $ withInnerNames tr diff --git a/trace-dispatcher/src/Cardano/Logging/Tracer/EKG.hs b/trace-dispatcher/src/Cardano/Logging/Tracer/EKG.hs deleted file mode 100644 index 1f30ba28ee9..00000000000 --- a/trace-dispatcher/src/Cardano/Logging/Tracer/EKG.hs +++ /dev/null @@ -1,98 +0,0 @@ -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Cardano.Logging.Tracer.EKG ( - ekgTracer -) where - -import Cardano.Logging.DocuGenerator -import Cardano.Logging.Types -import Cardano.Logging.Utils (showTReal) - -import Control.Concurrent.MVar -import Control.Monad.IO.Class (MonadIO, liftIO) -import qualified Control.Tracer as T -import qualified Data.HashMap.Strict as Map -import Data.Maybe (fromMaybe) -import Data.Text (Text, intercalate) -import qualified System.Metrics as Metrics -import qualified System.Metrics.Counter as Counter -import qualified System.Metrics.Gauge as Gauge -import qualified System.Metrics.Label as Label - - --- Using a hashmap, as metrics names typically contain long common prefixes, which is suboptimal for key lookup based on Ord -type Map = Map.HashMap - --- | It is mandatory to construct only one standard tracer in any application! --- Throwing away a standard tracer and using a new one will result in an exception -ekgTracer :: MonadIO m => TraceConfig -> Metrics.Store -> m (Trace m FormattedMessage) -ekgTracer TraceConfig{tcMetricsPrefix} store = liftIO $ do - rgsGauges <- newMVar Map.empty - rgsLabels <- newMVar Map.empty - rgsCounters <- newMVar Map.empty - pure $ Trace $ T.arrow $ T.emit $ - output rgsGauges rgsLabels rgsCounters - where - metricsPrefix = fromMaybe mempty tcMetricsPrefix - - output :: MonadIO m => - MVar (Map Text Gauge.Gauge) - -> MVar (Map Text Label.Label) - -> MVar (Map Text Counter.Counter) - -> (LoggingContext, Either TraceControl FormattedMessage) - -> m () - output rgsGauges rgsLabels rgsCounters - (_, Right (FormattedMetrics m)) = - liftIO $ mapM_ - (setIt rgsGauges rgsLabels rgsCounters) m - output _ _ _ p@(_, Left TCDocument {}) = - docIt EKGBackend p - output _ _ _ (LoggingContext{}, _) = - pure () - - setIt :: - MVar (Map Text Gauge.Gauge) - -> MVar (Map Text Label.Label) - -> MVar (Map Text Counter.Counter) - -> Metric - -> IO () - setIt rgsGauges rgsLabels rgsCounters = \case - IntM name theInt -> do - let fullName = metricsPrefix <> name <> "_int" - gauge <- modifyMVar rgsGauges (setFunc Metrics.createGauge fullName) - Gauge.set gauge (fromIntegral theInt) - DoubleM name theDouble -> do - let fullName = metricsPrefix <> name <> "_real" - label <- modifyMVar rgsLabels (setFunc Metrics.createLabel fullName) - Label.set label (showTReal theDouble) - PrometheusM name keyLabels -> do - let fullName = metricsPrefix <> name - label <- modifyMVar rgsLabels (setFunc Metrics.createLabel fullName) - Label.set label (presentPrometheusM keyLabels) - CounterM name mbInt -> do - let fullName = metricsPrefix <> name <> "_counter" - counter <- modifyMVar rgsCounters (setFunc Metrics.createCounter fullName) - case mbInt of - Nothing -> Counter.inc counter - Just i -> Counter.add counter (fromIntegral i) - - setFunc :: - (Text -> Metrics.Store -> IO m) - -> Text - -> Map Text m - -> IO (Map Text m, m) - setFunc createAction name rgsMap = - case Map.lookup name rgsMap of - Just metric -> pure (rgsMap, metric) - Nothing -> do - metric <- createAction name store - let rgsMap' = Map.insert name metric rgsMap - pure (rgsMap', metric) - - presentPrometheusM :: [(Text, Text)] -> Text - presentPrometheusM = - label . map pair - where - label pairs = "{" <> intercalate "," pairs <> "} 1" - pair (k, v) = k <> "=\"" <> v <> "\"" diff --git a/trace-dispatcher/src/Cardano/Logging/Tracer/Forward.hs b/trace-dispatcher/src/Cardano/Logging/Tracer/Forward.hs deleted file mode 100644 index 4801818d155..00000000000 --- a/trace-dispatcher/src/Cardano/Logging/Tracer/Forward.hs +++ /dev/null @@ -1,38 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Cardano.Logging.Tracer.Forward - ( - forwardTracer - ) where - -import Cardano.Logging.DocuGenerator -import Cardano.Logging.Types - -import Control.Monad.IO.Class -import qualified Control.Tracer as T - - ---------------------------------------------------------------------------- - --- | It is mandatory to construct only one forwardTracer tracer in any application! --- Throwing away a forwardTracer tracer and using a new one will result in an exception -forwardTracer :: forall m. (MonadIO m) - => (TraceObject -> IO ()) - -> Trace m FormattedMessage -forwardTracer write = - Trace $ T.arrow $ T.emit $ uncurry output - where - output :: - LoggingContext - -> Either TraceControl FormattedMessage - -> m () - output LoggingContext {} (Right (FormattedForwarder lo)) = liftIO $ - write lo - output LoggingContext {} (Left TCReset) = liftIO $ do - pure () - output lk (Left c@TCDocument {}) = - docIt Forwarder (lk, Left c) - output LoggingContext {} (Right _) = pure () - output LoggingContext {} _ = pure () diff --git a/trace-dispatcher/src/Cardano/Logging/Tracer/Standard.hs b/trace-dispatcher/src/Cardano/Logging/Tracer/Standard.hs deleted file mode 100644 index 89be103f00d..00000000000 --- a/trace-dispatcher/src/Cardano/Logging/Tracer/Standard.hs +++ /dev/null @@ -1,83 +0,0 @@ -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Cardano.Logging.Tracer.Standard ( - standardTracer -) where - -import Cardano.Logging.DocuGenerator -import Cardano.Logging.Types -import Cardano.Logging.Utils (threadLabelMe) - -import Control.Concurrent.Async -import Control.Concurrent.Chan.Unagi.Bounded -import Control.Exception (BlockedIndefinitelyOnMVar (..), handle) -import Control.Monad (forever, when) -import Control.Monad.IO.Class -import qualified Control.Tracer as T -import Data.IORef -import Data.Maybe (isNothing) -import Data.Text (Text) -import qualified Data.Text.IO as TIO -import System.IO (hFlush, stdout) - --- | The state of a standard tracer -newtype StandardTracerState = StandardTracerState { - stRunning :: Maybe (InChan Text, OutChan Text, Async ()) -} - -emptyStandardTracerState :: StandardTracerState -emptyStandardTracerState = StandardTracerState Nothing - --- | The standardTracer handles stdout logging in a thread-safe manner. --- It is strongly advised to construct only one standardTracer for any application. -standardTracer :: forall m. (MonadIO m) - => m (Trace m FormattedMessage) -standardTracer = do - stateRef <- liftIO $ newIORef emptyStandardTracerState - pure $ Trace $ T.arrow $ T.emit $ uncurry (output stateRef) - where - output :: - IORef StandardTracerState - -> LoggingContext - -> Either TraceControl FormattedMessage - -> m () - output stateRef LoggingContext{} (Right (FormattedHuman _c msg)) = liftIO $ do - st <- readIORef stateRef - case stRunning st of - Just (inChannel, _, _) -> writeChan inChannel msg - Nothing -> pure () - output stateRef LoggingContext{} (Right (FormattedMachine msg)) = liftIO $ do - st <- readIORef stateRef - case stRunning st of - Just (inChannel, _, _) -> writeChan inChannel msg - Nothing -> pure () - output stateRef LoggingContext{} (Left TCReset) = liftIO $ do - st <- readIORef stateRef - case stRunning st of - Nothing -> when (isNothing $ stRunning st) $ - startStdoutThread stateRef - Just _ -> pure () - output _ lk c@(Left TCDocument {}) = - docIt - (Stdout MachineFormat) -- TODO Find out the right format - (lk, c) - output _stateRef LoggingContext {} _ = pure () - --- | Forks a new thread, which writes messages to stdout -startStdoutThread :: IORef StandardTracerState -> IO () -startStdoutThread stateRef = do - (inChan, outChan) <- newChan 2048 - as <- async $ threadLabelMe "StdoutTrace" >> stdoutThread outChan - link as - atomicWriteIORef stateRef $ StandardTracerState (Just (inChan, outChan, as)) - --- | The new thread, which does the actual write from the queue. --- Will safely terminate when all producers have gone out of scope. -stdoutThread :: OutChan Text -> IO () -stdoutThread outChan = - handle (\BlockedIndefinitelyOnMVar -> pure ()) $ - forever $ do - readChan outChan - >>= TIO.putStrLn - hFlush stdout diff --git a/trace-dispatcher/src/Cardano/Logging/Types.hs b/trace-dispatcher/src/Cardano/Logging/Types.hs deleted file mode 100644 index c0fb6d83250..00000000000 --- a/trace-dispatcher/src/Cardano/Logging/Types.hs +++ /dev/null @@ -1,656 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneKindSignatures #-} - -{-# OPTIONS_GHC -Wno-partial-fields #-} - -module Cardano.Logging.Types ( - Trace(..) - , LogFormatting(..) - , Metric(..) - , getMetricName - , emptyObject - , Documented(..) - , DocMsg(..) - , LoggingContext(..) - , emptyLoggingContext - , Namespace(..) - , nsReplacePrefix - , nsReplaceInner - , nsCast - , nsPrependInner - , nsGetComplete - , nsGetTuple - , nsRawToText - , nsToText - , MetaTrace(..) - , DetailLevel(..) - , Privacy(..) - , SeverityS(..) - , SeverityF(..) - , ConfigOption(..) - , ForwarderAddr(..) - , FormatLogging(..) - , ForwarderMode(..) - , Verbosity(..) - , TraceOptionForwarder(..) - , defaultForwarder - , ConfigReflection(..) - , emptyConfigReflection - , TraceConfig(..) - , emptyTraceConfig - , FormattedMessage(..) - , TraceControl(..) - , DocCollector(..) - , LogDoc(..) - , emptyLogDoc - , BackendConfig(..) - , Folding(..) - , unfold - , TraceObject(..) - , PreFormatted(..) - , HowToConnect(..) -) where - -import Codec.Serialise (Serialise (..)) -import Control.Applicative ((<|>)) -import Control.DeepSeq (NFData) -import qualified Control.Tracer as T -import qualified Data.Aeson as AE -import qualified Data.Aeson.Types as AE (Parser) -import Data.Bool (bool) -import Data.ByteString (ByteString) -import qualified Data.HashMap.Strict as HM -import Data.IORef -import Data.Kind (Type) -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as Map -import Data.Set (Set) -import qualified Data.Set as Set -import Data.Text as T (Text, breakOnEnd, intercalate, null, pack, singleton, unpack, - unsnoc, words) -import Data.Text.Read as T (decimal) -import Data.Time (UTCTime) -import Data.Word (Word16) -import GHC.Generics -import Network.HostName (HostName) -import Network.Socket (PortNumber) - - --- | The Trace carries the underlying tracer Tracer from the contra-tracer package. --- It adds a 'LoggingContext' and maybe a 'TraceControl' to every message. -newtype Trace m a = Trace - {unpackTrace :: T.Tracer m (LoggingContext, Either TraceControl a)} - --- | Contramap lifted to Trace -instance Monad m => T.Contravariant (Trace m) where - contramap f (Trace tr) = Trace $ - T.contramap (\case - (lc, Right a) -> (lc, Right (f a)) - (lc, Left tc) -> (lc, Left tc)) - tr - --- | @tr1 <> tr2@ will run @tr1@ and then @tr2@ with the same input. -instance Monad m => Semigroup (Trace m a) where - Trace a1 <> Trace a2 = Trace (a1 <> a2) - -instance Monad m => Monoid (Trace m a) where - mappend = (<>) - mempty = Trace T.nullTracer - --- | A unique identifier for every message, composed of text --- A namespace can as well appear with the tracer name (e.g. "ChainDB.OpenEvent.OpenedDB"), --- or more prefixes, in this moment it is a NamespaceOuter is used -data Namespace a = Namespace { - nsPrefix :: [Text] - , nsInner :: [Text]} - deriving stock Eq - -instance Show (Namespace a) where - show (Namespace [] []) = "emptyNS" - show (Namespace [] nsInner') = - unpack $ intercalate (singleton '.') nsInner' - show (Namespace nsPrefix' nsInner') = - unpack $ intercalate (singleton '.') (nsPrefix' ++ nsInner') - -nsReplacePrefix :: [Text] -> Namespace a -> Namespace a -nsReplacePrefix o (Namespace _ i) = Namespace o i - -nsReplaceInner :: [Text] -> Namespace a -> Namespace a -nsReplaceInner i (Namespace o _) = Namespace o i - - -nsPrependInner :: Text -> Namespace a -> Namespace b -nsPrependInner t (Namespace o i) = Namespace o (t : i) - -{-# INLINE nsCast #-} -nsCast :: Namespace a -> Namespace b -nsCast (Namespace o i) = Namespace o i - -nsGetComplete :: Namespace a -> [Text] -nsGetComplete (Namespace [] i) = i -nsGetComplete (Namespace o i) = o ++ i - -nsGetTuple :: Namespace a -> ([Text],[Text]) -nsGetTuple (Namespace o i) = (o,i) - -nsRawToText :: ([Text], [Text]) -> Text -nsRawToText (ns1, ns2) = intercalate "." (ns1 ++ ns2) - -nsToText :: Namespace a -> Text -nsToText (Namespace ns1 ns2) = intercalate "." (ns1 ++ ns2) - --- | Every message needs this to define how to represent itself -class LogFormatting a where - -- | Machine readable representation with the possibility to represent with varying serialisations based on the detail level. - -- This will result in JSON formatted log output. - -- A `forMachine` implementation is required for any instance definition. - forMachine :: DetailLevel -> a -> AE.Object - - -- | Human-readable representation. - -- The empty text indicates there's no specific human-readable formatting for that type - this is the default implementation. - -- If however human-readble output is explicitly requested, e.g. by logs, the system will fall back to a JSON object - -- conforming to the `forMachine` definition, and rendering it as a value in `{"data": }`. - -- Leaving out `forHuman` in some instance definition will not lead to loss of log information that way. - forHuman :: a -> Text - forHuman _v = "" - - -- | Metrics representation. - -- The default indicates that no metric is based on trace occurrences of that type. - asMetrics :: a -> [Metric] - asMetrics _v = [] - - -class MetaTrace a where - namespaceFor :: a -> Namespace a - - severityFor :: Namespace a -> Maybe a -> Maybe SeverityS - privacyFor :: Namespace a -> Maybe a -> Maybe Privacy - privacyFor _ _ = Just Public - detailsFor :: Namespace a -> Maybe a -> Maybe DetailLevel - detailsFor _ _ = Just DNormal - - documentFor :: Namespace a -> Maybe Text - metricsDocFor :: Namespace a -> [(Text,Text)] - metricsDocFor _ = [] - allNamespaces :: [Namespace a] - -data Metric - -- | An integer metric. - -- Text is used to name the metric - = IntM Text Integer - -- | A double metric. - -- Text is used to name the metric - | DoubleM Text Double - -- | A counter metric. - -- Text is used to name the metric - | CounterM Text (Maybe Int) - -- | A prometheus metric with key label pairs. - -- Text is used to name the metric - -- [(Text, Text)] is used to represent the key label pairs - -- The value of the metric will always be "1" - -- e.g. if you have a prometheus metric with the name "prometheus_metric" - -- and the key label pairs [("key1", "value1"), ("key2", "value2")] - -- the metric will be represented as "prometheus_metric{key1=\"value1\",key2=\"value2\"} 1" - - | PrometheusM Text [(Text, Text)] - deriving stock (Eq, Show) - - -getMetricName :: Metric -> Text -getMetricName (IntM name _) = name -getMetricName (DoubleM name _) = name -getMetricName (CounterM name _) = name -getMetricName (PrometheusM name _) = name - - --- | A helper function for creating an empty |Object|. -emptyObject :: HM.HashMap Text a -emptyObject = HM.empty - --- Document all log messages by providing a list of DocMsgs for all constructors. --- Because it is not enforced by the type system, it is very --- important to provide a complete list, as the prototypes are used as well for configuration. --- If you don't want to add an item for documentation enter an empty text. -newtype Documented a = Documented {undoc :: [DocMsg a]} - deriving stock Show - deriving newtype Semigroup - --- | Document a message by giving a prototype, its most special name in the namespace --- and a comment in markdown format -data DocMsg a = DocMsg { - dmNamespace :: Namespace a - , dmMetricsMD :: [(Text, Text)] - , dmMarkdown :: Text -} - -instance Show (DocMsg a) where - show (DocMsg _ _ md) = unpack md - --- | Context any log message carries -data LoggingContext = LoggingContext { - lcNSInner :: [Text] - , lcNSPrefix :: [Text] - , lcSeverity :: Maybe SeverityS - , lcPrivacy :: Maybe Privacy - , lcDetails :: Maybe DetailLevel - } - deriving stock - (Show, Generic) - deriving anyclass - Serialise - -emptyLoggingContext :: LoggingContext -emptyLoggingContext = LoggingContext [] [] Nothing Nothing Nothing - --- | Formerly known as verbosity -data DetailLevel = - DMinimal - | DNormal - | DDetailed - | DMaximum - deriving stock (Eq, Ord, Show, Enum, Bounded, Generic) - deriving anyclass (Serialise, AE.FromJSON) - -instance AE.ToJSON DetailLevel where - toEncoding = AE.genericToEncoding AE.defaultOptions - --- | Privacy of a message. Default is Public -data Privacy = - Confidential -- ^ confidential information - handle with care - | Public -- ^ can be public. - deriving stock (Eq, Ord, Show, Enum, Bounded, Generic) - deriving anyclass Serialise - --- | Severity of a message -data SeverityS - = Debug -- ^ Debug messages - | Info -- ^ Information - | Notice -- ^ Normal runtime Conditions - | Warning -- ^ General Warnings - | Error -- ^ General Errors - | Critical -- ^ Severe situations - | Alert -- ^ Take immediate action - | Emergency -- ^ System is unusable - deriving stock (Eq, Ord, Show, Read, Enum, Bounded, Generic) - deriving anyclass (AE.ToJSON, AE.FromJSON, Serialise) - --- | Severity for a filter --- Nothing means don't show anything (Silence) --- Just level means show messages with severity >= level -newtype SeverityF = SeverityF (Maybe SeverityS) - deriving stock Eq - -instance Enum SeverityF where - toEnum 8 = SeverityF Nothing - toEnum i = SeverityF (Just (toEnum i)) - fromEnum (SeverityF Nothing) = 8 - fromEnum (SeverityF (Just s)) = fromEnum s - -instance AE.ToJSON SeverityF where - toJSON (SeverityF (Just s)) = AE.String ((pack . show) s) - toJSON (SeverityF Nothing) = AE.String "Silence" - -instance AE.FromJSON SeverityF where - parseJSON (AE.String "Debug") = pure (SeverityF (Just Debug)) - parseJSON (AE.String "Info") = pure (SeverityF (Just Info)) - parseJSON (AE.String "Notice") = pure (SeverityF (Just Notice)) - parseJSON (AE.String "Warning") = pure (SeverityF (Just Warning)) - parseJSON (AE.String "Error") = pure (SeverityF (Just Error)) - parseJSON (AE.String "Critical") = pure (SeverityF (Just Critical)) - parseJSON (AE.String "Alert") = pure (SeverityF (Just Alert)) - parseJSON (AE.String "Emergency") = pure (SeverityF (Just Emergency)) - parseJSON (AE.String "Silence") = pure (SeverityF Nothing) - parseJSON invalid = fail $ "Parsing of filter Severity failed." - <> "Unknown severity: " <> show invalid - -instance Ord SeverityF where - compare (SeverityF (Just s1)) (SeverityF (Just s2)) = compare s1 s2 - compare (SeverityF Nothing) (SeverityF Nothing) = EQ - compare (SeverityF (Just _s1)) (SeverityF Nothing) = LT - compare (SeverityF Nothing) (SeverityF (Just _s2)) = GT - -instance Show SeverityF where - show (SeverityF (Just s)) = show s - show (SeverityF Nothing) = "Silence" - - ----------------------------------------------------------------- --- Configuration - --- | -data ConfigReflection = ConfigReflection { - crSilent :: IORef (Set [Text]) - , crNoMetrics :: IORef (Set [Text]) - , crAllTracers :: IORef (Set [Text]) - } - -emptyConfigReflection :: IO ConfigReflection -emptyConfigReflection = do - silence <- newIORef Set.empty - hasMetrics <- newIORef Set.empty - allTracers <- newIORef Set.empty - pure $ ConfigReflection silence hasMetrics allTracers - -data FormattedMessage = - FormattedHuman Bool Text - -- ^ The bool specifies if the formatting includes colours - | FormattedMachine Text - | FormattedMetrics [Metric] - | FormattedForwarder TraceObject - | FormattedCBOR ByteString - deriving stock (Eq, Show) - - -data PreFormatted = PreFormatted { - pfTime :: !UTCTime - , pfNamespace :: !Text - , pfThreadId :: !Text - , pfForHuman :: !(Maybe Text) - , pfForMachineObject :: AE.Object -} - --- | Used as interface object for ForwarderTracer -data TraceObject = TraceObject { - toHuman :: !(Maybe Text) - , toMachine :: !Text - , toNamespace :: ![Text] - , toSeverity :: !SeverityS - , toDetails :: !DetailLevel - , toTimestamp :: !UTCTime - , toHostname :: !Text - , toThreadId :: !Text -} deriving stock - (Eq, Show, Generic) - -- ^ Instances for 'TraceObject' to forward it using 'trace-forward' library. - deriving anyclass - (Serialise) - --- | -data BackendConfig = - Forwarder - | Stdout FormatLogging - | EKGBackend - | DatapointBackend - | PrometheusSimple Bool (Maybe HostName) PortNumber -- boolean: drop suffixes like "_int" in exposition; default: False - deriving stock (Eq, Ord, Show, Generic) - -instance AE.ToJSON BackendConfig where - toJSON Forwarder = AE.String "Forwarder" - toJSON DatapointBackend = AE.String "DatapointBackend" - toJSON EKGBackend = AE.String "EKGBackend" - toJSON (Stdout f) = AE.String $ "Stdout " <> (pack . show) f - toJSON (PrometheusSimple s h p) = AE.String $ "PrometheusSimple " - <> bool mempty "nosuffix" s - <> maybe mempty ((<> " ") . pack) h - <> (pack . show) p - -instance AE.FromJSON BackendConfig where - parseJSON = AE.withText "BackendConfig" $ \case - "Forwarder" -> pure Forwarder - "EKGBackend" -> pure EKGBackend - "DatapointBackend" -> pure DatapointBackend - "Stdout HumanFormatColoured" -> pure $ Stdout HumanFormatColoured - "Stdout HumanFormatUncoloured" -> pure $ Stdout HumanFormatUncoloured - "Stdout MachineFormat" -> pure $ Stdout MachineFormat - prometheus -> either fail pure (parsePrometheusString prometheus) - -parsePrometheusString :: Text -> Either String BackendConfig -parsePrometheusString t = case T.words t of - ["PrometheusSimple", portNo_] -> - parsePort portNo_ >>= Right . PrometheusSimple False Nothing - ["PrometheusSimple", arg, portNo_] -> - parsePort portNo_ >>= Right . if validSuffix arg then PrometheusSimple (isNoSuffix arg) Nothing else PrometheusSimple False (Just $ unpack arg) - ["PrometheusSimple", noSuff, host, portNo_] - | validSuffix noSuff -> parsePort portNo_ >>= Right . PrometheusSimple (isNoSuffix noSuff) (Just $ unpack host) - | otherwise -> Left $ "invalid modifier for PrometheusSimple: " ++ show noSuff - _ - -> Left $ "unknown backend: " ++ show t - where - validSuffix s = s == "suffix" || s == "nosuffix" - isNoSuffix = (== "nosuffix") - parsePort p = case T.decimal p of - Right (portNo :: Word, rest) - | T.null rest && 0 < portNo && portNo < 65536 -> Right $ fromIntegral portNo - _ -> failure - where failure = Left $ "invalid PrometheusSimple port: " ++ show p - -data FormatLogging = - HumanFormatColoured - | HumanFormatUncoloured - | MachineFormat - deriving stock (Eq, Ord, Show) - --- Configuration options for individual namespace elements -data ConfigOption = - -- | Severity level for a filter (default is Warning) - ConfSeverity {severity :: SeverityF} - -- | Detail level (default is DNormal) - | ConfDetail {detail :: DetailLevel} - -- | To which backend to pass - -- Default is [EKGBackend, Forwarder, Stdout MachineFormat] - | ConfBackend {backends :: [BackendConfig]} - -- | Construct a limiter with limiting to the Double, - -- which represents frequency in number of messages per second - | ConfLimiter {maxFrequency :: Double} - deriving stock (Eq, Ord, Show, Generic) - -newtype ForwarderAddr - = LocalSocket FilePath - deriving stock (Eq, Ord, Show) - -instance AE.FromJSON ForwarderAddr where - parseJSON = AE.withObject "ForwarderAddr" $ \o -> LocalSocket <$> o AE..: "filePath" - -data ForwarderMode = - -- | Forwarder works as a client: it initiates network connection with - -- 'cardano-tracer' and/or another Haskell acceptor application. - Initiator - -- | Forwarder works as a server: it accepts network connection from - -- 'cardano-tracer' and/or another Haskell acceptor application. - | Responder - deriving stock (Eq, Ord, Show, Generic) - -data Verbosity = - -- | Maximum verbosity for all tracers in the forwarding protocols. - Maximum - -- | Minimum verbosity, the forwarding will work as silently as possible. - | Minimum - deriving stock (Eq, Ord, Show, Generic) - deriving anyclass AE.ToJSON - -instance AE.FromJSON Verbosity where - parseJSON (AE.String "Maximum") = pure Maximum - parseJSON (AE.String "Minimum") = pure Minimum - parseJSON other = fail $ "Parsing of Verbosity failed." - <> "Unknown Verbosity: " <> show other - -data TraceOptionForwarder = TraceOptionForwarder { - tofQueueSize :: Word - , tofVerbosity :: Verbosity - , tofMaxReconnectDelay :: Word -} deriving stock (Eq, Ord, Show, Generic) - --- A word regarding queue size: --- --- In case of a missing forwarding service consumer, traces messages will be --- buffered. This mitigates short forwarding interruptions, or delays at startup --- time. --- --- The queue capacity should thus correlate to the expected log lines per second --- given a particular tracing configuration - to avoid unnecessarily increasing --- memory footprint. --- --- The default values here are chosen to accomodate verbose tracing output --- (i.e., buffering 1min worth of trace data given ~32 messages per second). A --- config that results in less than 5 msgs per second should also provide --- `TraceOptionForwarder` a queue size value considerably lower. --- --- The queue size ties in with the max number of trace objects cardano-tracer --- requests periodically, the default for that being 100. Here, the queue can --- hold enough traces for 10 subsequent polls by cardano-tracer. -instance AE.FromJSON TraceOptionForwarder where - parseJSON = AE.withObject "TraceOptionForwarder" $ \obj -> do - -- Field "queueSize" is the new field that replaces and unifies - -- both "connQueueSize" and "disconnQueueSize". - maybeQueueSize <- obj AE..:? "queueSize" - queueSize <- case maybeQueueSize of - -- If the new field was provided we use it. - (Just qs) -> return qs - -- Else we look for the deprecated fields. - Nothing -> do - connQueueSize <- obj AE..:? "connQueueSize" AE..!= 128 - disconnQueueSize <- obj AE..:? "disconnQueueSize" AE..!= 192 - return $ max connQueueSize disconnQueueSize - verbosity <- obj AE..:? "verbosity" AE..!= Minimum - maxReconnectDelay <- obj AE..:? "maxReconnectDelay" AE..!= 45 - return $ TraceOptionForwarder queueSize verbosity maxReconnectDelay - -instance AE.ToJSON TraceOptionForwarder where - toJSON TraceOptionForwarder{..} = AE.object - [ - "queueSize" AE..= tofQueueSize, - "verbosity" AE..= tofVerbosity, - "maxReconnectDelay" AE..= tofMaxReconnectDelay - ] - -defaultForwarder :: TraceOptionForwarder -defaultForwarder = TraceOptionForwarder { - tofQueueSize = 192 - , tofVerbosity = Minimum - , tofMaxReconnectDelay = 45 -} - -instance AE.FromJSON ForwarderMode where - parseJSON (AE.String "Initiator") = pure Initiator - parseJSON (AE.String "Responder") = pure Responder - parseJSON other = fail $ "Parsing of ForwarderMode failed." - <> "Unknown ForwarderMode: " <> show other - -data TraceConfig = TraceConfig { - -- | Options specific to a certain namespace - tcOptions :: Map.Map [Text] [ConfigOption] - -- | Options for the forwarder - , tcForwarder :: Maybe TraceOptionForwarder - -- | Optional human-readable name of the node. - , tcNodeName :: Maybe Text - -- | Optional prefix for metrics. - , tcMetricsPrefix :: Maybe Text - -- | Optional resource trace frequency in milliseconds. - , tcResourceFrequency :: Maybe Int - -- | Optional ledger metrics frequency in milliseconds. - , tcLedgerMetricsFrequency :: Maybe Int -} - deriving stock (Eq, Ord, Show) - -emptyTraceConfig :: TraceConfig -emptyTraceConfig = TraceConfig { - tcOptions = Map.empty - , tcForwarder = Nothing - , tcNodeName = Nothing - , tcMetricsPrefix = Nothing - , tcResourceFrequency = Just 5000 -- Every five seconds - , tcLedgerMetricsFrequency = Just 1 -- Every slot - } - ---------------------------------------------------------------------------- --- Control and Documentation - --- | When configuring a net of tracers, it should be run with Config on all --- entry points first, and then with TCOptimize. When reconfiguring it needs to --- run TCReset followed by Config followed by TCOptimize -data TraceControl where - TCReset :: TraceControl - TCConfig :: TraceConfig -> TraceControl - TCOptimize :: ConfigReflection -> TraceControl - TCDocument :: Int -> DocCollector -> TraceControl - -newtype DocCollector = DocCollector (IORef (Map Int LogDoc)) - -data LogDoc = LogDoc { - ldDoc :: !Text - , ldMetricsDoc :: !(Map.Map Text Text) - , ldNamespace :: ![([Text],[Text])] - , ldSeverityCoded :: !(Maybe SeverityS) - , ldPrivacyCoded :: !(Maybe Privacy) - , ldDetailsCoded :: !(Maybe DetailLevel) - , ldDetails :: ![DetailLevel] - , ldBackends :: ![BackendConfig] - , ldFiltered :: ![SeverityF] - , ldLimiter :: ![(Text, Double)] - , ldSilent :: Bool -} deriving stock (Eq, Show) - -emptyLogDoc :: Text -> [(Text, Text)] -> LogDoc -emptyLogDoc d m = LogDoc d (Map.fromList m) [] Nothing Nothing Nothing [] [] [] [] False - --- | Type for the function foldTraceM from module Cardano/Logging/Trace -newtype Folding a b = Folding b - -unfold :: Folding a b -> b -unfold (Folding b) = b - -instance LogFormatting b => LogFormatting (Folding a b) where - forMachine v (Folding b) = forMachine v b - forHuman (Folding b) = forHuman b - asMetrics (Folding b) = asMetrics b - --- | Specifies how to connect to the peer. --- --- Taken from ekg-forward:System.Metrics.Configuration, to avoid dependency. -type Host :: Type -type Host = Text - -type Port :: Type -type Port = Word16 - -type HowToConnect :: Type -data HowToConnect - = LocalPipe !FilePath -- ^ Local pipe (UNIX or Windows). - | RemoteSocket !Host !Port -- ^ Remote socket (host and port). - deriving stock (Eq, Generic) - deriving anyclass (NFData) - -instance Show HowToConnect where - show = \case - LocalPipe pipe -> pipe - RemoteSocket host port -> T.unpack host ++ ":" ++ show port - -instance AE.ToJSON HowToConnect where - toJSON = AE.toJSON . show - toEncoding = AE.toEncoding . show - --- first try to host:port, and if that fails revert to parsing any --- string literal and assume it is a localpipe. -instance AE.FromJSON HowToConnect where - parseJSON = AE.withText "HowToConnect" $ \t -> - (uncurry RemoteSocket <$> parseHostPort t) - <|> ( LocalPipe <$> parseLocalPipe t) - -parseLocalPipe :: Text -> AE.Parser FilePath -parseLocalPipe t - | T.null t = fail "parseLocalPipe: empty Text" - | otherwise = pure $ T.unpack t - -parseHostPort :: Text -> AE.Parser (Text, Word16) -parseHostPort t - | T.null t - = fail "parseHostPort: empty Text" - | otherwise - = let - (host_, portText) = T.breakOnEnd ":" t - host = maybe "" fst (T.unsnoc host_) - in if - | T.null host -> fail "parseHostPort: Empty host or no colon found." - | T.null portText -> fail "parseHostPort: Empty port." - | Right (port, remainder) <- T.decimal portText - , T.null remainder - , 0 <= port, port <= 65535 -> pure (host, port) - | otherwise -> fail "parseHostPort: Non-numeric port or value out of range." diff --git a/trace-dispatcher/src/Cardano/Logging/Types/NodeInfo.hs b/trace-dispatcher/src/Cardano/Logging/Types/NodeInfo.hs deleted file mode 100644 index df38d875792..00000000000 --- a/trace-dispatcher/src/Cardano/Logging/Types/NodeInfo.hs +++ /dev/null @@ -1,27 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# Language DerivingStrategies #-} -{-# Language DeriveAnyClass #-} - -module Cardano.Logging.Types.NodeInfo - ( NodeInfo (..) - ) - where - -import Control.DeepSeq (NFData) -import Data.Aeson (FromJSON, ToJSON) -import Data.Text (Text) -import Data.Time (UTCTime) -import GHC.Generics (Generic) - --- | NodeInfo - -data NodeInfo = NodeInfo - { niName :: Text - , niProtocol :: Text - , niVersion :: Text - , niCommit :: Text - , niStartTime :: UTCTime - , niSystemStartTime :: UTCTime - } - deriving stock (Eq, Show, Generic) - deriving anyclass (NFData, ToJSON, FromJSON) diff --git a/trace-dispatcher/src/Cardano/Logging/Types/NodeStartupInfo.hs b/trace-dispatcher/src/Cardano/Logging/Types/NodeStartupInfo.hs deleted file mode 100644 index 9ea7d1b4bbb..00000000000 --- a/trace-dispatcher/src/Cardano/Logging/Types/NodeStartupInfo.hs +++ /dev/null @@ -1,30 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# Language DerivingStrategies #-} -{-# Language DeriveAnyClass #-} - -module Cardano.Logging.Types.NodeStartupInfo - ( NodeStartupInfo (..) - ) - where - -import Control.DeepSeq (NFData) -import Data.Aeson (FromJSON, ToJSON) -import Data.Text (Text) -import Data.Time (NominalDiffTime) -import Data.Word (Word64) -import GHC.Generics (Generic) - --- | NodeStartupInfo - --- | This information is taken from 'BasicInfoShelleyBased'. It is required for --- 'cardano-tracer' service (particularly, for RTView). -data NodeStartupInfo = NodeStartupInfo - { suiEra :: Text - , suiSlotLength :: NominalDiffTime - , suiEpochLength :: Word64 - , suiSlotsPerKESPeriod :: Word64 - } - deriving stock - (Eq, Show, Generic) - deriving anyclass - (NFData, ToJSON, FromJSON) diff --git a/trace-dispatcher/src/Cardano/Logging/Types/TraceMessage.hs b/trace-dispatcher/src/Cardano/Logging/Types/TraceMessage.hs deleted file mode 100644 index 6310baf2044..00000000000 --- a/trace-dispatcher/src/Cardano/Logging/Types/TraceMessage.hs +++ /dev/null @@ -1,83 +0,0 @@ - -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE RecordWildCards #-} - -{-# OPTIONS_GHC -Wno-orphans #-} - -module Cardano.Logging.Types.TraceMessage - ( TraceMessage (..) - ) where - -import Cardano.Logging.Types - -import Codec.CBOR.JSON -import Codec.Serialise (Serialise (..)) -import Data.Aeson as AE hiding (decode, encode) -import Data.Text (Text) -import Data.Time.Clock (UTCTime) - - --- | base for a machine readable trace message (JSON or CBOR), with metadata, and enclosed payload data from the trace itself. -data TraceMessage = TraceMessage - { tmsgAt :: !UTCTime - , tmsgNS :: !Text - , tmsgData :: !AE.Object - , tmsgSev :: !SeverityS - , tmsgThread :: !Text - , tmsgHost :: !Text - } - deriving Show - -instance Serialise AE.Object where - encode = encodeValue . Object - decode = decodeValue True >>= \case - Object o -> pure o - x -> fail $ "decode(TraceMessage): expected JSON object, got: " ++ show x - - --- Serialisations are hand-rolled for higher degree of stability, and making them transparent. -instance Serialise TraceMessage where - encode TraceMessage{..} = - encode tmsgAt - <> encode tmsgNS - <> encode tmsgSev - <> encode tmsgData - <> encode tmsgThread - <> encode tmsgHost - - decode = do - tmsgAt <- decode - tmsgNS <- decode - tmsgSev <- decode - tmsgData <- decode - tmsgThread <- decode - tmsgHost <- decode - pure TraceMessage{..} - - -instance ToJSON TraceMessage where - toJSON TraceMessage{..} = AE.object - [ "at" .= tmsgAt - , "ns" .= tmsgNS - , "data" .= tmsgData - , "sev" .= tmsgSev - , "thread" .= tmsgThread - , "host" .= tmsgHost - ] - toEncoding TraceMessage{..} = AE.pairs $ - "at" .= tmsgAt - <> "ns" .= tmsgNS - <> "data" .= tmsgData - <> "sev" .= tmsgSev - <> "thread" .= tmsgThread - <> "host" .= tmsgHost - -instance FromJSON TraceMessage where - parseJSON = AE.withObject "TraceMessage" $ \v -> do - tmsgAt <- v .: "at" - tmsgNS <- v .: "ns" - tmsgData <- v .: "data" - tmsgSev <- v .: "sev" - tmsgThread <- v .: "thread" - tmsgHost <- v .: "host" - pure TraceMessage{..} diff --git a/trace-dispatcher/src/Cardano/Logging/Utils.hs b/trace-dispatcher/src/Cardano/Logging/Utils.hs deleted file mode 100644 index 2630da48f05..00000000000 --- a/trace-dispatcher/src/Cardano/Logging/Utils.hs +++ /dev/null @@ -1,69 +0,0 @@ -{-# LANGUAGE NumericUnderscores #-} - -module Cardano.Logging.Utils - ( module Cardano.Logging.Utils ) - where - - -import Control.Concurrent (threadDelay) -import Control.Concurrent.Async (concurrently_) -import Control.Exception (SomeAsyncException (..), SomeException, fromException, tryJust) -import Data.IORef -import qualified Data.Text as T -import qualified Data.Text.Lazy as TL (toStrict) -import qualified Data.Text.Lazy.Builder as T (toLazyText) -import qualified Data.Text.Lazy.Builder.Int as T -import qualified Data.Text.Lazy.Builder.RealFloat as T (realFloat) -import GHC.Conc (labelThread, myThreadId) - - --- | Run an IO action which may throw an exception in a loop. --- On exception, the action will be re-run after a pause. --- That pause doubles which each exception, but is reset when the action runs long enough. -runInLoop :: IO () -> (SomeException -> IO ()) -> Word -> Word -> IO () -runInLoop action handleInterruption initialDelay maxDelay - | initialDelay == 0 = runInLoop action handleInterruption 1 maxDelay - | maxDelay < initialDelay = runInLoop action handleInterruption initialDelay initialDelay - | otherwise = newIORef (fromIntegral initialDelay) >>= go - where - go :: IORef Int -> IO () - go currentDelay = - tryJust excludeAsyncExceptions (actionResettingDelay currentDelay) >>= \case - Left e -> do - handleInterruption e - waitForSecs <- atomicModifyIORef' currentDelay bumpDelay - threadDelay $ 1_000_000 * waitForSecs - go currentDelay - Right _ -> return () - - -- if the action runs at least maxDelay seconds, the pause is reset - actionResettingDelay currentDelay = concurrently_ action $ do - threadDelay $ fromIntegral $ 1_000_000 * maxDelay - atomicWriteIORef currentDelay $ fromIntegral initialDelay - - excludeAsyncExceptions e = - case fromException e of - Just SomeAsyncException{} -> Nothing - _ -> Just e - - bumpDelay current = - ( min (current * 2) (fromIntegral maxDelay) - , current - ) - - --- | Convenience function for a Show instance to be converted to text immediately -{-# INLINE showT #-} -showT :: Show a => a -> T.Text -showT = T.pack . show - -{-# INLINE showTHex #-} -showTHex :: Integral a => a -> T.Text -showTHex = TL.toStrict . T.toLazyText . T.hexadecimal - -{-# INLINE showTReal #-} -showTReal :: RealFloat a => a -> T.Text -showTReal = TL.toStrict . T.toLazyText . T.realFloat - -threadLabelMe :: String -> IO () -threadLabelMe label = myThreadId >>= flip labelThread label diff --git a/trace-dispatcher/src/Control/Tracer.hs b/trace-dispatcher/src/Control/Tracer.hs deleted file mode 100644 index 73a8f3bd019..00000000000 --- a/trace-dispatcher/src/Control/Tracer.hs +++ /dev/null @@ -1,244 +0,0 @@ -{-| -Module : Control.Tracer -Description : A simple interface for logging, tracing, and monitoring -Copyright : (c) Alexander Vieth, 2019 -Maintainer : aovieth@gmail.com -License : Apache-2.0 - -=== General usage - -'Tracer' is a contravariant functor intended to express the pattern in which -values of its parameter type are used to produce effects which are prescribed -by the caller, as in tracing, logging, code instrumentation, etc. - -Programs should be written to use as specific a tracer as possible, i.e. to -take as a parameter a @Tracer m domainSpecificType@. To combine these programs -into an executable which does meaningful tracing, an implementation of that -tracing should be used to make a @Tracer probablyIO implementationTracingType@, -which is 'contramap'ped to fit @Tracer m domainSpecificType@ wherever it is -needed, for the various @domainSpecificType@s that appear throughout the -program. - -=== An example - -This short example shows how a tracer can be deployed, highlighting the use of -'contramap' to fit a general tracer which writes text to a file, where a -specific tracer which takes domain-specific events is expected. - -> -- Writes text to some log file. -> traceToLogFile :: FilePath -> Tracer IO Text -> -> -- Domain-specific event type. -> data Event = EventA | EventB Int -> -> -- The log-file format for an Event. -> eventToText :: Event -> Text -> -> -- Some action that can use any tracer on Event, in any monad. -> actionWithTrace :: Monad m => Tracer m Event -> m () -> actionWithTrace tracer = do -> traceWith tracer EventA -> traceWith tracer (EventB 42) -> -> -- Set up a log file tracer, then use it where the Event tracer is expected. -> main :: IO () -> main = do -> textTacer <- traceToLogFile "log.txt" -> let eventTracer :: Tracer IO Event -> eventTracer = contramap eventToText tracer -> actionWithTrace eventTracer --} - -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Control.Tracer - ( Tracer (..) - , traceWith - , arrow - , use - , Arrow.squelch - , Arrow.emit - , Arrow.effect - -- * Simple tracers - , nullTracer - , stdoutTracer - , debugTracer - -- * Transforming tracers - , natTracer - , Arrow.nat - , traceMaybe - , squelchUnless - -- * Re-export of Contravariant - , Contravariant(..) - ) where - -import Control.Arrow (arr, runKleisli, (&&&), (|||)) -import Control.Category ((>>>)) -import qualified Control.Tracer.Arrow as Arrow -import Data.Functor.Contravariant (Contravariant (..)) - -import Debug.Trace (traceM) - --- | This type describes some effect in @m@ which depends upon some value of --- type @a@, for which the /output value/ is not of interest (only the effects). --- --- The motivating use case is to describe tracing, logging, monitoring, and --- similar features, in which the programmer wishes to provide some values to --- some /other/ program which will do some real world side effect, such as --- writing to a log file or bumping a counter in some monitoring system. --- --- The actual implementation of such a program will probably work on rather --- large, domain-agnostic types like @Text@, @ByteString@, JSON values for --- structured logs, etc. --- --- But the call sites which ultimately /invoke/ these implementations will deal --- with smaller, domain-specific types that concisely describe events, metrics, --- debug information, etc. --- --- This difference is reconciled by the 'Contravariant' instance for 'Tracer'. --- 'Data.Functor.Contravariant.contramap' is used to change the input type of --- a tracer. This allows for a more general tracer to be used where a more --- specific one is expected. --- --- Intuitively: if you can map your domain-specific type @Event@ to a @Text@ --- representation, then any @Tracer m Text@ can stand in where a --- @Tracer m Event@ is required. --- --- > eventToText :: Event -> Text --- > --- > traceTextToLogFile :: Tracer m Text --- > --- > traceEventToLogFile :: Tracer m Event --- > traceEventToLogFile = contramap eventToText traceTextToLogFile --- --- Effectful tracers that actually do interesting stuff can be defined --- using 'emit', and composed via 'contramap'. --- --- The 'nullTracer' can be used as a stand-in for any tracer, doing no --- side-effects and producing no interesting value. --- --- To deal with branching, the arrow interface on the underlying --- 'Control.Tracer.Arrow.Tracer' should be used. Arrow notation can be helpful --- here. --- --- For example, a common pattern is to trace only some variants of a sum type. --- --- > data Event = This Int | That Bool --- > --- > traceOnlyThat :: Tracer m Int -> Tracer m Bool --- > traceOnlyThat tr = Tracer $ proc event -> do --- > case event of --- > This i -> use tr -< i --- > That _ -> squelch -< () --- --- The key point of using the arrow representation we have here is that this --- tracer will not necessarily need to force @event@: if the input tracer @tr@ --- does not force its value, then @event@ will not be forced. To elaborate, --- suppose @tr@ is @nullTracer@. Then this expression becomes --- --- > classify (This i) = Left i --- > classify (That _) = Right () --- > --- > traceOnlyThat tr --- > = Tracer $ Pure classify >>> (squelch ||| squelch) >>> Pure (either id id) --- > = Tracer $ Pure classify >>> Pure (either (const (Left ())) (const (Right ()))) >>> Pure (either id id) --- > = Tracer $ Pure (classify >>> either (const (Left ())) (const (Right ())) >>> either id id) --- --- So that when this tracer is run by 'traceWith' we get --- --- > traceWith (traceOnlyThat tr) x --- > = traceWith (Pure _) --- > = pure () --- --- It is _essential_ that the computation of the tracing effects cannot itself --- have side-effects, as this would ruin the ability to short-circuit when --- it is known that no tracing will be done: the side-effects of a branch --- could change the outcome of another branch. This would fly in the face of --- a crucial design goal: you can leave your tracer calls in the program so --- they do not bitrot, but can also make them zero runtime cost by substituting --- 'nullTracer' appropriately. -newtype Tracer m a = Tracer { runTracer :: Arrow.TracerA m a () } - -instance Monad m => Contravariant (Tracer m) where - contramap f tracer = Tracer (arr f >>> use tracer) - --- | @tr1 <> tr2@ will run @tr1@ and then @tr2@ with the same input. -instance Monad m => Semigroup (Tracer m s) where - Tracer a1 <> Tracer a2 = Tracer (a1 &&& a2 >>> arr discard) - where - discard :: ((), ()) -> () - discard = const () - -instance Monad m => Monoid (Tracer m s) where - mappend = (<>) - mempty = nullTracer - -{-# INLINE traceWith #-} --- | Run a tracer with a given input. -traceWith :: Monad m => Tracer m a -> a -> m () -traceWith (Tracer tr) = runKleisli (Arrow.runTracerA tr) - --- | Inverse of 'use'. -{-# INLINE arrow #-} -arrow :: Arrow.TracerA m a () -> Tracer m a -arrow = Tracer - --- | Inverse of 'arrow'. Useful when writing arrow tracers which use a --- contravariant tracer (the newtype in this module). -{-# INLINE use #-} -use :: Tracer m a -> Arrow.TracerA m a () -use = runTracer - --- | A tracer which does nothing. -{-# INLINE nullTracer #-} -nullTracer :: Monad m => Tracer m a -nullTracer = Tracer Arrow.squelch - --- | Create a simple contravariant tracer which runs a given side-effect. -{-# INLINE emit #-} -emit :: Applicative m => (a -> m ()) -> Tracer m a -emit f = Tracer (Arrow.emit f) - --- | Run a tracer only for the Just variant of a Maybe. If it's Nothing, the --- 'nullTracer' is used (no output). --- --- The arrow representation allows for proper laziness: if the tracer parameter --- does not produce any tracing effects, then the predicate won't even be --- evaluated. Contrast with the simple contravariant representation as --- @a -> m ()@, in which the predicate _must_ be forced no matter what, --- because it's impossible to know a priori whether that function will not --- produce any tracing effects. --- --- It's written out explicitly for demonstration. Could also use arrow --- notation: --- --- > traceMaybe p tr = Tracer $ proc a -> do --- > case k a of --- > Just b -> use tr -< b --- > Nothing -> Arrow.squelch -< () --- -traceMaybe :: Monad m => (a -> Maybe b) -> Tracer m b -> Tracer m a -traceMaybe k tr = Tracer $ classify >>> (Arrow.squelch ||| use tr) - where - classify = arr (maybe (Left ()) Right . k) - --- | Uses 'traceMaybe' to give a tracer which emits only if a predicate is true. -squelchUnless :: Monad m => (a -> Bool) -> Tracer m a -> Tracer m a -squelchUnless p = traceMaybe (\a -> if p a then Just a else Nothing) - --- | Use a natural transformation to change the @m@ type. This is useful, for --- instance, to use concrete IO tracers in monad transformer stacks that have --- IO as their base. -natTracer :: forall m n s . (forall x . m x -> n x) -> Tracer m s -> Tracer n s -natTracer h (Tracer tr) = Tracer (Arrow.nat h tr) - --- | Trace strings to stdout. Output could be jumbled when this is used from --- multiple threads. Consider 'debugTracer' instead. -stdoutTracer :: Tracer IO String -stdoutTracer = emit putStrLn - --- | Trace strings using 'Debug.Trace.traceM'. This will use stderr. See --- documentation in "Debug.Trace" for more details. -debugTracer :: Applicative m => Tracer m String -debugTracer = emit traceM diff --git a/trace-dispatcher/src/Control/Tracer/Arrow.hs b/trace-dispatcher/src/Control/Tracer/Arrow.hs deleted file mode 100644 index 449a3982665..00000000000 --- a/trace-dispatcher/src/Control/Tracer/Arrow.hs +++ /dev/null @@ -1,95 +0,0 @@ -{-| -Module : Control.TracerA.Arrow -Copyright : (c) Alexander Vieth, 2019 -Licence : Apache-2.0 -Maintainer : aovieth@gmail.com --} - -{-# LANGUAGE GADTs #-} -{-# LANGUAGE RankNTypes #-} - -module Control.Tracer.Arrow - ( TracerA (..) - , runTracerA - , compute - , emit - , effect - , squelch - , nat - ) where - -import Prelude hiding (id, (.)) - -import Control.Arrow -import Control.Category - --- | Formal representation of a tracer arrow as a Kleisli arrow over some --- monad, but tagged so that we know whether it has any effects which will emit --- a trace. -data TracerA m a b where - -- | An emitting part, followed by a non-emitting part. - -- The non-emitting part is there so that later emitting parts can be - -- tacked-on later. - Emitting :: Kleisli m a x -> Kleisli m x b -> TracerA m a b - -- | No emitting. There may be side-effects, but they are assumed to be - -- benign and will be discarded by 'runTracerA'. - Squelching :: Kleisli m a b -> TracerA m a b - --- | The resulting Kleisli arrow includes all of the effects required to do --- the emitting part. -{-# INLINE runTracerA #-} -runTracerA :: Monad m => TracerA m a () -> Kleisli m a () -runTracerA (Emitting emits _noEmits) = emits >>> arr (const ()) -runTracerA (Squelching _ ) = arr (const ()) - --- | Ignore the input and do not emit. The name is intended to lead to clear --- and suggestive arrow expressions. -squelch :: Applicative m => TracerA m a () -squelch = compute (const ()) - --- | Do an emitting effect. Contrast with 'effect' which does not make the --- tracer an emitting tracer. -{-# INLINE emit #-} -emit :: Applicative m => (a -> m ()) -> TracerA m a () -emit f = Emitting (Kleisli f) (Kleisli (const (pure ()))) - --- | Do a non-emitting effect. This effect will only be run if some part of --- the tracer downstream emits (see 'emit'). -{-# INLINE effect #-} -effect :: (a -> m b) -> TracerA m a b -effect = Squelching . Kleisli - --- | Pure computation in a tracer: no side effects or emits. -{-# INLINE compute #-} -compute :: Applicative m => (a -> b) -> TracerA m a b -compute f = effect (pure . f) - -instance Monad m => Category (TracerA m) where - id = compute id - Squelching l . Squelching r = Squelching (l . r) - -- Crucial: the squelching parts stay together. Could also have written - -- = Emitting (rp . re) l - -- but that would miss opportunities to skip doing work. - Squelching l . Emitting re rp = Emitting re (l . rp) - -- Contrast with the above clause: here the emitting part comes _after_ the - -- squelching part, so the squelching part becomes part of the emitting part. - Emitting le lp . Squelching r = Emitting (le . r) lp - Emitting le lp . Emitting re rp = Emitting (le . rp . re) lp - -instance Monad m => Arrow (TracerA m) where - arr = compute - Squelching l *** Squelching r = Squelching (l *** r ) - Squelching l *** Emitting re rp = Emitting (second re) (l *** rp) - Emitting le lp *** Squelching r = Emitting (first le) (lp *** r ) - Emitting le lp *** Emitting re rp = Emitting (le *** re) (lp *** rp) - -instance Monad m => ArrowChoice (TracerA m) where - Squelching l +++ Squelching r = Squelching (l +++ r) - Squelching l +++ Emitting re rp = Emitting (id +++ re) (l +++ rp) - Emitting le lp +++ Squelching r = Emitting (le +++ id) (lp +++ r ) - Emitting le lp +++ Emitting re rp = Emitting (le +++ re) (lp +++ rp) - --- | Use a natural transformation to change the underlying monad. -nat :: (forall x . m x -> n x) -> TracerA m a b -> TracerA n a b -nat h (Squelching (Kleisli k)) = Squelching (Kleisli (h . k)) -nat h (Emitting (Kleisli k) (Kleisli l)) = Emitting (Kleisli (h . k)) (Kleisli (h . l)) diff --git a/trace-dispatcher/test/Cardano/Logging/Test/Config.hs b/trace-dispatcher/test/Cardano/Logging/Test/Config.hs deleted file mode 100644 index df7eb26528b..00000000000 --- a/trace-dispatcher/test/Cardano/Logging/Test/Config.hs +++ /dev/null @@ -1,86 +0,0 @@ -{-# OPTIONS_GHC -Wno-orphans #-} - -module Cardano.Logging.Test.Config ( - config1 - , config2 - , config3 - , config4 - ) where - -import Cardano.Logging - -import Data.Map.Strict (fromList) - -import Test.QuickCheck - - --- | different configurations for testing -config1 :: TraceConfig -config1 = emptyTraceConfig { - tcOptions = fromList - [([], - [ ConfSeverity (SeverityF (Just Debug)) - , ConfDetail DNormal - , ConfBackend [Stdout HumanFormatColoured, Forwarder, EKGBackend] - ]) - ] - } - -config2 :: TraceConfig -config2 = emptyTraceConfig { - tcOptions = fromList - [ ([], - [ ConfSeverity (SeverityF (Just Debug)) - , ConfDetail DNormal - , ConfBackend [Stdout HumanFormatColoured, Forwarder, EKGBackend] - ]) - , (["Test", "Message1"], - [ ConfSeverity (SeverityF (Just Info)) - , ConfDetail DNormal - , ConfBackend [Stdout HumanFormatColoured, EKGBackend] - ]) - , (["Test", "Message2"], - [ ConfSeverity (SeverityF (Just Error)) - , ConfDetail DMinimal - , ConfBackend [Forwarder, EKGBackend] - ]) - ] - } - - -config3 :: TraceConfig -config3 = emptyTraceConfig { - tcOptions = fromList - [ ([], - [ ConfSeverity (SeverityF (Just Debug)) - , ConfDetail DNormal - , ConfBackend [Stdout HumanFormatColoured, Forwarder, EKGBackend] - ]) - , (["Test", "Message1"], - [ ConfSeverity (SeverityF (Just Debug)) - , ConfDetail DNormal - , ConfBackend [Stdout HumanFormatColoured, EKGBackend] - , ConfLimiter 100 - ]) - , (["Test", "Message2"], - [ ConfSeverity (SeverityF (Just Error)) - , ConfDetail DMinimal - , ConfBackend [Forwarder, EKGBackend] - ]) - ] - } - --- | different configurations for testing -config4 :: TraceConfig -config4 = emptyTraceConfig { - tcOptions = fromList - [([], - [ ConfSeverity (SeverityF (Just Debug)) - , ConfDetail DNormal - , ConfBackend [EKGBackend] - ]) - ] - } - -instance Arbitrary TraceConfig where - arbitrary = elements [config1, config2] diff --git a/trace-dispatcher/test/Cardano/Logging/Test/Oracles.hs b/trace-dispatcher/test/Cardano/Logging/Test/Oracles.hs deleted file mode 100644 index db4de7844ad..00000000000 --- a/trace-dispatcher/test/Cardano/Logging/Test/Oracles.hs +++ /dev/null @@ -1,110 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Cardano.Logging.Test.Oracles ( - oracleMessages - , occurrences - ) where - -import Cardano.Logging -import Cardano.Logging.Test.Types - -import Data.Maybe (fromMaybe) -import qualified Data.Text as T -import Text.Read (readMaybe) - -import Test.QuickCheck - - --- | Checks for every message that it appears or does not appear at the right --- backend. Tests filtering and routing to backends -oracleMessages :: TraceConfig -> ScriptRes -> Property -oracleMessages conf ScriptRes {..} = - let Script msgs = srScript - in property $ all oracleMessage msgs - where - oracleMessage :: ScriptedMessage -> Bool - oracleMessage (ScriptedMessage _t msg) = - let ns = namespaceFor msg - filterSeverity = getSeverity conf (nsReplacePrefix ["Test"] ns) - backends = getBackends conf (nsReplacePrefix ["Test"] ns) - inStdout = hasStdoutBackend backends - && fromEnum (fromMaybe Error (severityFor ns Nothing)) >= fromEnum filterSeverity - isCorrectStdout = includedExactlyOnce msg srStdoutRes == inStdout - inForwarder = elem Forwarder backends - && fromEnum (fromMaybe Error (severityFor ns Nothing)) >= fromEnum filterSeverity{- -} - && privacyFor ns Nothing == Just Public - isCorrectForwarder = includedExactlyOnce msg srForwardRes == inForwarder - inEKG = elem EKGBackend backends - && not (null (asMetrics msg)) - isCorrectEKG = includedExactlyOnce msg srEkgRes == inEKG - res = isCorrectStdout && isCorrectForwarder && isCorrectEKG - in case traceMessage isCorrectStdout isCorrectForwarder isCorrectEKG msg of - Nothing -> res - Just str -> error (str ++ " " ++ show res) - traceMessage :: Bool -> Bool -> Bool -> Message -> Maybe String - traceMessage isCorrectStdout isCorrectForwarder isCorrectEKG msg - | not isCorrectStdout - = Just - ("stdoutTracer wrong filtering or routing for " - <> show msg <> " config " <> show conf) - | not isCorrectForwarder - = Just - ("forwardTracer wrong filtering or routing for " - <> show msg <> " config " <> show conf) - | not isCorrectEKG - = Just - ("ekgTracer wrong filtering or routing for " - <> show msg <> " config " <> show conf) - | otherwise = Nothing - - --- | Is the stdout backend included in this configuration -hasStdoutBackend :: [BackendConfig] -> Bool -hasStdoutBackend [] = False -hasStdoutBackend (Stdout _ : _) = True -hasStdoutBackend (_ : rest) = hasStdoutBackend rest - --- | Is this message in some form included in the formatted messages exactly once -includedExactlyOnce :: Message -> [FormattedMessage] -> Bool -includedExactlyOnce msg list = - let msgID = getMessageID msg - in case occurrences msgID list of - 1 -> True - 0 -> False - _ -> error $ "Multiple occurrences of message " <> show msgID - --- | How often does the message with this id appears in the list of --- formatted messages? -occurrences :: MessageID -> [FormattedMessage] -> Int -occurrences _mid [] = 0 -occurrences mid (fmsg : rest) = if isMessageWithId mid fmsg - then 1 + occurrences mid rest - else occurrences mid rest - --- | Returns true if the given message has this id, otherwise false -isMessageWithId :: MessageID -> FormattedMessage -> Bool -isMessageWithId mid (FormattedMetrics (IntM _ idm : _)) - = fromIntegral idm == mid -isMessageWithId _ (FormattedMetrics []) = False -isMessageWithId mid (FormattedHuman _ txt) = idInText mid txt -isMessageWithId mid (FormattedMachine txt) = idInText mid txt -isMessageWithId mid (FormattedForwarder to) = - case toHuman to of - Just txt -> idInText mid txt - Nothing -> idInText mid (toMachine to) - --- | Is this message id part of the text? -idInText :: MessageID -> T.Text -> Bool -idInText mid txt = - case extractId txt of - Nothing -> False - Just i -> i == mid - --- | Extract a messageID from a text. It is always found in the form '' -extractId :: T.Text -> Maybe Int -extractId txt = - let ntxt = T.takeWhile (/= '>') - (T.drop 1 - (T.dropWhile (/= '<') txt)) - in readMaybe (T.unpack ntxt) diff --git a/trace-dispatcher/test/Cardano/Logging/Test/Script.hs b/trace-dispatcher/test/Cardano/Logging/Test/Script.hs deleted file mode 100644 index 0545a1b3f1e..00000000000 --- a/trace-dispatcher/test/Cardano/Logging/Test/Script.hs +++ /dev/null @@ -1,359 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Cardano.Logging.Test.Script - ( - runScriptSimple - , runScriptMultithreaded - , runScriptMultithreadedWithReconfig - , runScriptMultithreadedWithConstantReconfig - ) where - -import Cardano.Logging -import Cardano.Logging.Test.Config () -import Cardano.Logging.Test.Tracer -import Cardano.Logging.Test.Types - -import Control.Concurrent (ThreadId, forkFinally, threadDelay) -import Control.Concurrent.MVar -import Control.Exception.Base (SomeException, throw) -import Control.Monad (liftM2, when) -import Data.IORef (newIORef, readIORef) -import Data.List (sort) -import Data.Maybe (mapMaybe) -import Data.Time.Clock.System - -import Test.QuickCheck - - --- | Run a script in a single thread and uses the oracle to test for correctness --- The duration of the test is given by time in seconds -runScriptSimple :: - Double - -> (TraceConfig -> ScriptRes -> Property) - -> Property -runScriptSimple time oracle = do - let generator :: Gen (Script, TraceConfig) = arbitrary - forAll generator (\ (Script msgs,conf) -> ioProperty $ do - stdoutTrRef <- newIORef [] - stdoutTracer' <- testTracer stdoutTrRef - forwardTrRef <- newIORef [] - forwardTracer' <- testTracer forwardTrRef - ekgTrRef <- newIORef [] - ekgTracer' <- testTracer ekgTrRef - tr <- mkCardanoTracer - stdoutTracer' - forwardTracer' - (Just ekgTracer') - ["Test"] - confState <- emptyConfigReflection - configureTracers confState conf [tr] - let sortedMsgs = sort msgs - let (msgsWithIds,_) = withMessageIds 0 sortedMsgs - let timedMessages = map (withTimeFactor time) msgsWithIds - playIt (Script timedMessages) tr 0.0 - r1 <- readIORef stdoutTrRef - r2 <- readIORef forwardTrRef - r3 <- readIORef ekgTrRef - let scriptResult = ScriptRes - (Script timedMessages) - (reverse r1) - (reverse r2) - (reverse r3) - -- trace ("stdoutTrRes " <> show (srStdoutRes scriptResult) - -- <> " forwardTrRes " <> show (srForwardRes scriptResult) - -- <> " ekgTrRes " <> show (srEkgRes scriptResult)) $ - pure $ oracle conf scriptResult) - - --- | Run three scripts in three threads in parallel --- and use the oracle to test for correctness. --- The duration of the test is given by time in seconds -runScriptMultithreaded :: - Double - -> (TraceConfig -> ScriptRes -> Property) - -> Property -runScriptMultithreaded time oracle = do - let generator :: Gen (Script, Script, Script, TraceConfig) = arbitrary - forAll generator (\ (Script msgs1, Script msgs2, Script msgs3, conf) - -> ioProperty $ do - stdoutTrRef <- newIORef [] - stdoutTracer' <- testTracer stdoutTrRef - forwardTrRef <- newIORef [] - forwardTracer' <- testTracer forwardTrRef - ekgTrRef <- newIORef [] - ekgTracer' <- testTracer ekgTrRef - tr <- mkCardanoTracer - stdoutTracer' - forwardTracer' - (Just ekgTracer') - ["Test"] - confState <- emptyConfigReflection - configureTracers confState conf [tr] - let sortedMsgs1 = sort msgs1 - (msgsWithIds1,_) = withMessageIds 0 sortedMsgs1 - timedMessages1 = map (withTimeFactor time) msgsWithIds1 - start1 = length timedMessages1 - sortedMsgs2 = sort msgs2 - (msgsWithIds2,_) = withMessageIds start1 sortedMsgs2 - timedMessages2 = map (withTimeFactor time) msgsWithIds2 - start2 = start1 + length timedMessages2 - sortedMsgs3 = sort msgs3 - (msgsWithIds3,_) = withMessageIds start2 sortedMsgs3 - timedMessages3 = map (withTimeFactor time) msgsWithIds3 - - children :: MVar [MVar (Either SomeException ())] <- newMVar [] - _ <- forkChild children (playIt (Script timedMessages1) tr 0.0) - - _ <- forkChild children (playIt (Script timedMessages2) tr 0.0) - - _ <- forkChild children (playIt (Script timedMessages3) tr 0.0) - res <- waitForChildren children [] - let resErr = mapMaybe - (\case - Right _ -> Nothing - Left err -> Just err) res - if not (null resErr) - then throw (head resErr) - else do - r1 <- readIORef stdoutTrRef - r2 <- readIORef forwardTrRef - r3 <- readIORef ekgTrRef - let timedMessages = timedMessages1 ++ timedMessages2 ++ timedMessages3 - scriptResult = ScriptRes - (Script timedMessages) - (reverse r1) - (reverse r2) - (reverse r3) - -- trace ("stdoutTrRes " <> show (srStdoutRes scriptResult) - -- <> " forwardTrRes " <> show (srForwardRes scriptResult) - -- <> " ekgTrRes " <> show (srEkgRes scriptResult)) $ - pure $ oracle conf scriptResult) - --- | Run three scripts in three threads in parallel --- and use the oracle to test for correctness. --- The duration of the test is given by time in seconds -runScriptMultithreadedWithReconfig :: - Double - -> (TraceConfig -> ScriptRes -> Property) - -> Property -runScriptMultithreadedWithReconfig time oracle = do - let generator :: Gen (Script, Script, Script, TraceConfig, TraceConfig) - = arbitrary - reconfigTimeGen = choose (0.0, time) - generator' = liftM2 (,) generator reconfigTimeGen - forAll generator' - (\ ((Script msgs1, Script msgs2, Script msgs3, conf, conf2), reconfigTime) -> - ioProperty $ do - stdoutTrRef <- newIORef [] - stdoutTracer' <- testTracer stdoutTrRef - forwardTrRef <- newIORef [] - forwardTracer' <- testTracer forwardTrRef - ekgTrRef <- newIORef [] - ekgTracer' <- testTracer ekgTrRef - tr <- mkCardanoTracer - stdoutTracer' - forwardTracer' - (Just ekgTracer') - ["Test"] - confState <- emptyConfigReflection - configureTracers confState conf [tr] - let sortedMsgs1 = sort msgs1 - (msgsWithIds1,_) = withMessageIds 0 sortedMsgs1 - timedMessages1 = map (withTimeFactor time) msgsWithIds1 - start1 = length timedMessages1 - sortedMsgs2 = sort msgs2 - (msgsWithIds2,_) = withMessageIds start1 sortedMsgs2 - timedMessages2 = map (withTimeFactor time) msgsWithIds2 - start2 = start1 + length timedMessages2 - sortedMsgs3 = sort msgs3 - (msgsWithIds3,_) = withMessageIds start2 sortedMsgs3 - timedMessages3 = map (withTimeFactor time) msgsWithIds3 - - children :: MVar [MVar (Either SomeException ())] <- newMVar [] - _ <- forkChild children (playIt (Script timedMessages1) tr 0.0) - _ <- forkChild children (playIt (Script timedMessages2) tr 0.0) - _ <- forkChild children (playIt (Script timedMessages3) tr 0.0) - _ <- forkChild children (playReconfigure confState reconfigTime conf2 tr) - - res <- waitForChildren children [] - let resErr = mapMaybe - (\case - Right _ -> Nothing - Left err -> Just err) res - if not (null resErr) - then throw (head resErr) - else do - r1 <- readIORef stdoutTrRef - r2 <- readIORef forwardTrRef - r3 <- readIORef ekgTrRef - let timedMessages = timedMessages1 ++ timedMessages2 ++ timedMessages3 - scriptResult = ScriptRes - (Script timedMessages) - (reverse r1) - (reverse r2) - (reverse r3) - -- trace ("stdoutTrRes " <> show (srStdoutRes scriptResult) - -- <> " forwardTrRes " <> show (srForwardRes scriptResult) - -- <> " ekgTrRes " <> show (srEkgRes scriptResult)) $ - pure $ oracle conf scriptResult) - --- | Run three scripts in three threads in parallel --- and use the oracle to test for correctness. --- The duration of the test is given by time in seconds -runScriptMultithreadedWithConstantReconfig :: - Double - -> (TraceConfig -> ScriptRes -> Property) - -> Property -runScriptMultithreadedWithConstantReconfig time oracle = do - let generator :: Gen (Script, Script, Script, TraceConfig, TraceConfig) - = arbitrary - forAll generator - (\ (Script msgs1, Script msgs2, Script msgs3, conf1, conf2) -> - ioProperty $ do - stdoutTrRef <- newIORef [] - stdoutTracer' <- testTracer stdoutTrRef - forwardTrRef <- newIORef [] - forwardTracer' <- testTracer forwardTrRef - ekgTrRef <- newIORef [] - ekgTracer' <- testTracer ekgTrRef - tr <- mkCardanoTracer - stdoutTracer' - forwardTracer' - (Just ekgTracer') - ["Test"] - confState <- emptyConfigReflection - configureTracers confState conf1 [tr] - let sortedMsgs1 = sort msgs1 - let (msgsWithIds1,_) = withMessageIds 0 sortedMsgs1 - let timedMessages1 = map (withTimeFactor time) msgsWithIds1 - let start1 = length timedMessages1 - let sortedMsgs2 = sort msgs2 - let (msgsWithIds2,_) = withMessageIds start1 sortedMsgs2 - let timedMessages2 = map (withTimeFactor time) msgsWithIds2 - let start2 = start1 + length timedMessages2 - let sortedMsgs3 = sort msgs3 - let (msgsWithIds3,_) = withMessageIds start2 sortedMsgs3 - let timedMessages3 = map (withTimeFactor time) msgsWithIds3 - - children :: MVar [MVar (Either SomeException ())] <- newMVar [] - _ <- forkChild children (playIt (Script timedMessages1) tr 0.0) - _ <- forkChild children (playIt (Script timedMessages2) tr 0.0) - _ <- forkChild children (playIt (Script timedMessages3) tr 0.0) - _ <- forkChild children (playReconfigureContinuously confState time conf1 conf2 tr) - - res <- waitForChildren children [] - let resErr = mapMaybe - (\case - Right _ -> Nothing - Left err -> Just err) res - if not (null resErr) - then throw (head resErr) - else do - r1 <- readIORef stdoutTrRef - r2 <- readIORef forwardTrRef - r3 <- readIORef ekgTrRef - let timedMessages = timedMessages1 ++ timedMessages2 ++ timedMessages3 - scriptResult = ScriptRes - (Script timedMessages) - (reverse r1) - (reverse r2) - (reverse r3) - -- trace ("stdoutTrRes " <> show (srStdoutRes scriptResult) - -- <> " forwardTrRes " <> show (srForwardRes scriptResult) - -- <> " ekgTrRes " <> show (srEkgRes scriptResult)) $ - pure $ oracle conf2 scriptResult) - - -forkChild :: MVar [MVar (Either SomeException ())] -> IO () -> IO ThreadId -forkChild children io = do - mvar <- newEmptyMVar - childs <- takeMVar children - putMVar children (mvar:childs) - forkFinally io (putMVar mvar) - -waitForChildren :: MVar [MVar (Either SomeException ())] - -> [Either SomeException ()] - -> IO [Either SomeException ()] -waitForChildren children accum = do - cs <- takeMVar children - case cs of - [] -> pure accum - m:ms -> do - putMVar children ms - res <- takeMVar m - waitForChildren children (res : accum) - --- | Plays a script in a single thread -playReconfigure :: ConfigReflection -> Double -> TraceConfig -> Trace IO Message -> IO () -playReconfigure confState time config tr = do - - threadDelay (round (time * 1000000)) - configureTracers confState config [tr] - -playReconfigureContinuously :: - ConfigReflection - -> Double - -> TraceConfig - -> TraceConfig - -> Trace IO Message - -> IO () -playReconfigureContinuously confState time config1 config2 tr = do - startTime <- systemTimeToSeconds <$> getSystemTime - go startTime 0 - where - go :: Double -> Int -> IO () - go startTime alt = do - timeNow <- systemTimeToSeconds <$> getSystemTime - if timeNow - startTime > time - then pure () - else if alt == 0 - then do - configureTracers confState config1 [tr] - go startTime 1 - else do - configureTracers confState config2 [tr] - go startTime 0 - - - systemTimeToSeconds :: SystemTime -> Double - systemTimeToSeconds MkSystemTime {..} = - fromIntegral systemSeconds + fromIntegral systemNanoseconds * 1.0E-9 - - --- | Play the current script in one thread --- The time is in milliseconds -playIt :: Script -> Trace IO Message -> Double -> IO () -playIt (Script []) _tr _d = pure () -playIt (Script (ScriptedMessage d1 m1 : rest)) tr d = do - when (d < d1) $ threadDelay (round ((d1 - d) * 1000000)) - -- this is in microseconds - traceWith tr m1 - playIt (Script rest) tr d1 - --- | Adds a message id to every message. --- MessageId gives the id to start with. --- Returns a tuple with the messages with ids and --- the successor of the last used messageId -withMessageIds :: MessageID -> [ScriptedMessage] -> ([ScriptedMessage], MessageID) -withMessageIds mid sMsgs = go mid sMsgs [] - where - go mid' [] acc = (reverse acc, mid') - go mid' (ScriptedMessage time msg : tl) acc = - go (mid' + 1) tl (ScriptedMessage time (setMessageID msg mid') : acc) - -withTimeFactor :: Double -> ScriptedMessage -> ScriptedMessage -withTimeFactor factor (ScriptedMessage time msg) = - ScriptedMessage (time * factor) msg - --- mergeResults :: [ScriptRes] -> ScriptRes --- mergeResults results = --- let script = Script $ --- concatMap --- (\r -> case srScript r of --- Script scriptedList -> scriptedList) results --- stdOutRes = concatMap srStdoutRes results --- forwardRes = concatMap srForwardRes results --- ekgRes = concatMap srEkgRes results --- in ScriptRes script stdOutRes forwardRes ekgRes diff --git a/trace-dispatcher/test/Cardano/Logging/Test/Tracer.hs b/trace-dispatcher/test/Cardano/Logging/Test/Tracer.hs deleted file mode 100644 index 541e50ac8ad..00000000000 --- a/trace-dispatcher/test/Cardano/Logging/Test/Tracer.hs +++ /dev/null @@ -1,81 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} - - -module Cardano.Logging.Test.Tracer ( - testTracer - , formattedMsgAsText - , testLoggingMessageEq - , testLoggingMessagesEq - ) where - -import Cardano.Logging -import Cardano.Logging.Types.TraceMessage - -import Control.Monad.IO.Class -import Data.Aeson (decodeStrict) -import Data.Function (on) -import Data.IORef -import Data.Text (Text, pack, unpack) -import Data.Text.Encoding (encodeUtf8) - - -testTracer :: MonadIO m - => IORef [FormattedMessage] - -> m (Trace m FormattedMessage) -testTracer ioRef = liftIO $ - pure $ Trace $ arrow $ emit output - where - output (LoggingContext{}, Right msg) = liftIO $ do - modifyIORef ioRef (msg :) - output (lc, c@(Left TCDocument {})) = - docIt - (Stdout MachineFormat) - (lc, c) - output (LoggingContext{}, _) = pure () - - -formattedMsgAsText :: FormattedMessage -> Text -formattedMsgAsText (FormattedHuman _ text) = text -formattedMsgAsText (FormattedMachine text) = text -formattedMsgAsText (FormattedMetrics metrics) = pack (show metrics) -formattedMsgAsText (FormattedForwarder traceObj) = toMachine traceObj -formattedMsgAsText (FormattedCBOR _) = error "FormattedMessage.FormattedCBOR currently has no Text representation" - -testLoggingMessageEq :: Text -> Text -> IO Bool -testLoggingMessageEq t1 t2 = - let lm1 = (decodeStrict . encodeUtf8) t1 :: Maybe TraceMessage - lm2 = (decodeStrict . encodeUtf8) t2 :: Maybe TraceMessage - in case (lm1, lm2) of - (Just parse1, Just parse2) -> - let - constraints = - [ (==) `on` tmsgNS - , (==) `on` tmsgData - , (==) `on` tmsgSev - ] - allConstraintsHold = all (\check -> check parse1 parse2) constraints - in if not allConstraintsHold - then do - putStrLn $ "Failed ns1: " ++ show (tmsgNS parse1) ++ " ns2: " ++ show (tmsgNS parse2) ++ - " / data1: " ++ show (tmsgData parse1) ++ " data2: " ++ show (tmsgData parse1) ++ - " / sev1: " ++ show (tmsgSev parse1) ++ " sev2: " ++ show (tmsgSev parse2) - pure False - else pure True - _ -> do - putStrLn $ "Failed t1:" ++ unpack t1 ++ " t2: " ++ unpack t2 ++ - " / lm1 " ++ show lm1 ++ " lm2 " ++ show lm2 - pure False - -testLoggingMessagesEq :: [Text] -> [Text] -> IO Bool -testLoggingMessagesEq [] [] = pure True -testLoggingMessagesEq (a : atl) (b : btl) = do - resl <- testLoggingMessageEq a b - if resl - then do - testLoggingMessagesEq atl btl - else do - putStrLn ("Failed a: " ++ unpack a ++ " b: " ++ unpack b) - pure False -testLoggingMessagesEq _ _ = do - putStrLn "number differs" - pure False diff --git a/trace-dispatcher/test/Cardano/Logging/Test/Types.hs b/trace-dispatcher/test/Cardano/Logging/Test/Types.hs deleted file mode 100644 index c2de40cd020..00000000000 --- a/trace-dispatcher/test/Cardano/Logging/Test/Types.hs +++ /dev/null @@ -1,146 +0,0 @@ -module Cardano.Logging.Test.Types ( - MessageID - , Message (..) - , ScriptedMessage (..) - , Script (..) - , ScriptRes (..) - , scriptLength - , emptyScriptRes - , getMessageID - , setMessageID - ) where - -import Cardano.Logging - -import Data.Aeson (Value (..), (.=)) -import Data.Text hiding (length) - -import Test.QuickCheck - -type MessageID = Int - -data Message = - Message1 MessageID Int - | Message2 MessageID Text - | Message3 MessageID Double - deriving (Eq, Ord, Show) - -getMessageID :: Message -> MessageID -getMessageID (Message1 mid _) = mid -getMessageID (Message2 mid _) = mid -getMessageID (Message3 mid _) = mid - -setMessageID :: Message -> MessageID -> Message -setMessageID (Message1 _ v) mid = Message1 mid v -setMessageID (Message2 _ v) mid = Message2 mid v -setMessageID (Message3 _ v) mid = Message3 mid v - -instance LogFormatting Message where - forMachine _dtal (Message1 mid i) = - mconcat [ "kind" .= String "Message1" - , "mid" .= ("<" <> showT mid <> ">") - , "workload" .= String (showT i) - ] - forMachine DMinimal (Message2 mid _s) = - mconcat [ "mid" .= ("<" <> showT mid <> ">") - , "kind" .= String "Message2" - ] - forMachine _dtal (Message2 mid s) = - mconcat [ "kind" .= String "Message2" - , "mid" .= String ("<" <> showT mid <> ">") - , "workload" .= String s - ] - forMachine _dtal (Message3 mid d) = - mconcat [ "kind" .= String "Message3" - , "mid" .= String ("<" <> showT mid <> ">") - , "workload" .= String (showT d) - ] - forHuman (Message1 mid i) = - "Message1 <" <> showT mid <> "> " <> showT i - forHuman (Message2 mid s) = - "Message2 <" <> showT mid <> "> " <> s - forHuman (Message3 mid d) = - "Message3 <" <> showT mid <> "> " <> showT d - asMetrics (Message1 mid _i) = - [ IntM "Metrics1" (fromIntegral mid) - , IntM "Metrics2" (fromIntegral mid) - , IntM "Metrics3" (fromIntegral mid) - , IntM "Metrics4" (fromIntegral mid) - , IntM "Metrics5" (fromIntegral mid)] - asMetrics _ = [] - -instance MetaTrace Message where - namespaceFor Message1 {} = Namespace [] ["Message1"] - namespaceFor Message2 {} = Namespace [] ["Message2"] - namespaceFor Message3 {} = Namespace [] ["Message3"] - - severityFor (Namespace _ ["Message1"]) _ = Just Debug - severityFor (Namespace _ ["Message2"]) _ = Just Info - severityFor (Namespace _ ["Message3"]) _ = Just Error - severityFor _ns _ = Nothing - - privacyFor (Namespace _ ["Message1"]) _ = Just Public - privacyFor (Namespace _ ["Message2"]) _ = Just Confidential - privacyFor (Namespace _ ["Message3"]) _ = Just Public - privacyFor _ns _ = Nothing - - documentFor (Namespace _ ["Message1"]) = Just "The first message." - documentFor (Namespace _ ["Message2"]) = Just "The second message." - documentFor (Namespace _ ["Message3"]) = Just "The third message." - documentFor _ns = Nothing - - metricsDocFor (Namespace _ ["Message1"]) = - [ ("Metrics1", "A number") - , ("Metrics2", "A number") - , ("Metrics3", "A number") - , ("Metrics4", "A number") - , ("Metrics5", "A number") - ] - metricsDocFor _ = [] - - allNamespaces = [ Namespace [] ["Message1"] - , Namespace [] ["Message2"] - , Namespace [] ["Message3"]] - -instance Arbitrary Message where - arbitrary = oneof - [ Message1 0 <$> arbitrary, - Message2 0 <$> elements ["Hallo", "Goodbye", "Whatelse"], - Message3 0 <$> arbitrary - ] - --- | Adds a time between 0 and 1. --- 0 is the time of the test start, and 1 the test end -data ScriptedMessage = ScriptedMessage Double Message - deriving (Eq, Show) - --- Ordered by time -instance Ord ScriptedMessage where - compare (ScriptedMessage d1 _m1) (ScriptedMessage d2 _m2) = compare d1 d2 - -instance Arbitrary ScriptedMessage where - arbitrary = ScriptedMessage <$> choose (0.0, 1.0) <*> arbitrary - -newtype Script = Script [ScriptedMessage] - deriving (Eq, Show) - -scriptLength :: Script -> Int -scriptLength (Script m) = length m - -instance Arbitrary Script where - arbitrary = Script <$> listOf arbitrary - -data ScriptRes = ScriptRes { - srScript :: Script - , srStdoutRes :: [FormattedMessage] - , srForwardRes :: [FormattedMessage] - , srEkgRes :: [FormattedMessage] - } - -emptyScriptRes :: ScriptRes -emptyScriptRes = ScriptRes { - srScript = Script [] - , srStdoutRes = [] - , srForwardRes = [] - , srEkgRes = [] -} diff --git a/trace-dispatcher/test/Cardano/Logging/Test/Unit/Aggregation.hs b/trace-dispatcher/test/Cardano/Logging/Test/Unit/Aggregation.hs deleted file mode 100644 index 218e8118c1e..00000000000 --- a/trace-dispatcher/test/Cardano/Logging/Test/Unit/Aggregation.hs +++ /dev/null @@ -1,87 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} - - -module Cardano.Logging.Test.Unit.Aggregation ( - testAggregation -, testAggResult -) where - -import Cardano.Logging -import Cardano.Logging.Test.Tracer - -import Data.Aeson (Value (..), (.=)) -import Data.IORef -import Data.Text (Text, pack) -import GHC.Generics (Generic) - -data BaseStats = BaseStats { - bsMeasure :: Double, - bsMin :: Double, - bsMax :: Double, - bsCount :: Int, - bsSum :: Double - } deriving (Eq, Ord, Show, Generic) - - -instance LogFormatting BaseStats where - forMachine _dtal BaseStats{..} = - mconcat - [ "kind" .= Data.Aeson.String "BaseStats" - , "bsMeasure" .= String (pack $ show bsMeasure) - , "bsMin" .= String (pack $ show bsMin) - , "bsMax" .= String (pack $ show bsMax) - , "bsCount" .= String (pack $ show bsCount) - , "bsSum" .= String (pack $ show bsSum) - ] - asMetrics BaseStats {..} = - [ DoubleM "measure" bsMeasure - , DoubleM "sum" bsSum] - -instance MetaTrace BaseStats where - namespaceFor BaseStats{} = Namespace [] ["BaseStats"] - severityFor (Namespace _ ["BaseStats"]) _ = Just Info - privacyFor (Namespace _ ["BaseStats"]) _ = Just Public - documentFor (Namespace _ ["BaseStats"]) = Just "Basic statistics" - metricsDocFor (Namespace _ ["BaseStats"]) = - [ ("measure", "This is the value of a single measurement") - , ("sum", "This is the sum of all measurements")] - allNamespaces = [Namespace [] ["BaseStats"]] - -emptyStats :: BaseStats -emptyStats = BaseStats 0.0 100000000.0 (-100000000.0) 0 0.0 - -calculate :: BaseStats -> LoggingContext -> Double -> IO BaseStats -calculate BaseStats{..} _ val = pure $ - BaseStats - val - (min bsMin val) - (max bsMax val) - (1 + bsCount) - (bsSum + val) - -testAggregation :: IO [Text] -testAggregation = do - testTracerRef <- newIORef [] - simpleTracer <- testTracer testTracerRef - formTracer <- machineFormatter simpleTracer - tracer <- foldTraceM calculate emptyStats (contramap unfold formTracer) - confState <- emptyConfigReflection - configureTracers confState emptyTraceConfig [formTracer] - - traceWith tracer 1.0 - traceWith tracer 2.0 - traceWith tracer 0.5 - - msgs <- reverse <$> readIORef testTracerRef - let res = map formattedMsgAsText msgs - pure res - -testAggResult :: [Text] -testAggResult = [ - "{\"at\":\"2023-11-23T15:55:01.255202499Z\",\"ns\":\"\",\"data\":{\"bsCount\":\"1\",\"bsMax\":\"1.0\",\"bsMeasure\":\"1.0\",\"bsMin\":\"1.0\",\"bsSum\":\"1.0\",\"kind\":\"BaseStats\"},\"sev\":\"Info\",\"thread\":\"1342\",\"host\":\"deusXmachina\"}" - ,"{\"at\":\"2023-11-23T15:55:01.255204601Z\",\"ns\":\"\",\"data\":{\"bsCount\":\"2\",\"bsMax\":\"2.0\",\"bsMeasure\":\"2.0\",\"bsMin\":\"1.0\",\"bsSum\":\"3.0\",\"kind\":\"BaseStats\"},\"sev\":\"Info\",\"thread\":\"1342\",\"host\":\"deusXmachina\"}" - ,"{\"at\":\"2023-11-23T15:55:01.25520585Z\",\"ns\":\"\",\"data\":{\"bsCount\":\"3\",\"bsMax\":\"2.0\",\"bsMeasure\":\"0.5\",\"bsMin\":\"0.5\",\"bsSum\":\"3.5\",\"kind\":\"BaseStats\"},\"sev\":\"Info\",\"thread\":\"1342\",\"host\":\"deusXmachina\"}" - ] diff --git a/trace-dispatcher/test/Cardano/Logging/Test/Unit/Configuration.hs b/trace-dispatcher/test/Cardano/Logging/Test/Unit/Configuration.hs deleted file mode 100644 index 70ec4ff47ea..00000000000 --- a/trace-dispatcher/test/Cardano/Logging/Test/Unit/Configuration.hs +++ /dev/null @@ -1,129 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} - -module Cardano.Logging.Test.Unit.Configuration ( - testConfig - , testConfigResult -) where - -import Cardano.Logging -import Cardano.Logging.Test.Tracer - -import Control.Monad.IO.Class -import qualified Data.Aeson as AE -import qualified Data.Aeson.KeyMap as KeyMap -import Data.IORef (IORef, newIORef, readIORef) -import qualified Data.Map.Strict as Map -import Data.Text (Text) - -newtype TestMessage = TestMessage Text - deriving Show - -instance LogFormatting TestMessage where - forHuman (TestMessage text) = text - forMachine _verb (TestMessage text) = - KeyMap.fromList - [ "kind" AE..= AE.String "TestMessage" - , "text" AE..= AE.String text - ] - -instance MetaTrace TestMessage where - namespaceFor (TestMessage _text) = Namespace [] ["TestMessage"] - severityFor (Namespace _ ["TestMessage"]) _ = Just Info - privacyFor (Namespace _ ["TestMessage"]) _ = Just Public - documentFor (Namespace _ ["TestMessage"]) = Just "Just a test" - metricsDocFor (Namespace _ ["TestMessage"]) = [] - allNamespaces = [Namespace [] ["TestMessage"]] - -tracers :: MonadIO m => IORef [FormattedMessage] -> m (Trace m TestMessage, Trace m TestMessage, Trace m TestMessage) -tracers testTracerRef = do - t <- testTracer testTracerRef - t0 <- machineFormatter t - t1 <- withInnerNames . appendPrefixName "tracer1" <$> filterSeverityFromConfig t0 - t2 <- withInnerNames . appendPrefixName "tracer2" <$> filterSeverityFromConfig t0 - t3 <- withInnerNames . appendPrefixName "tracer3" <$> filterSeverityFromConfig t0 - pure (t1, t2, t3) - -config1 :: TraceConfig -config1 = TraceConfig { - tcOptions = Map.fromList - [ ([], [ConfSeverity (SeverityF Nothing)]) - , (["tracer1","TestMessage"], [ConfSeverity (SeverityF (Just Error))]) - , (["tracer2","TestMessage"], [ConfSeverity (SeverityF (Just Critical))]) - , (["tracer3","TestMessage"], [ConfSeverity (SeverityF (Just Info))]) - ] - , tcForwarder = Just TraceOptionForwarder { - tofQueueSize = 1000 - , tofVerbosity = Minimum - , tofMaxReconnectDelay = 60 - } - , tcNodeName = Nothing - , tcResourceFrequency = Nothing - , tcMetricsPrefix = Nothing - , tcLedgerMetricsFrequency = Nothing - } - -config2 :: TraceConfig -config2 = TraceConfig { - tcOptions = Map.fromList - [ ([], [ConfSeverity (SeverityF (Just Info))]) - , (["tracer2","TestMessage"], [ConfSeverity (SeverityF (Just Warning))]) - , (["tracer3","TestMessage"], [ConfSeverity (SeverityF (Just Warning))]) - ] - , tcForwarder = Just TraceOptionForwarder { - tofQueueSize = 1000 - , tofVerbosity = Minimum - , tofMaxReconnectDelay = 60 - } - , tcNodeName = Just "node-1" - , tcResourceFrequency = Nothing - , tcMetricsPrefix = Nothing - , tcLedgerMetricsFrequency = Nothing - } - -testConfig' :: - TraceConfig - -> Trace IO TestMessage - -> Trace IO TestMessage - -> Trace IO TestMessage - -> IO () -testConfig' tc t1 t2 t3 = do - confState <- emptyConfigReflection - configureTracers confState tc [t1, t2, t3] - traceWith (setSeverity Critical t1) (TestMessage "Now setting config") - traceWith - (setSeverity Error t1) - (TestMessage "1: show with config1 and config2") - traceWith - (setSeverity Info t1) - (TestMessage "2: show not with config1 but with config2") - traceWith - (setSeverity Notice t3) - (TestMessage "3: show with config1 but not with config2") - traceWith - (setSeverity Warning t2) - (TestMessage "4: show not with config1 but with config2") - traceWith - (setSeverity Info t2) - (TestMessage "5: never show") - -testConfig :: IO [Text] -testConfig = do - testTracerRef <- newIORef [] - (t1, t2, t3) <- tracers testTracerRef - testConfig' config1 t1 t2 t3 - testConfig' config2 t1 t2 t3 - msgs <- reverse <$> readIORef testTracerRef - let res = map formattedMsgAsText msgs - -- print res - pure res - -testConfigResult :: [Text] -testConfigResult = [ - "{\"at\":\"2023-11-27T20:58:43.900681509Z\",\"ns\":\"tracer1.TestMessage\",\"data\":{\"kind\":\"TestMessage\",\"text\":\"Now setting config\"},\"sev\":\"Critical\",\"thread\":\"501\",\"host\":\"deusXmachina\"}" - ,"{\"at\":\"2023-11-27T20:58:43.900689522Z\",\"ns\":\"tracer1.TestMessage\",\"data\":{\"kind\":\"TestMessage\",\"text\":\"1: show with config1 and config2\"},\"sev\":\"Error\",\"thread\":\"501\",\"host\":\"deusXmachina\"}" - ,"{\"at\":\"2023-11-27T20:58:43.900697892Z\",\"ns\":\"tracer3.TestMessage\",\"data\":{\"kind\":\"TestMessage\",\"text\":\"3: show with config1 but not with config2\"},\"sev\":\"Notice\",\"thread\":\"501\",\"host\":\"deusXmachina\"}" - ,"{\"at\":\"2023-11-27T20:58:43.900763175Z\",\"ns\":\"tracer1.TestMessage\",\"data\":{\"kind\":\"TestMessage\",\"text\":\"Now setting config\"},\"sev\":\"Critical\",\"thread\":\"501\",\"host\":\"deusXmachina\"}" - ,"{\"at\":\"2023-11-27T20:58:43.900769378Z\",\"ns\":\"tracer1.TestMessage\",\"data\":{\"kind\":\"TestMessage\",\"text\":\"1: show with config1 and config2\"},\"sev\":\"Error\",\"thread\":\"501\",\"host\":\"deusXmachina\"}" - ,"{\"at\":\"2023-11-27T20:58:43.900773848Z\",\"ns\":\"tracer1.TestMessage\",\"data\":{\"kind\":\"TestMessage\",\"text\":\"2: show not with config1 but with config2\"},\"sev\":\"Info\",\"thread\":\"501\",\"host\":\"deusXmachina\"}" - ,"{\"at\":\"2023-11-27T20:58:43.900781456Z\",\"ns\":\"tracer2.TestMessage\",\"data\":{\"kind\":\"TestMessage\",\"text\":\"4: show not with config1 but with config2\"},\"sev\":\"Warning\",\"thread\":\"501\",\"host\":\"deusXmachina\"}" - ] diff --git a/trace-dispatcher/test/Cardano/Logging/Test/Unit/DataPoint.hs b/trace-dispatcher/test/Cardano/Logging/Test/Unit/DataPoint.hs deleted file mode 100644 index 1663ee367d5..00000000000 --- a/trace-dispatcher/test/Cardano/Logging/Test/Unit/DataPoint.hs +++ /dev/null @@ -1,62 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} - -{-# OPTIONS_GHC -Wno-orphans #-} - -module Cardano.Logging.Test.Unit.DataPoint ( - testDataPoint - , testDataPointResult -) where - -import Cardano.Logging - -import Control.DeepSeq (NFData) -import qualified Data.Aeson as A -import Data.ByteString.Lazy.UTF8 -import qualified Data.Map.Strict as M -import GHC.Conc -import GHC.Generics (Generic) - - -data BaseStats = BaseStats { - bsMeasure :: Double, - bsMin :: Double, - bsMax :: Double, - bsCount :: Int, - bsSum :: Double - } deriving (Eq, Ord, Show, Generic) - -deriving instance (NFData BaseStats) - -instance MetaTrace BaseStats where - namespaceFor BaseStats{} = Namespace [] ["BaseStats"] - severityFor (Namespace _ ["BaseStats"]) _ = Just Info - privacyFor (Namespace _ ["BaseStats"]) _ = Just Public - documentFor (Namespace _ ["BaseStats"]) = Just "Basic statistics" - metricsDocFor (Namespace _ ["BaseStats"]) = - [ ("measure", "This is the value of a single measurement") - , ("sum", "This is the sum of all measurements")] - allNamespaces = [Namespace [] ["BaseStats"]] - -instance A.ToJSON BaseStats where - toEncoding = A.genericToEncoding A.defaultOptions - -instance Show DataPoint where - show (DataPoint a) = toString $ A.encode a - -emptyStats :: BaseStats -emptyStats = BaseStats 0.0 100000000.0 (-100000000.0) 0 0.0 - -testDataPoint :: IO (M.Map DataPointName DataPoint) -testDataPoint = do - dpMap <- newTVarIO M.empty - let rawDataPointTracer = dataPointTracer dpMap - dpTracer <- mkDataPointTracer rawDataPointTracer - traceWith dpTracer emptyStats - readTVarIO dpMap - -testDataPointResult :: String -testDataPointResult = "fromList [(\"BaseStats\",{\"bsMeasure\":0.0,\"bsMin\":1.0e8,\"bsMax\":-1.0e8,\"bsCount\":0,\"bsSum\":0.0})]" diff --git a/trace-dispatcher/test/Cardano/Logging/Test/Unit/Documentation.hs b/trace-dispatcher/test/Cardano/Logging/Test/Unit/Documentation.hs deleted file mode 100644 index f2e97d83df0..00000000000 --- a/trace-dispatcher/test/Cardano/Logging/Test/Unit/Documentation.hs +++ /dev/null @@ -1,47 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} - - - -module Cardano.Logging.Test.Unit.Documentation ( - docTracers -) where - -import Cardano.Logging -import Cardano.Logging.Test.Tracer -import Cardano.Logging.Test.Unit.TestObjects - -import Data.IORef -import qualified Data.Map as Map -import qualified Data.Text as T - -docTracers :: IO T.Text -docTracers = do - testTracerRef <- newIORef [] - tt <- testTracer testTracerRef - t1 <- mkCardanoTracer tt tt Nothing ["Node1"] - t2 <- mkCardanoTracer tt tt Nothing ["Node2"] - confState <- emptyConfigReflection - configureTracers confState config1 [t1, t2] - b1 <- documentTracer (t1 :: Trace IO (TraceForgeEvent LogBlock)) - b2 <- documentTracer (t2 :: Trace IO (TraceForgeEvent LogBlock)) - pure (docuResultsToText (b1 <> b2) config1) - -config1 :: TraceConfig -config1 = TraceConfig { - tcOptions = Map.fromList - [ ([], [ConfSeverity (SeverityF Nothing), ConfBackend [Stdout MachineFormat]]) - , (["node2"], [ConfSeverity (SeverityF (Just Info)), ConfBackend [Stdout MachineFormat]]) - , (["node1"], [ConfSeverity (SeverityF (Just Warning)), ConfBackend [Stdout MachineFormat]]) - ] - , tcForwarder = Just TraceOptionForwarder { - tofQueueSize = 1000 - , tofVerbosity = Minimum - , tofMaxReconnectDelay = 60 - } - , tcNodeName = Nothing - , tcResourceFrequency = Nothing - , tcMetricsPrefix = Just "cardano" - , tcLedgerMetricsFrequency = Nothing - } - diff --git a/trace-dispatcher/test/Cardano/Logging/Test/Unit/EKG.hs b/trace-dispatcher/test/Cardano/Logging/Test/Unit/EKG.hs deleted file mode 100644 index c96a9c2f482..00000000000 --- a/trace-dispatcher/test/Cardano/Logging/Test/Unit/EKG.hs +++ /dev/null @@ -1,51 +0,0 @@ -{-# OPTIONS_GHC -Wno-orphans #-} - -module Cardano.Logging.Test.Unit.EKG ( - testEKG -) where - -import Cardano.Logging - -import Control.Concurrent -import qualified Data.Aeson as AE -import Data.Text (pack) -import System.Metrics (newStore) - - -newtype Measure = Measure Int - -instance LogFormatting Measure where - forMachine _dtal (Measure count) = - mconcat - [ "count" AE..= AE.String (pack $ show count) - ] - asMetrics (Measure count) = - [ DoubleM "measure" (fromIntegral count)] - -instance MetaTrace Measure where - namespaceFor (Measure _count) = Namespace [] ["Count"] - severityFor (Namespace [] ["Count"]) _ = Just Info - privacyFor (Namespace [] ["Count"]) _ = Just Public - documentFor (Namespace [] ["Count"]) = Just "A counter" - metricsDocFor (Namespace [] ["Count"]) = - [("count", "an integer")] - allNamespaces = [Namespace [] ["Count"]] - - -testEKG :: IO Int -testEKG = do - store <- newStore - tracer <- ekgTracer emptyTraceConfig store - let formattedTracer = metricsFormatter tracer - confState <- emptyConfigReflection - configureTracers confState emptyTraceConfig [formattedTracer] - loop (appendPrefixName "ekg1" formattedTracer) 1 - where - loop :: Trace IO Measure -> Int -> IO Int - loop tr count = do - if count == 1000 - then pure 1000 - else do - traceWith tr (Measure count) - threadDelay 1000 - loop tr (count + 1) diff --git a/trace-dispatcher/test/Cardano/Logging/Test/Unit/FrequencyLimiting.hs b/trace-dispatcher/test/Cardano/Logging/Test/Unit/FrequencyLimiting.hs deleted file mode 100644 index f682d1dbbb9..00000000000 --- a/trace-dispatcher/test/Cardano/Logging/Test/Unit/FrequencyLimiting.hs +++ /dev/null @@ -1,43 +0,0 @@ -module Cardano.Logging.Test.Unit.FrequencyLimiting ( - testLimiting - , testLimitingResult -) where - -import Cardano.Logging -import Cardano.Logging.Test.Tracer -import Cardano.Logging.Test.Unit.TestObjects - -import Control.Concurrent -import Data.IORef -import Data.Text (Text) - -repeated :: Trace IO (TraceForgeEvent LogBlock) -> Int -> Int -> IO () -repeated _ 0 _ = pure () -repeated t n d = do - traceWith t (TraceStartLeadershipCheck (SlotNo (fromIntegral n))) - threadDelay d - repeated t (n-1) d - -testLimiting :: IO [Text] -testLimiting = do - testTracerRef <- newIORef [] - simpleTracer <- testTracer testTracerRef - tf <- machineFormatter simpleTracer - tflimit <- machineFormatter simpleTracer - tf2 <- limitFrequency 5 "5 messages per second" tflimit tf - tf3 <- limitFrequency 15 "15 messages per second" tflimit tf - confState <- emptyConfigReflection - configureTracers confState emptyTraceConfig [tflimit] - configureTracers confState emptyTraceConfig [tf2, tf3] - let tr = tf2 <> tf3 - - repeated tr 1000 1000 -- 1000 messages per second - repeated tr 20 100000 -- 10 message per second - repeated tr 300 10000 -- 100 message per second - - msgs <- reverse <$> readIORef testTracerRef - let res = map formattedMsgAsText msgs - pure res - -testLimitingResult :: [Text] -testLimitingResult = [] diff --git a/trace-dispatcher/test/Cardano/Logging/Test/Unit/Routing.hs b/trace-dispatcher/test/Cardano/Logging/Test/Unit/Routing.hs deleted file mode 100644 index 1af85f3bc92..00000000000 --- a/trace-dispatcher/test/Cardano/Logging/Test/Unit/Routing.hs +++ /dev/null @@ -1,56 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - -module Cardano.Logging.Test.Unit.Routing ( - testRouting -, testRoutingResult -) where - -import Cardano.Logging -import Cardano.Logging.Test.Tracer -import Cardano.Logging.Test.Unit.TestObjects - -import Data.IORef -import Data.Text (Text) - - -routingTracer1 :: (Monad m) - => Trace m (TraceForgeEvent LogBlock) - -> Trace m (TraceForgeEvent LogBlock) - -> Trace m (TraceForgeEvent LogBlock) -routingTracer1 t1 t2 = routingTrace routingf (t1 <> t2) - where - routingf TraceStartLeadershipCheck {} = pure t1 - routingf _ = pure t2 - -routingTracer2 :: (Monad m) - => Trace m (TraceForgeEvent LogBlock) - -> Trace m (TraceForgeEvent LogBlock) - -> Trace m (TraceForgeEvent LogBlock) -routingTracer2 t1 t2 = t1 <> t2 - -testRouting :: IO [Text] -testRouting = do - testTracerRef <- newIORef [] - simpleTracer <- testTracer testTracerRef - tf <- machineFormatter simpleTracer - let t1 = appendPrefixName "tracer1" tf - let t2 = appendPrefixName "tracer2" tf - confState <- emptyConfigReflection - configureTracers confState emptyTraceConfig [t1, t2] - let r1 = routingTracer1 t1 t2 - r2 = routingTracer2 t1 t2 - traceWith r1 message1 - traceWith r1 message2 - traceWith r2 message3 - - msgs <- reverse <$> readIORef testTracerRef - let res = map formattedMsgAsText msgs - pure res - -testRoutingResult :: [Text] -testRoutingResult = [ - "{\"at\":\"2023-11-23T16:03:38.710828111Z\",\"ns\":\"tracer1\",\"data\":{\"kind\":\"TraceStartLeadershipCheck\",\"slot\":1001},\"sev\":\"Info\",\"thread\":\"1484\",\"host\":\"deusXmachina\"}" - ,"{\"at\":\"2023-11-23T16:03:38.710830144Z\",\"ns\":\"tracer2\",\"data\":{\"kind\":\"TraceSlotIsImmutable\",\"slot\":3333,\"tip\":\"Origin\",\"tipBlockNo\":1},\"sev\":\"Info\",\"thread\":\"1484\",\"host\":\"deusXmachina\"}" - ,"{\"at\":\"2023-11-23T16:03:38.710834117Z\",\"ns\":\"tracer1\",\"data\":{\"current slot\":4400,\"kind\":\"TraceBlockFromFuture\",\"tip\":300},\"sev\":\"Info\",\"thread\":\"1484\",\"host\":\"deusXmachina\"}" - ,"{\"at\":\"2023-11-23T16:03:38.710835429Z\",\"ns\":\"tracer2\",\"data\":{\"current slot\":4400,\"kind\":\"TraceBlockFromFuture\",\"tip\":300},\"sev\":\"Info\",\"thread\":\"1484\",\"host\":\"deusXmachina\"}" - ] diff --git a/trace-dispatcher/test/Cardano/Logging/Test/Unit/TestObjects.hs b/trace-dispatcher/test/Cardano/Logging/Test/Unit/TestObjects.hs deleted file mode 100644 index e97c907b20f..00000000000 --- a/trace-dispatcher/test/Cardano/Logging/Test/Unit/TestObjects.hs +++ /dev/null @@ -1,213 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeFamilies #-} - -module Cardano.Logging.Test.Unit.TestObjects ( - - TraceForgeEvent(..) - , LogBlock(..) - , SlotNo(..) - , message1 - , message2 - , message3 - , message4 -) where - -import Cardano.Logging - -import qualified Data.Aeson as AE -import qualified Data.Aeson.KeyMap as KeyMap -import Data.Kind (Type) -import Data.Text (pack) -import Data.Word (Word64) -import GHC.Generics -import Text.Printf (printf) - -newtype SlotNo = SlotNo {unSlotNo :: Word64} - deriving (Eq, Ord, Show, Generic) - -instance AE.ToJSON SlotNo where - toEncoding = AE.genericToEncoding AE.defaultOptions - -newtype Point block = Point - { getPoint :: WithOrigin (Block SlotNo (HeaderHash block)) - } - deriving (Generic) - - -instance AE.ToJSON (Point LogBlock) where - toEncoding = AE.genericToEncoding AE.defaultOptions - -class ( Eq (HeaderHash b) - , Ord (HeaderHash b) - , Show (HeaderHash b) - ) => StandardHash b - -deriving newtype instance StandardHash block => Eq (Point block) -deriving newtype instance StandardHash block => Ord (Point block) -deriving newtype instance StandardHash block => Show (Point block) - -data Block slot hash = Block - { blockPointSlot :: !slot - , blockPointHash :: !hash - } - deriving (Eq, Ord, Show, Generic) - -instance (AE.ToJSON h, AE.ToJSON s) => AE.ToJSON (Block s h) where - toEncoding = AE.genericToEncoding AE.defaultOptions - -data WithOrigin t = Origin | At !t - deriving - ( Eq, - Ord, - Show, - Generic - ) - -instance AE.ToJSON a => AE.ToJSON (WithOrigin a) where - toEncoding = AE.genericToEncoding AE.defaultOptions - -newtype BlockNo = BlockNo {unBlockNo :: Word64} - deriving stock (Eq, Ord, Generic, Show) - deriving newtype (Enum, Bounded, Num) - -instance AE.ToJSON BlockNo where - toEncoding = AE.genericToEncoding AE.defaultOptions - -data LogBlock = LogBlock - deriving(Eq, Ord, Show, StandardHash) - -type family HeaderHash b :: Type - -type instance HeaderHash LogBlock = LogHash - -newtype LogHash = LogHash { unLogHash :: Word64 } - deriving (Eq, Ord, Show, Generic) - -instance AE.ToJSON LogHash where - toEncoding = AE.genericToEncoding AE.defaultOptions - --- The actual test trace messages -data TraceForgeEvent blk - = TraceStartLeadershipCheck SlotNo - | TraceSlotIsImmutable SlotNo (Point blk) BlockNo - | TraceBlockFromFuture SlotNo SlotNo - deriving (Eq, Show, Generic) - -instance MetaTrace (TraceForgeEvent blk) where - namespaceFor TraceStartLeadershipCheck {} = Namespace [] ["StartLeadershipCheck"] - namespaceFor TraceSlotIsImmutable {} = Namespace [] ["SlotIsImmutable"] - namespaceFor TraceBlockFromFuture {} = Namespace [] ["BlockFromFuture"] - - severityFor (Namespace _ ["StartLeadershipCheck"]) _ = Just Info - severityFor (Namespace _ ["SlotIsImmutable"]) _ = Just Error - severityFor (Namespace _ ["BlockFromFuture"]) _ = Just Error - severityFor _ns _ = Nothing - - documentFor (Namespace _ ["StartLeadershipCheck"]) = Just - "Start of the leadership check\n\ - \\n\ - \We record the current slot number." - documentFor (Namespace _ ["SlotIsImmutable"]) = Just $ mconcat - [ "Leadership check failed: the tip of the ImmutableDB inhabits the\n" - , "current slot\n" - , "\n" - , "This might happen in two cases.\n" - , "\n" - , "1. the clock moved backwards, on restart we ignored everything from the\n" - , " VolatileDB since it's all in the future, and now the tip of the\n" - , " ImmutableDB points to a block produced in the same slot we're trying\n" - , " to produce a block in\n" - , "\n" - , "2. k = 0 and we already adopted a block from another leader of the same\n" - , " slot.\n" - , "\n" - , "We record both the current slot number as well as the tip of the\n" - , "ImmutableDB.\n" - , "\n" - , "See also " - ] - documentFor (Namespace _ ["BlockFromFuture"]) = Just $ mconcat - [ "Leadership check failed: the current chain contains a block from a slot\n" - , "/after/ the current slot\n" - , "\n" - , "This can only happen if the system is under heavy load.\n" - , "\n" - , "We record both the current slot number as well as the slot number of the\n" - , "block at the tip of the chain.\n" - , "\n" - , "See also " - ] - documentFor _ns = Nothing - - metricsDocFor (Namespace _ _) = [] - - allNamespaces = [ Namespace [] ["StartLeadershipCheck"] - , Namespace [] ["SlotIsImmutable"] - , Namespace [] ["BlockFromFuture"]] - -instance LogFormatting (TraceForgeEvent LogBlock) where - forHuman (TraceStartLeadershipCheck slotNo) = pack $ - printf - "Checking for leadership in slot %u" - (unSlotNo slotNo) - forHuman (TraceSlotIsImmutable slotNo immutableTipPoint immutableTipBlkNo) = pack $ - printf - ( mconcat - [ "Couldn't forge block because slot %u is immutable. " - , " Immutable tip: %s, immutable tip block no: %i." - ] - ) - (unSlotNo slotNo) - (show immutableTipPoint) - (unBlockNo immutableTipBlkNo) - forHuman (TraceBlockFromFuture currentSlot tipSlot) = pack $ - printf - "Couldn't forge block because tip %u of slot %u is in the future." - (unSlotNo tipSlot) - (unSlotNo currentSlot) - - forMachine _verb (TraceStartLeadershipCheck slotNo) = - KeyMap.fromList - [ "kind" AE..= AE.String "TraceStartLeadershipCheck" - , "slot" AE..= AE.toJSON (unSlotNo slotNo) - ] - forMachine _verb (TraceSlotIsImmutable slotNo tipPoint tipBlkNo) = - KeyMap.fromList - [ "kind" AE..= AE.String "TraceSlotIsImmutable" - , "slot" AE..= AE.toJSON (unSlotNo slotNo) - , "tip" AE..= showT tipPoint - , "tipBlockNo" AE..= AE.toJSON (unBlockNo tipBlkNo) - ] - forMachine _verb (TraceBlockFromFuture currentSlot tip) = - KeyMap.fromList - [ "kind" AE..= AE.String "TraceBlockFromFuture" - , "current slot" AE..= AE.toJSON (unSlotNo currentSlot) - , "tip" AE..= AE.toJSON (unSlotNo tip) - ] - - asMetrics (TraceStartLeadershipCheck slotNo) = - [IntM "cardano.node.aboutToLeadSlotLast" (fromIntegral $ unSlotNo slotNo)] - asMetrics (TraceSlotIsImmutable slot _tipPoint _tipBlkNo) = - [IntM "cardano.node.slotIsImmutable" (fromIntegral $ unSlotNo slot)] - asMetrics (TraceBlockFromFuture slot _slotNo) = - [IntM "cardano.node.blockFromFuture" (fromIntegral $ unSlotNo slot)] - - - -message1 :: TraceForgeEvent LogBlock -message1 = TraceStartLeadershipCheck (SlotNo 1001) - -message2 :: TraceForgeEvent LogBlock -message2 = TraceSlotIsImmutable (SlotNo 3333) (Point Origin) (BlockNo 1) - -message3 :: TraceForgeEvent LogBlock -message3 = TraceBlockFromFuture (SlotNo 4400) (SlotNo 300) - -message4 :: TraceForgeEvent LogBlock -message4 = TraceStartLeadershipCheck (SlotNo 2002) diff --git a/trace-dispatcher/test/Cardano/Logging/Test/Unit/Trivial.hs b/trace-dispatcher/test/Cardano/Logging/Test/Unit/Trivial.hs deleted file mode 100644 index a981f0bd2ca..00000000000 --- a/trace-dispatcher/test/Cardano/Logging/Test/Unit/Trivial.hs +++ /dev/null @@ -1,81 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -module Cardano.Logging.Test.Unit.Trivial ( - test1 - , test1Res - , test2 - , test2Res -) where - - -import Cardano.Logging -import Cardano.Logging.Test.Tracer -import Cardano.Logging.Test.Unit.TestObjects - -import Data.IORef -import Data.Text (Text) - - --- | Make sure the function append name is only called once --- for every path element -test1 :: IO [Text] -test1 = do - testTracerRef <- newIORef [] - testTracer' <- testTracer testTracerRef - simpleTracer <- machineFormatter testTracer' - confState <- emptyConfigReflection - configureTracers confState emptyTraceConfig [simpleTracer] - let simpleTracer1 = filterTraceBySeverity - (Just (SeverityF (Just Warning))) - simpleTracer - let simpleTracerC1 = appendInnerName "Outer1" simpleTracer1 - let simpleTracerC2 = appendInnerName "Inner1" simpleTracerC1 - let simpleTracerC3 = setSeverity Error - $ setPrivacy Confidential - $ appendInnerName "Inner2" simpleTracerC1 - traceWith (setSeverity Error simpleTracerC2) message1 - traceWith (setSeverity Warning simpleTracerC3) message2 - traceWith simpleTracerC2 message3 - traceWith (setSeverity Critical (appendInnerName "Inner3" simpleTracerC3)) message4 - msgs <- reverse <$> readIORef testTracerRef - let res = map formattedMsgAsText msgs --- print res - pure res - -test1Res :: [Text] -test1Res = [ - "{\"at\":\"2023-11-28T13:35:37.465134879Z\",\"ns\":\"Outer1.Inner1\",\"data\":{\"kind\":\"TraceStartLeadershipCheck\",\"slot\":1001},\"sev\":\"Error\",\"thread\":\"3\",\"host\":\"deusXmachina\"}" - ,"{\"at\":\"2023-11-28T13:35:37.465138573Z\",\"ns\":\"Outer1.Inner2\",\"data\":{\"kind\":\"TraceSlotIsImmutable\",\"slot\":3333,\"tip\":\"Origin\",\"tipBlockNo\":1},\"sev\":\"Warning\",\"thread\":\"3\",\"host\":\"deusXmachina\"}" - ,"{\"at\":\"2023-11-28T13:35:37.465139932Z\",\"ns\":\"Outer1.Inner1\",\"data\":{\"current slot\":4400,\"kind\":\"TraceBlockFromFuture\",\"tip\":300},\"sev\":\"Info\",\"thread\":\"3\",\"host\":\"deusXmachina\"}" - ,"{\"at\":\"2023-11-28T13:35:37.465140622Z\",\"ns\":\"Outer1.Inner2.Inner3\",\"data\":{\"kind\":\"TraceStartLeadershipCheck\",\"slot\":2002},\"sev\":\"Critical\",\"thread\":\"3\",\"host\":\"deusXmachina\"}" - ] - -test2 :: IO [Text] -test2 = do - stdoutTracerRef <- newIORef [] - stdoutTracer' <- testTracer stdoutTracerRef - simpleTracer <- machineFormatter stdoutTracer' - confState <- emptyConfigReflection - configureTracers confState emptyTraceConfig [simpleTracer] - let simpleTracer1 = filterTraceBySeverity - (Just (SeverityF (Just Warning))) - (withSeverity simpleTracer) - let simpleTracerC1 = appendInnerName "Outer1" simpleTracer1 - let simpleTracerC2 = appendInnerName "Inner1" simpleTracerC1 - let simpleTracerC3 = setPrivacy Confidential $ appendInnerName "Inner2" simpleTracerC1 - traceWith simpleTracerC2 message1 - traceWith (setSeverity Critical simpleTracerC3) message2 - traceWith simpleTracerC2 message3 - traceWith (appendInnerName "Inner3" simpleTracerC3) message4 - traceWith (appendInnerName "cont1" $ appendInnerName "cont2" $ appendInnerName "cont3" simpleTracerC2) message1 - msgs <- reverse <$> readIORef stdoutTracerRef - let res = map formattedMsgAsText msgs - pure res - -test2Res :: [Text] -test2Res = [ - "{\"at\":\"2023-11-23T14:07:26.112085435Z\",\"ns\":\"Outer1.Inner1\",\"data\":{\"kind\":\"TraceStartLeadershipCheck\",\"slot\":1001},\"sev\":\"Info\",\"thread\":\"460\",\"host\":\"deusXmachina\"}" - ,"{\"at\":\"2023-11-23T14:07:26.112096216Z\",\"ns\":\"Outer1.Inner2\",\"data\":{\"kind\":\"TraceSlotIsImmutable\",\"slot\":3333,\"tip\":\"Origin\",\"tipBlockNo\":1},\"sev\":\"Critical\",\"thread\":\"460\",\"host\":\"deusXmachina\"}" - ,"{\"at\":\"2023-11-23T14:07:26.112101607Z\",\"ns\":\"Outer1.Inner1\",\"data\":{\"current slot\":4400,\"kind\":\"TraceBlockFromFuture\",\"tip\":300},\"sev\":\"Info\",\"thread\":\"460\",\"host\":\"deusXmachina\"}" - ,"{\"at\":\"2023-11-23T14:07:26.112107139Z\",\"ns\":\"Outer1.Inner2.Inner3\",\"data\":{\"kind\":\"TraceStartLeadershipCheck\",\"slot\":2002},\"sev\":\"Info\",\"thread\":\"460\",\"host\":\"deusXmachina\"}" - ,"{\"at\":\"2023-11-23T14:07:26.112114044Z\",\"ns\":\"Outer1.Inner1.cont3.cont2.cont1\",\"data\":{\"kind\":\"TraceStartLeadershipCheck\",\"slot\":1001},\"sev\":\"Info\",\"thread\":\"460\",\"host\":\"deusXmachina\"}" - ] diff --git a/trace-dispatcher/test/data/docGeneration.md b/trace-dispatcher/test/data/docGeneration.md deleted file mode 100644 index 22a81c2d1df..00000000000 --- a/trace-dispatcher/test/data/docGeneration.md +++ /dev/null @@ -1,181 +0,0 @@ -# Cardano Trace Documentation - -## Table Of Contents - -### [Trace Messages](#trace-messages) - -1. [Node1ⓣⓢ](#node1blockfromfuture) -1. [Node2ⓣⓢ](#node2blockfromfuture) - -### [Metrics](#metrics) - - -### [Datapoints](#datapoints) - - -### [Configuration](#configuration) - - - -## Trace Messages - -### Node1.BlockFromFuture - - -> Leadership check failed: the current chain contains a block from a slot -> /after/ the current slot -> -> This can only happen if the system is under heavy load. -> -> We record both the current slot number as well as the slot number of the -> block at the tip of the chain. -> -> See also - - -Severity: `Error` -Privacy: `Public` -Details: `DNormal` - - -From current configuration: - -Backends: - `Stdout MachineFormat` -Filtered Invisible by config value: `Silence` - -### Node1.SlotIsImmutable - - -> Leadership check failed: the tip of the ImmutableDB inhabits the -> current slot -> -> This might happen in two cases. -> -> 1. the clock moved backwards, on restart we ignored everything from the -> VolatileDB since it's all in the future, and now the tip of the -> ImmutableDB points to a block produced in the same slot we're trying -> to produce a block in -> -> 2. k = 0 and we already adopted a block from another leader of the same -> slot. -> -> We record both the current slot number as well as the tip of the -> ImmutableDB. -> -> See also - - -Severity: `Error` -Privacy: `Public` -Details: `DNormal` - - -From current configuration: - -Backends: - `Stdout MachineFormat` -Filtered Invisible by config value: `Silence` - -### Node1.StartLeadershipCheck - - -> Start of the leadership check -> -> We record the current slot number. - - -Severity: `Info` -Privacy: `Public` -Details: `DNormal` - - -From current configuration: - -Backends: - `Stdout MachineFormat` -Filtered Invisible by config value: `Silence` - -### Node2.BlockFromFuture - - -> Leadership check failed: the current chain contains a block from a slot -> /after/ the current slot -> -> This can only happen if the system is under heavy load. -> -> We record both the current slot number as well as the slot number of the -> block at the tip of the chain. -> -> See also - - -Severity: `Error` -Privacy: `Public` -Details: `DNormal` - - -From current configuration: - -Backends: - `Stdout MachineFormat` -Filtered Invisible by config value: `Silence` - -### Node2.SlotIsImmutable - - -> Leadership check failed: the tip of the ImmutableDB inhabits the -> current slot -> -> This might happen in two cases. -> -> 1. the clock moved backwards, on restart we ignored everything from the -> VolatileDB since it's all in the future, and now the tip of the -> ImmutableDB points to a block produced in the same slot we're trying -> to produce a block in -> -> 2. k = 0 and we already adopted a block from another leader of the same -> slot. -> -> We record both the current slot number as well as the tip of the -> ImmutableDB. -> -> See also - - -Severity: `Error` -Privacy: `Public` -Details: `DNormal` - - -From current configuration: - -Backends: - `Stdout MachineFormat` -Filtered Invisible by config value: `Silence` - -### Node2.StartLeadershipCheck - - -> Start of the leadership check -> -> We record the current slot number. - - -Severity: `Info` -Privacy: `Public` -Details: `DNormal` - - -From current configuration: - -Backends: - `Stdout MachineFormat` -Filtered Invisible by config value: `Silence` -## Metrics - - -## Datapoints - - -## diff --git a/trace-dispatcher/test/trace-dispatcher-test.hs b/trace-dispatcher/test/trace-dispatcher-test.hs deleted file mode 100644 index e9bcd681ed2..00000000000 --- a/trace-dispatcher/test/trace-dispatcher-test.hs +++ /dev/null @@ -1,93 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -Wno-unused-imports #-} - -import Prelude hiding (readFile, writeFile) - -import Data.Aeson -import qualified Data.ByteString.Char8 as BS -import Data.Text (Text, breakOn, replace, stripEnd) -import Data.Text.Encoding -import Data.Text.IO (readFile) -import Test.Tasty -import Test.Tasty.HUnit -import Test.Tasty.QuickCheck - -import Cardano.Logging -import Cardano.Logging.Test.Oracles -import Cardano.Logging.Test.Script -import Cardano.Logging.Test.Tracer -import Cardano.Logging.Test.Unit.Aggregation -import Cardano.Logging.Test.Unit.Configuration -import Cardano.Logging.Test.Unit.DataPoint -import Cardano.Logging.Test.Unit.Documentation -import Cardano.Logging.Test.Unit.EKG -import Cardano.Logging.Test.Unit.FrequencyLimiting -import Cardano.Logging.Test.Unit.Routing -import Cardano.Logging.Test.Unit.Trivial - - -main :: IO () -main = defaultMain tests - --- Add unitTests to the main test group -tests :: TestTree -tests = testGroup "Tests" - [ unitTests - , localTests - ] - -unitTests :: TestTree -unitTests = testGroup "trace-dispatcher-unit-tests" - [ - testCase "testTrivial1" $ do - res <- test1 - bres <- testLoggingMessagesEq res test1Res - assertBool "testTrivial1" bres - , testCase "testTrivial2" $ do - res <- test2 - bres <- testLoggingMessagesEq res test2Res - assertBool "testTrivial2" bres - , testCase "testAggregation" $ do - res <- testAggregation - bres <- testLoggingMessagesEq res testAggResult - assertBool "testAggregation" bres - , testCase "testRouting" $ do - res <- testRouting - bres <- testLoggingMessagesEq res testRoutingResult - assertBool "testRouting" bres - , testCase "testConfig" $ do - res <- testConfig - bres <- testLoggingMessagesEq res testConfigResult - assertBool "testConfig" bres -#ifdef linux_HOST_OS - , testCase "testDocGeneration" $ do - actual <- docTracers - expected <- readFile "test/data/docGeneration.md" - let actual' = fst $ breakOn "Configuration:" actual - assertEqual "testDocGeneration" - (stripEnd expected) - (stripEnd actual') -#endif - , testCase "testEKG" $ do - res <- testEKG - assertBool "testEKG" (res == 1000) - , testCase "testDatapoint" $ do - res <- testDataPoint - assertBool "testDatapoint" (show res == testDataPointResult) - , testCase "testLimiting" $ do - _res <- testLimiting - assertBool "testLimiting" True -- currently not verified - ] - -localTests :: TestTree -localTests = localOption (QuickCheckTests 10) $ testGroup "trace-dispatcher" - [ testProperty "single-threaded send tests" $ - runScriptSimple 1.0 oracleMessages - , testProperty "multi-threaded send tests" $ - runScriptMultithreaded 1.0 oracleMessages - -- , testProperty "multi-threaded send tests with reconfiguration" $ - -- runScriptMultithreadedWithReconfig 1.0 oracleMessages - , testProperty "reconfiguration stress test" $ - runScriptMultithreadedWithConstantReconfig 1.0 (\ _ _ -> property True) - ] diff --git a/trace-dispatcher/trace-dispatcher.cabal b/trace-dispatcher/trace-dispatcher.cabal deleted file mode 100644 index b70ef21a856..00000000000 --- a/trace-dispatcher/trace-dispatcher.cabal +++ /dev/null @@ -1,165 +0,0 @@ -cabal-version: 3.0 - -name: trace-dispatcher -version: 2.11.1 -synopsis: Tracers for Cardano -description: Package for development of simple and efficient tracers - based on the arrow based contra-tracer package -category: Cardano, - Trace, -copyright: 2020-2023 Input Output Global Inc (IOG), 2023-2026 Intersect. -author: Juergen Nicklisch-Franken -maintainer: operations@iohk.io -license: Apache-2.0 -license-files: LICENSE - NOTICE -extra-doc-files: CHANGELOG.md - README.md - doc/trace-dispatcher.md - -common project-config - default-language: Haskell2010 - - default-extensions: LambdaCase - NamedFieldPuns - OverloadedStrings - - ghc-options: -Wall - -Wcompat - -Wincomplete-uni-patterns - -Wincomplete-record-updates - -Wpartial-fields - -Widentities - -Wredundant-constraints - -Wmissing-export-lists - -Wno-incomplete-patterns - - if impl(ghc >= 9.8) - ghc-options: -Wno-x-partial - - -library - import: project-config - hs-source-dirs: src - exposed-modules: Cardano.Logging - Cardano.Logging.Configuration - Cardano.Logging.ConfigurationParser - Cardano.Logging.Consistency - Cardano.Logging.DocuGenerator - Cardano.Logging.DocuGenerator.Result - Cardano.Logging.DocuGenerator.Tree - Cardano.Logging.Formatter - Cardano.Logging.FrequencyLimiter - Cardano.Logging.Prometheus.Exposition - Cardano.Logging.Prometheus.NetworkRun - Cardano.Logging.Prometheus.TCPServer - Cardano.Logging.Trace - Cardano.Logging.TraceDispatcherMessage - Cardano.Logging.Tracer.DataPoint - Cardano.Logging.Tracer.EKG - Cardano.Logging.Tracer.Standard - Cardano.Logging.Tracer.Forward - Cardano.Logging.Tracer.Composed - Cardano.Logging.Types - Cardano.Logging.Types.TraceMessage - Cardano.Logging.Types.NodeInfo - Cardano.Logging.Types.NodeStartupInfo - Cardano.Logging.Utils - Control.Tracer.Arrow - Control.Tracer - - build-depends: base >=4.12 && <5 - , aeson >= 2.1.0.0 - , aeson-pretty - , async - , bytestring - , cborg - , cborg-json - , containers - , contra-tracer - , deepseq - , ekg-core - , hashable - , hostname - , http-date - , network - , serialise - , stm - , text - , time - , time-manager - , unagi-chan >= 0.4.1.4 - , unix-compat - , unliftio - , unliftio-core - , unordered-containers - , yaml - - if os(windows) - build-depends: Win32 - else - build-depends: unix - - -test-suite trace-dispatcher-test - import: project-config - type: exitcode-stdio-1.0 - hs-source-dirs: test - main-is: trace-dispatcher-test.hs - other-modules: Cardano.Logging.Test.Types - Cardano.Logging.Test.Oracles - Cardano.Logging.Test.Config - Cardano.Logging.Test.Tracer - Cardano.Logging.Test.Script - Cardano.Logging.Test.Unit.TestObjects - Cardano.Logging.Test.Unit.Aggregation - Cardano.Logging.Test.Unit.Trivial - Cardano.Logging.Test.Unit.Routing - Cardano.Logging.Test.Unit.EKG - Cardano.Logging.Test.Unit.Configuration - Cardano.Logging.Test.Unit.DataPoint - Cardano.Logging.Test.Unit.FrequencyLimiting - Cardano.Logging.Test.Unit.Documentation - - build-depends: base >=4.12 && <5 - , aeson - , bytestring - , containers - , deepseq - , ekg-core - , generic-data - , hostname - , text - , stm - , tasty - , tasty-hunit - , tasty-quickcheck - , time - , trace-dispatcher - , unordered-containers - , utf8-string - , yaml - , QuickCheck - - -benchmark trace-dispatcher-bench - import: project-config - type: exitcode-stdio-1.0 - hs-source-dirs: bench, test - main-is: trace-dispatcher-bench.hs - - other-modules: Cardano.Logging.Test.Types - Cardano.Logging.Test.Oracles - Cardano.Logging.Test.Config - Cardano.Logging.Test.Tracer - Cardano.Logging.Test.Script - - build-depends: base >=4.12 && <5 - , aeson - , containers - , criterion - , ekg-core - , text - , time - , trace-dispatcher - , QuickCheck diff --git a/trace-forward/src/Trace/Forward/Forwarding.hs b/trace-forward/src/Trace/Forward/Forwarding.hs index fae115607c2..2960db6c85d 100644 --- a/trace-forward/src/Trace/Forward/Forwarding.hs +++ b/trace-forward/src/Trace/Forward/Forwarding.hs @@ -328,6 +328,8 @@ doListenToAcceptor magic snocket makeBearer configureSocket address timeLimits ekgConfig tfConfig dpfConfig sink ekgStore dpStore = void $ Server.with snocket + nullTracer + Mux.nullTracers makeBearer configureSocket address diff --git a/trace-forward/src/Trace/Forward/Utils/Version.hs b/trace-forward/src/Trace/Forward/Utils/Version.hs index 5ec494a22a7..881347b5897 100644 --- a/trace-forward/src/Trace/Forward/Utils/Version.hs +++ b/trace-forward/src/Trace/Forward/Utils/Version.hs @@ -1,3 +1,7 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralisedNewtypeDeriving #-} {-# LANGUAGE NamedFieldPuns #-} module Trace.Forward.Utils.Version @@ -13,13 +17,16 @@ import Ouroboros.Network.Protocol.Handshake.Version (Accept (..), Acce Queryable (..)) import qualified Codec.CBOR.Term as CBOR +import Control.DeepSeq (NFData) import Data.Text (Text) import qualified Data.Text as T +import GHC.Generics (Generic) data ForwardingVersion = ForwardingV_1 | ForwardingV_2 - deriving (Eq, Ord, Enum, Bounded, Show) + deriving stock (Eq, Ord, Enum, Bounded, Show, Generic) + deriving anyclass (NFData) forwardingVersionCodec :: CodecCBORTerm (Text, Maybe Int) ForwardingVersion forwardingVersionCodec = CodecCBORTerm { encodeTerm, decodeTerm } @@ -38,7 +45,8 @@ forwardingVersionCodec = CodecCBORTerm { encodeTerm, decodeTerm } newtype ForwardingVersionData = ForwardingVersionData { networkMagic :: NetworkMagic - } deriving (Eq, Show) + } deriving stock (Eq, Show) + deriving newtype (NFData) instance Acceptable ForwardingVersionData where acceptableVersion local remote diff --git a/trace-forward/test/Test/Trace/Forward/Protocol/DataPoint/Tests.hs b/trace-forward/test/Test/Trace/Forward/Protocol/DataPoint/Tests.hs index 5911f134313..6831fd8b381 100644 --- a/trace-forward/test/Test/Trace/Forward/Protocol/DataPoint/Tests.hs +++ b/trace-forward/test/Test/Trace/Forward/Protocol/DataPoint/Tests.hs @@ -18,6 +18,7 @@ import Control.Monad.IOSim (runSimOrThrow) import Control.Monad.ST (runST) import Control.Tracer (nullTracer) import Network.TypedProtocol.Codec +import Network.TypedProtocol.Codec.Properties import Network.TypedProtocol.Proofs import Test.Tasty @@ -45,7 +46,7 @@ tests = testGroup "Trace.Forward.Protocol.DataPoint" prop_codec_DataPointForward :: AnyMessage DataPointForward - -> Bool + -> Property prop_codec_DataPointForward msg = runST $ prop_codecM (codecDataPointForward CBOR.encode CBOR.decode @@ -54,7 +55,7 @@ prop_codec_DataPointForward msg = runST $ prop_codec_splits2_DataPointForward :: AnyMessage DataPointForward - -> Bool + -> Property prop_codec_splits2_DataPointForward msg = runST $ prop_codec_splitsM splits2 @@ -65,7 +66,7 @@ prop_codec_splits2_DataPointForward msg = runST $ prop_codec_splits3_DataPointForward :: AnyMessage DataPointForward - -> Bool + -> Property prop_codec_splits3_DataPointForward msg = runST $ prop_codec_splitsM splits3 diff --git a/trace-forward/test/Test/Trace/Forward/Protocol/TraceObject/Tests.hs b/trace-forward/test/Test/Trace/Forward/Protocol/TraceObject/Tests.hs index edf3f04f34a..06d5da2438e 100644 --- a/trace-forward/test/Test/Trace/Forward/Protocol/TraceObject/Tests.hs +++ b/trace-forward/test/Test/Trace/Forward/Protocol/TraceObject/Tests.hs @@ -18,6 +18,7 @@ import Control.Monad.ST (runST) import Control.Tracer (nullTracer) import Network.TypedProtocol.Codec import Network.TypedProtocol.Proofs +import Network.TypedProtocol.Codec.Properties import Test.Tasty import Test.Tasty.QuickCheck @@ -43,7 +44,7 @@ tests = testGroup "Trace.Forward.Protocol.TraceObject" , testProperty "channel IO" prop_channel_IO_TraceObjectForward ] -prop_codec_TraceObjectForward :: AnyMessage (TraceObjectForward TraceItem) -> Bool +prop_codec_TraceObjectForward :: AnyMessage (TraceObjectForward TraceItem) -> Property prop_codec_TraceObjectForward msg = runST $ prop_codecM (codecTraceObjectForward CBOR.encode CBOR.decode @@ -52,7 +53,7 @@ prop_codec_TraceObjectForward msg = runST $ prop_codec_splits2_TraceObjectForward :: AnyMessage (TraceObjectForward TraceItem) - -> Bool + -> Property prop_codec_splits2_TraceObjectForward msg = runST $ prop_codec_splitsM splits2 @@ -62,7 +63,7 @@ prop_codec_splits2_TraceObjectForward msg = runST $ prop_codec_splits3_TraceObjectForward :: AnyMessage (TraceObjectForward TraceItem) - -> Bool + -> Property prop_codec_splits3_TraceObjectForward msg = runST $ prop_codec_splitsM splits3 diff --git a/trace-forward/trace-forward.cabal b/trace-forward/trace-forward.cabal index 9302f4a8d25..77b489be267 100644 --- a/trace-forward/trace-forward.cabal +++ b/trace-forward/trace-forward.cabal @@ -64,20 +64,20 @@ library , cborg , containers , contra-tracer + , deepseq , extra , io-classes , network , network-mux - , ouroboros-network-api + , ouroboros-network:{api, framework} ^>= 1.1 , ekg-core - , ekg-forward >= 1.0 + , ekg-forward >= 1.2 , singletons ^>= 3.0 - , ouroboros-network-framework ^>= 0.19.2 , serialise , stm , text , trace-dispatcher - , typed-protocols:{typed-protocols, cborg} ^>= 1.0 + , typed-protocols:{typed-protocols, cborg} ^>= 1.2 test-suite test import: project-config @@ -104,14 +104,13 @@ test-suite test , contra-tracer , io-classes , io-sim - , ouroboros-network-api - , ouroboros-network-framework + , ouroboros-network:{api, framework} , trace-forward , QuickCheck , serialise , tasty , tasty-quickcheck - , typed-protocols + , typed-protocols:{typed-protocols, codec-properties} , text ghc-options: -rtsopts