From 1de51eca0889bc72d9df2b8ce0c7a23976f8cf40 Mon Sep 17 00:00:00 2001 From: Georgy Lukyanov Date: Fri, 6 Feb 2026 10:45:36 +0100 Subject: [PATCH 01/39] [wip] Bump Hackage and CHaP index states, add SRPs --- cabal.project | 70 ++++++++++++++++++++++++++++++++++++++++++++++++--- flake.lock | 12 ++++----- 2 files changed, 73 insertions(+), 9 deletions(-) diff --git a/cabal.project b/cabal.project index 1a821ddc7db..1e2db6e8cf7 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-09T20:37:06Z constraints: -- haskell.nix patch does not work for 1.6.8 @@ -41,7 +41,7 @@ packages: extra-packages: alex program-options - ghc-options: -Werror + -- ghc-options: -Werror test-show-details: direct @@ -77,3 +77,67 @@ 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. + +-- Points to https://github.com/IntersectMBO/cardano-ledger/pull/5573 +source-repository-package + type: git + location: https://github.com/IntersectMBO/cardano-ledger + tag: 30a3e666b84f9d056f464b3a00c56ab0c5bccacd + --sha256: sha256-DsBE94iDxHkFnRdREZUOZYkydIMnp7U09N4SnaRc6+s= + subdir: + eras/allegra/impl + eras/alonzo/impl + eras/alonzo/test-suite + eras/babbage/impl + eras/conway/impl + eras/dijkstra/impl + eras/mary/impl + eras/shelley/impl + eras/shelley/test-suite + eras/shelley-ma/test-suite + libs/cardano-ledger-api + libs/cardano-ledger-core + libs/cardano-ledger-binary + libs/cardano-protocol-tpraos + libs/non-integral + libs/small-steps + libs/cardano-data + libs/vector-map + eras/byron/chain/executable-spec + eras/byron/ledger/executable-spec + eras/byron/ledger/impl + eras/byron/crypto + +-- geo2a/bump-ntc +source-repository-package + type: git + location: https://github.com/IntersectMBO/ouroboros-consensus + tag: d871fcf0ae5acf017f19282cda911ed5727239be + --sha256: sha256-//U4RJG1f1BQNT14rV0tte1YpawSWZCO38x5zBEVIYg= + subdir: + . + +source-repository-package + type: git + location: https://github.com/input-output-hk/kes-agent + tag: 7aedefc0077ffaf93bf46508c1fe0d7efdead227 + --sha256: sha256-ZcB0pPex349uH1W7ha5ez7Kx/XadK00j5wRm7+vyX0s= + subdir: + kes-agent + kes-agent-crypto + +source-repository-package + type: git + location: https://github.com/IntersectMBO/cardano-api + tag: c409f34bb2681d3224da88dbadfb4a415824261b + --sha256: sha256-rzW9XWN5qSSLOT3zVUf2hvT7BqiyfNzvTyBopP5KbSE= + subdir: + cardano-api + +source-repository-package + type: git + location: https://github.com/IntersectMBO/cardano-cli + tag: c867304a1342d2df08040549b3f8a0e0a8eef045 + --sha256: sha256-2YQ40E4QLJj0Zt4xlLqtEBypf3SfmxOPgjtksQFbhlc= + subdir: + cardano-cli diff --git a/flake.lock b/flake.lock index 7c09d075789..190cc94a737 100644 --- a/flake.lock +++ b/flake.lock @@ -3,11 +3,11 @@ "CHaP": { "flake": false, "locked": { - "lastModified": 1772623894, - "narHash": "sha256-95NCPKIcDnQ+vja6ofTsnFJKoH9AjT0opOj8zdGvWSw=", + "lastModified": 1773090839, + "narHash": "sha256-V7vhMr+wuiPBRwocogR4kom2TelRRmyIwMtkwGWOjpw=", "owner": "intersectmbo", "repo": "cardano-haskell-packages", - "rev": "e140e457e9c9db8591f0d8b0c35597ffb65955fc", + "rev": "7891446454cabab3809353586b672b4aaa598c76", "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": { From 7e5782c0dd75189748ff3c559f19213a3f813a5c Mon Sep 17 00:00:00 2001 From: Georgy Lukyanov Date: Thu, 12 Feb 2026 19:36:32 +0100 Subject: [PATCH 02/39] Use `cardano-crypto-class-2.3.*` --- cardano-node-chairman/cardano-node-chairman.cabal | 2 +- cardano-submit-api/cardano-submit-api.cabal | 4 ++-- cardano-testnet/cardano-testnet.cabal | 4 ++-- 3 files changed, 5 insertions(+), 5 deletions(-) diff --git a/cardano-node-chairman/cardano-node-chairman.cabal b/cardano-node-chairman/cardano-node-chairman.cabal index 3a2c9e630e1..fb580394619 100644 --- a/cardano-node-chairman/cardano-node-chairman.cabal +++ b/cardano-node-chairman/cardano-node-chairman.cabal @@ -69,7 +69,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-submit-api/cardano-submit-api.cabal b/cardano-submit-api/cardano-submit-api.cabal index b7cb0bd700f..015a0448125 100644 --- a/cardano-submit-api/cardano-submit-api.cabal +++ b/cardano-submit-api/cardano-submit-api.cabal @@ -42,7 +42,7 @@ library , cardano-api ^>= 10.24.1 , 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 @@ -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-testnet/cardano-testnet.cabal b/cardano-testnet/cardano-testnet.cabal index dd9d3e75a2a..404c0f9d220 100644 --- a/cardano-testnet/cardano-testnet.cabal +++ b/cardano-testnet/cardano-testnet.cabal @@ -43,7 +43,7 @@ library , bytestring , cardano-api ^>= 10.24.1 , 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 @@ -154,7 +154,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 From c8dddf25192f5af8da9ca2e88c1bfcc3e31aa5ee Mon Sep 17 00:00:00 2001 From: Georgy Lukyanov Date: Thu, 12 Feb 2026 19:36:48 +0100 Subject: [PATCH 03/39] Use `typed-protocols-1.2.*` --- cardano-node/cardano-node.cabal | 2 +- trace-forward/trace-forward.cabal | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/cardano-node/cardano-node.cabal b/cardano-node/cardano-node.cabal index 9f463f9b347..a1a9e7b90c5 100644 --- a/cardano-node/cardano-node.cabal +++ b/cardano-node/cardano-node.cabal @@ -214,7 +214,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 diff --git a/trace-forward/trace-forward.cabal b/trace-forward/trace-forward.cabal index 9302f4a8d25..d185f08ff19 100644 --- a/trace-forward/trace-forward.cabal +++ b/trace-forward/trace-forward.cabal @@ -77,7 +77,7 @@ library , stm , text , trace-dispatcher - , typed-protocols:{typed-protocols, cborg} ^>= 1.0 + , typed-protocols:{typed-protocols, cborg} ^>= 1.2 test-suite test import: project-config From 430eb105bd508c26699b281e508ba3395fa995e4 Mon Sep 17 00:00:00 2001 From: Georgy Lukyanov Date: Mon, 5 Jan 2026 14:52:58 +0100 Subject: [PATCH 04/39] Bump Plutus and API --- cardano-node-chairman/cardano-node-chairman.cabal | 4 ++-- cardano-node/cardano-node.cabal | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/cardano-node-chairman/cardano-node-chairman.cabal b/cardano-node-chairman/cardano-node-chairman.cabal index fb580394619..cf70935a963 100644 --- a/cardano-node-chairman/cardano-node-chairman.cabal +++ b/cardano-node-chairman/cardano-node-chairman.cabal @@ -44,12 +44,12 @@ 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 diff --git a/cardano-node/cardano-node.cabal b/cardano-node/cardano-node.cabal index a1a9e7b90c5..412434bfc79 100644 --- a/cardano-node/cardano-node.cabal +++ b/cardano-node/cardano-node.cabal @@ -139,7 +139,7 @@ library , base16-bytestring , bytestring , cardano-api ^>= 10.24.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 @@ -169,7 +169,7 @@ library , 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 , microlens From 6eb5ebbe4f1fa5adc797713a73b5fc5561c9e436 Mon Sep 17 00:00:00 2001 From: Georgy Lukyanov Date: Fri, 6 Feb 2026 10:50:10 +0100 Subject: [PATCH 05/39] Bump Network and Consensus packages, adapt to new structure - remove Nix overrides for ouroboros-network-framework and ouroboros-consensus-cardano that do not exist anymore, as the were renamed --- bench/locli/locli.cabal | 4 ++-- bench/tx-generator/tx-generator.cabal | 10 +++------- .../cardano-node-chairman.cabal | 6 ++---- cardano-node/cardano-node.cabal | 18 +++++------------- cardano-submit-api/cardano-submit-api.cabal | 4 ++-- cardano-testnet/cardano-testnet.cabal | 6 +++--- cardano-tracer/cardano-tracer.cabal | 17 ++++++----------- flake.nix | 2 +- nix/haskell.nix | 8 -------- nix/workbench/shell.nix | 2 +- trace-forward/trace-forward.cabal | 6 ++---- 11 files changed, 27 insertions(+), 56 deletions(-) diff --git a/bench/locli/locli.cabal b/bench/locli/locli.cabal index 21b5d941ee3..90335b330cf 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.0 , sop-core , split , sqlite-easy >= 1.1.0.1 diff --git a/bench/tx-generator/tx-generator.cabal b/bench/tx-generator/tx-generator.cabal index c18c68ddcb0..a7db05b4d7c 100644 --- a/bench/tx-generator/tx-generator.cabal +++ b/bench/tx-generator/tx-generator.cabal @@ -114,6 +114,7 @@ library , cardano-crypto-class , cardano-crypto-wrapper , cardano-data + , cardano-diffusion ^>= 1.0 , cardano-git-rev ^>= 0.2.2 , cardano-ledger-alonzo , cardano-ledger-api @@ -137,13 +138,8 @@ 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} , plutus-ledger-api , plutus-tx , random diff --git a/cardano-node-chairman/cardano-node-chairman.cabal b/cardano-node-chairman/cardano-node-chairman.cabal index cf70935a963..487e00bb2aa 100644 --- a/cardano-node-chairman/cardano-node-chairman.cabal +++ b/cardano-node-chairman/cardano-node-chairman.cabal @@ -51,10 +51,8 @@ executable cardano-node-chairman , contra-tracer , 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 diff --git a/cardano-node/cardano-node.cabal b/cardano-node/cardano-node.cabal index 412434bfc79..e9f25a8e1e2 100644 --- a/cardano-node/cardano-node.cabal +++ b/cardano-node/cardano-node.cabal @@ -185,14 +185,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.0 + , cardano-diffusion:{api, cardano-diffusion, orphan-instances, tracing} ^>=1.0 , prettyprinter , prettyprinter-ansi-terminal , psqueues @@ -263,11 +258,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, ouroboros-network} , strict-sop-core , text , trace-dispatcher diff --git a/cardano-submit-api/cardano-submit-api.cabal b/cardano-submit-api/cardano-submit-api.cabal index 015a0448125..e42f6744964 100644 --- a/cardano-submit-api/cardano-submit-api.cabal +++ b/cardano-submit-api/cardano-submit-api.cabal @@ -49,8 +49,8 @@ library , 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 diff --git a/cardano-testnet/cardano-testnet.cabal b/cardano-testnet/cardano-testnet.cabal index 404c0f9d220..e558c810341 100644 --- a/cardano-testnet/cardano-testnet.cabal +++ b/cardano-testnet/cardano-testnet.cabal @@ -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, ouroboros-network} ^>= 1.0 + , cardano-diffusion:{api, cardano-diffusion} ^>= 1.0 , prettyprinter , process , resourcet diff --git a/cardano-tracer/cardano-tracer.cabal b/cardano-tracer/cardano-tracer.cabal index 33f5cd51571..6b821b8f9c4 100644 --- a/cardano-tracer/cardano-tracer.cabal +++ b/cardano-tracer/cardano-tracer.cabal @@ -172,6 +172,7 @@ library , bimap , blaze-html , bytestring + , cardano-diffusion ^>= 1.0 , cborg ^>= 0.2.4 , containers , contra-tracer @@ -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.0 , 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 @@ -420,9 +417,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, ouroboros-network} ^>= 1.0 , process , QuickCheck , tasty diff --git a/flake.nix b/flake.nix index edfb1e89323..0636e6fe72e 100644 --- a/flake.nix +++ b/flake.nix @@ -126,7 +126,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..ae1593eb1ec 100644 --- a/nix/haskell.nix +++ b/nix/haskell.nix @@ -138,7 +138,6 @@ 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.plutus-ledger-api.components.library.doHaddock = false; @@ -359,12 +358,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"; @@ -397,7 +390,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-forward/trace-forward.cabal b/trace-forward/trace-forward.cabal index d185f08ff19..e1f7ec7a7c0 100644 --- a/trace-forward/trace-forward.cabal +++ b/trace-forward/trace-forward.cabal @@ -68,11 +68,10 @@ library , io-classes , network , network-mux - , ouroboros-network-api + , ouroboros-network:{api, framework} ^>= 1.0 , ekg-core , ekg-forward >= 1.0 , singletons ^>= 3.0 - , ouroboros-network-framework ^>= 0.19.2 , serialise , stm , text @@ -104,8 +103,7 @@ test-suite test , contra-tracer , io-classes , io-sim - , ouroboros-network-api - , ouroboros-network-framework + , ouroboros-network:{api, framework} , trace-forward , QuickCheck , serialise From df57958aabf978eddfd387673ea5cf0ca4dfaab5 Mon Sep 17 00:00:00 2001 From: Georgy Lukyanov Date: Fri, 6 Feb 2026 11:01:54 +0100 Subject: [PATCH 06/39] Bump kes-agent --- cardano-node/cardano-node.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/cardano-node/cardano-node.cabal b/cardano-node/cardano-node.cabal index e9f25a8e1e2..730ced8dc22 100644 --- a/cardano-node/cardano-node.cabal +++ b/cardano-node/cardano-node.cabal @@ -171,7 +171,7 @@ library , hostname , io-classes:{io-classes,strict-stm,si-timers} ^>= 1.8 , iohk-monitoring ^>= 0.2 - , kes-agent ^>=0.2 + , kes-agent ^>=1.1 , microlens , mmap , network-mux From c951a89cf454cf513cf49487eb7504b7b68eb568 Mon Sep 17 00:00:00 2001 From: Georgy Lukyanov Date: Tue, 10 Mar 2026 09:20:59 +0100 Subject: [PATCH 07/39] Bump ekg-forward --- cardano-tracer/cardano-tracer.cabal | 2 +- trace-forward/trace-forward.cabal | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/cardano-tracer/cardano-tracer.cabal b/cardano-tracer/cardano-tracer.cabal index 6b821b8f9c4..2fd20fea8b7 100644 --- a/cardano-tracer/cardano-tracer.cabal +++ b/cardano-tracer/cardano-tracer.cabal @@ -178,7 +178,7 @@ library , contra-tracer , directory , ekg-core - , ekg-forward >= 1.0 + , ekg-forward >= 1.1 , ekg-wai , extra , filepath diff --git a/trace-forward/trace-forward.cabal b/trace-forward/trace-forward.cabal index e1f7ec7a7c0..44b932bb1df 100644 --- a/trace-forward/trace-forward.cabal +++ b/trace-forward/trace-forward.cabal @@ -70,7 +70,7 @@ library , network-mux , ouroboros-network:{api, framework} ^>= 1.0 , ekg-core - , ekg-forward >= 1.0 + , ekg-forward >= 1.1 , singletons ^>= 3.0 , serialise , stm From 4fcb77e2d994bdac859ae92251a9119b28242017 Mon Sep 17 00:00:00 2001 From: Georgy Lukyanov Date: Tue, 6 Jan 2026 10:04:21 +0100 Subject: [PATCH 08/39] Initialise node feature flags --- cardano-node/src/Cardano/Node/Run.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/cardano-node/src/Cardano/Node/Run.hs b/cardano-node/src/Cardano/Node/Run.hs index edc43f58078..2ebc9151f7d 100644 --- a/cardano-node/src/Cardano/Node/Run.hs +++ b/cardano-node/src/Cardano/Node/Run.hs @@ -487,6 +487,9 @@ handleSimpleNode blockType runP tracers nc onKernel = do onKernel nodeKernel , rnPeerSharing = ncPeerSharing nc , rnGetUseBootstrapPeers = readTVar useBootstrapVar + , rnFeatureFlags = mempty + , rnTxSubmissionLogicVersion = undefined -- TODO(10.7) + , rnTxSubmissionInitDelay = undefined -- TODO(10.7) } #ifdef UNIX -- initial `SIGHUP` handler, which only rereads the topology file but From 2653fa81362d52bdb8063708853ddcdbf2fee72f Mon Sep 17 00:00:00 2001 From: Georgy Lukyanov Date: Tue, 10 Feb 2026 11:57:21 +0100 Subject: [PATCH 09/39] trace-forward: add new Network tracers --- trace-forward/src/Trace/Forward/Forwarding.hs | 2 ++ trace-forward/src/Trace/Forward/Utils/Version.hs | 12 ++++++++++-- trace-forward/trace-forward.cabal | 1 + 3 files changed, 13 insertions(+), 2 deletions(-) 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/trace-forward.cabal b/trace-forward/trace-forward.cabal index 44b932bb1df..b55ecd8b437 100644 --- a/trace-forward/trace-forward.cabal +++ b/trace-forward/trace-forward.cabal @@ -64,6 +64,7 @@ library , cborg , containers , contra-tracer + , deepseq , extra , io-classes , network From fbc80a1572a3f6df867c18970ac69a194c7702c0 Mon Sep 17 00:00:00 2001 From: Georgy Lukyanov Date: Tue, 10 Feb 2026 12:34:22 +0100 Subject: [PATCH 10/39] Rename Network imports --- bench/tx-generator/src/Cardano/Benchmarking/Command.hs | 2 +- .../src/Cardano/Benchmarking/GeneratorTx/NodeToNode.hs | 6 +++--- .../tx-generator/src/Cardano/Benchmarking/LogTypes.hs | 2 +- .../src/Cardano/Benchmarking/Script/Env.hs | 2 +- cardano-node/src/Cardano/Node/Configuration/Socket.hs | 2 +- .../src/Cardano/Node/Configuration/TopologyP2P.hs | 2 +- cardano-node/src/Cardano/Node/Queries.hs | 4 ++-- cardano-node/src/Cardano/Node/Run.hs | 4 ++-- cardano-node/src/Cardano/Node/Startup.hs | 4 ++-- cardano-node/src/Cardano/Node/Tracing/API.hs | 4 ++-- cardano-node/src/Cardano/Node/Tracing/Consistency.hs | 9 ++++----- cardano-node/src/Cardano/Node/Tracing/Documentation.hs | 4 ++-- cardano-node/src/Cardano/Node/Tracing/Tracers.hs | 2 -- cardano-node/src/Cardano/Node/Tracing/Tracers/P2P.hs | 2 +- .../src/Cardano/Node/Tracing/Tracers/Startup.hs | 4 ++-- cardano-node/src/Cardano/Node/Types.hs | 2 +- .../src/Cardano/Tracing/OrphanInstances/Network.hs | 10 +++++----- cardano-node/src/Cardano/Tracing/Tracers.hs | 4 ++-- cardano-node/test/Test/Cardano/Node/Gen.hs | 2 +- cardano-node/test/Test/Cardano/Node/POM.hs | 4 ++-- cardano-testnet/src/Testnet/Defaults.hs | 2 +- .../src/Cardano/Tracer/Handlers/ReForwarder.hs | 2 +- cardano-tracer/test/cardano-tracer-test-ext.hs | 2 +- 23 files changed, 39 insertions(+), 42 deletions(-) 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/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/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..cea86018f7f 100644 --- a/cardano-node/src/Cardano/Node/Configuration/TopologyP2P.hs +++ b/cardano-node/src/Cardano/Node/Configuration/TopologyP2P.hs @@ -47,7 +47,7 @@ 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 Cardano.Network.NodeToNode (DiffusionMode (..), PeerAdvertise (..)) import Ouroboros.Network.PeerSelection.LedgerPeers.Type (LedgerPeerSnapshot (..), UseLedgerPeers (..), RelayAccessPoint (..)) import Ouroboros.Network.PeerSelection.State.LocalRootPeers (HotValency (..), 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 2ebc9151f7d..4921e7733cd 100644 --- a/cardano-node/src/Cardano/Node/Run.hs +++ b/cardano-node/src/Cardano/Node/Run.hs @@ -107,8 +107,8 @@ 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.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) diff --git a/cardano-node/src/Cardano/Node/Startup.hs b/cardano-node/src/Cardano/Node/Startup.hs index e6ec33a8d74..c0a570b7fef 100644 --- a/cardano-node/src/Cardano/Node/Startup.hs +++ b/cardano-node/src/Cardano/Node/Startup.hs @@ -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) diff --git a/cardano-node/src/Cardano/Node/Tracing/API.hs b/cardano-node/src/Cardano/Node/Tracing/API.hs index e33d1c88915..be3d35535fb 100644 --- a/cardano-node/src/Cardano/Node/Tracing/API.hs +++ b/cardano-node/src/Cardano/Node/Tracing/API.hs @@ -32,8 +32,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..a3213ff21b1 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Consistency.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Consistency.hs @@ -68,12 +68,12 @@ 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 Cardano.Network.NodeToNode (RemoteAddress) +import qualified Cardano.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.LocalRootPeers @@ -96,7 +96,6 @@ import Ouroboros.Network.TxSubmission.Inbound (TraceTxSubmissionInboun import Ouroboros.Network.TxSubmission.Outbound (TraceTxSubmissionOutbound) import qualified Data.Text as T -import qualified Network.Mux as Mux import qualified Network.Socket as Socket diff --git a/cardano-node/src/Cardano/Node/Tracing/Documentation.hs b/cardano-node/src/Cardano/Node/Tracing/Documentation.hs index 1658bed634d..4fa07dbb9bd 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Documentation.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Documentation.hs @@ -82,8 +82,8 @@ 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 Cardano.Network.NodeToNode (RemoteAddress) +import qualified Cardano.Network.NodeToNode as NtN import Ouroboros.Network.PeerSelection.Churn (ChurnCounters (..)) import Ouroboros.Network.PeerSelection.Governor (DebugPeerSelection (..), PeerSelectionCounters, TracePeerSelection (..)) diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers.hs index 485d28e71f0..249ea520156 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers.hs @@ -53,8 +53,6 @@ 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) diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/P2P.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/P2P.hs index 709beae76b4..7142b3c07f6 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/P2P.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/P2P.hs @@ -28,7 +28,7 @@ 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 qualified Cardano.Network.NodeToNode as NtN import Ouroboros.Network.OrphanInstances () import Ouroboros.Network.PeerSelection.Churn (ChurnCounters (..)) import Ouroboros.Network.PeerSelection.Governor (DebugPeerSelection (..), diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/Startup.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/Startup.hs index 379d7820f77..7f877112caa 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 (..)) diff --git a/cardano-node/src/Cardano/Node/Types.hs b/cardano-node/src/Cardano/Node/Types.hs index 321d038cdc1..240a8f4def1 100644 --- a/cardano-node/src/Cardano/Node/Types.hs +++ b/cardano-node/src/Cardano/Node/Types.hs @@ -47,7 +47,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 diff --git a/cardano-node/src/Cardano/Tracing/OrphanInstances/Network.hs b/cardano-node/src/Cardano/Tracing/OrphanInstances/Network.hs index f77dc4092aa..8cb0df80666 100644 --- a/cardano-node/src/Cardano/Tracing/OrphanInstances/Network.hs +++ b/cardano-node/src/Cardano/Tracing/OrphanInstances/Network.hs @@ -23,7 +23,7 @@ module Cardano.Tracing.OrphanInstances.Network import Cardano.Network.Diffusion (CardanoDebugPeerSelection, CardanoPeerSelectionCounters, CardanoTraceLocalRootPeers, CardanoTracePeerSelection, TraceChurnMode (..)) -import Cardano.Network.OrphanInstances () +import Ouroboros.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 @@ -55,11 +55,11 @@ 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 Cardano.Network.NodeToClient (NodeToClientVersion (..)) +import qualified Cardano.Network.NodeToClient as NtC +import Cardano.Network.NodeToNode (NodeToNodeVersion (..), 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 (..), diff --git a/cardano-node/src/Cardano/Tracing/Tracers.hs b/cardano-node/src/Cardano/Tracing/Tracers.hs index 869a3015eed..953b089cce5 100644 --- a/cardano-node/src/Cardano/Tracing/Tracers.hs +++ b/cardano-node/src/Cardano/Tracing/Tracers.hs @@ -101,8 +101,8 @@ 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 Cardano.Network.NodeToClient (LocalAddress) +import Cardano.Network.NodeToNode (RemoteAddress) import Ouroboros.Network.PeerSelection.Churn (ChurnCounters (..)) import Ouroboros.Network.PeerSelection.Governor ( PeerSelectionView (..)) diff --git a/cardano-node/test/Test/Cardano/Node/Gen.hs b/cardano-node/test/Test/Cardano/Node/Gen.hs index d2fd8220b49..d62cfc7b31c 100644 --- a/cardano-node/test/Test/Cardano/Node/Gen.hs +++ b/cardano-node/test/Test/Cardano/Node/Gen.hs @@ -29,7 +29,7 @@ import Cardano.Node.Configuration.TopologyP2P (LocalRootPeersGroup (.. PeerAdvertise (..), PublicRootPeers (..), RootConfig (..)) 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 (..)) diff --git a/cardano-node/test/Test/Cardano/Node/POM.hs b/cardano-node/test/Test/Cardano/Node/POM.hs index d4de440fbd7..b3ac51bb555 100644 --- a/cardano-node/test/Test/Cardano/Node/POM.hs +++ b/cardano-node/test/Test/Cardano/Node/POM.hs @@ -22,8 +22,8 @@ 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 (..)) diff --git a/cardano-testnet/src/Testnet/Defaults.hs b/cardano-testnet/src/Testnet/Defaults.hs index e93e7b17aa1..bfdaa4cf6c0 100644 --- a/cardano-testnet/src/Testnet/Defaults.hs +++ b/cardano-testnet/src/Testnet/Defaults.hs @@ -71,7 +71,7 @@ import Cardano.Node.Configuration.TopologyP2P (LocalRootPeersGroup (.. 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 (..), 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-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 From 4a62825f4ec3ba2d6bb5782a4368b0381b704a90 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcin=20W=C3=B3jtowicz?= Date: Wed, 11 Feb 2026 09:34:17 +0100 Subject: [PATCH 11/39] fix typo --- cardano-node/src/Cardano/Node/Configuration/TopologyP2P.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/cardano-node/src/Cardano/Node/Configuration/TopologyP2P.hs b/cardano-node/src/Cardano/Node/Configuration/TopologyP2P.hs index cea86018f7f..0f6d2085a23 100644 --- a/cardano-node/src/Cardano/Node/Configuration/TopologyP2P.hs +++ b/cardano-node/src/Cardano/Node/Configuration/TopologyP2P.hs @@ -320,7 +320,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 From b9dcf3f34643980df4cc95fd79b410ddab42a2f4 Mon Sep 17 00:00:00 2001 From: Federico Mastellone Date: Thu, 12 Feb 2026 22:01:24 +0000 Subject: [PATCH 12/39] [wip] Integrate tracing changes, with TODOs - Use keyrole types instead of promoted constructors - tracing: remove ouroboros-network:framework-tracing Network.Mux - tracing: remove ouroboros-network:framework-tracing Ouroboros.Network - tracing: remove ouroboros-network:tracing - integrate new Ledger traces - use ToJSON to get ToObject for ApplyTxError - Add instance ToObject TxDecision --- cardano-node/app/cardano-node.hs | 1 + cardano-node/cardano-node.cabal | 3 +- .../Cardano/Node/Configuration/LedgerDB.hs | 76 +- .../src/Cardano/Node/Configuration/POM.hs | 13 +- .../Cardano/Node/Configuration/TopologyP2P.hs | 17 +- .../src/Cardano/Node/Protocol/Byron.hs | 7 +- .../src/Cardano/Node/Protocol/Cardano.hs | 1 + .../src/Cardano/Node/Protocol/Shelley.hs | 3 + .../src/Cardano/Node/Protocol/Types.hs | 4 + cardano-node/src/Cardano/Node/Run.hs | 31 +- .../src/Cardano/Node/TraceConstraints.hs | 12 +- cardano-node/src/Cardano/Node/Tracing/API.hs | 1 + .../src/Cardano/Node/Tracing/Consistency.hs | 34 +- .../src/Cardano/Node/Tracing/Documentation.hs | 36 +- .../src/Cardano/Node/Tracing/Era/HardFork.hs | 12 +- .../src/Cardano/Node/Tracing/Era/Shelley.hs | 134 +- .../src/Cardano/Node/Tracing/Render.hs | 21 +- .../src/Cardano/Node/Tracing/StateRep.hs | 2 +- .../src/Cardano/Node/Tracing/Tracers.hs | 67 +- .../Cardano/Node/Tracing/Tracers/ChainDB.hs | 668 ++++-- .../Cardano/Node/Tracing/Tracers/Consensus.hs | 166 +- .../Cardano/Node/Tracing/Tracers/Diffusion.hs | 979 +------- .../Node/Tracing/Tracers/LedgerMetrics.hs | 6 +- .../Node/Tracing/Tracers/NodeToClient.hs | 137 +- .../Node/Tracing/Tracers/NodeToNode.hs | 4 - .../src/Cardano/Node/Tracing/Tracers/P2P.hs | 2104 ----------------- .../Cardano/Node/Tracing/Tracers/Startup.hs | 1 + cardano-node/src/Cardano/Tracing/Config.hs | 18 + cardano-node/src/Cardano/Tracing/HasIssuer.hs | 4 +- .../Tracing/OrphanInstances/Consensus.hs | 98 +- .../Tracing/OrphanInstances/HardFork.hs | 12 +- .../Tracing/OrphanInstances/Network.hs | 224 +- .../Tracing/OrphanInstances/Shelley.hs | 126 +- cardano-node/src/Cardano/Tracing/Tracers.hs | 108 +- 34 files changed, 1169 insertions(+), 3961 deletions(-) delete mode 100644 cardano-node/src/Cardano/Node/Tracing/Tracers/P2P.hs 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 730ced8dc22..12e9dce2fac 100644 --- a/cardano-node/cardano-node.cabal +++ b/cardano-node/cardano-node.cabal @@ -111,7 +111,6 @@ library 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 @@ -139,6 +138,7 @@ library , base16-bytestring , bytestring , cardano-api ^>= 10.24.1 + , cardano-data , cardano-crypto-class ^>=2.3 , cardano-crypto-wrapper , cardano-git-rev ^>=0.2.2 @@ -165,7 +165,6 @@ library , ekg-wai , ekg-core , filepath - , formatting , generic-data , hashable , hostname 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..b0c488e3dd3 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 @@ -500,9 +501,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 +508,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,7 +718,7 @@ 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` @@ -821,7 +822,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) diff --git a/cardano-node/src/Cardano/Node/Configuration/TopologyP2P.hs b/cardano-node/src/Cardano/Node/Configuration/TopologyP2P.hs index 0f6d2085a23..f8ccb8239d6 100644 --- a/cardano-node/src/Cardano/Node/Configuration/TopologyP2P.hs +++ b/cardano-node/src/Cardano/Node/Configuration/TopologyP2P.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} @@ -37,6 +38,7 @@ module Cardano.Node.Configuration.TopologyP2P ) where + import Cardano.Api (handleIOExceptionsLiftWith, liftEither, runExceptT, throwError) import Cardano.Network.ConsensusMode (ConsensusMode (..)) @@ -49,7 +51,7 @@ import Cardano.Node.Types import Cardano.Tracing.OrphanInstances.Network () import Cardano.Network.NodeToNode (DiffusionMode (..), PeerAdvertise (..)) import Ouroboros.Network.PeerSelection.LedgerPeers.Type (LedgerPeerSnapshot (..), - UseLedgerPeers (..), RelayAccessPoint (..)) + UseLedgerPeers (..), RelayAccessPoint (..), LedgerPeersKind(..)) import Ouroboros.Network.PeerSelection.State.LocalRootPeers (HotValency (..), WarmValency (..)) @@ -347,16 +349,19 @@ readTopologyFileOrError nc tr = <> Text.unpack err) pure -readPeerSnapshotFile :: PeerSnapshotFile -> IO (Either Text LedgerPeerSnapshot) +-- TODO(10.7): what the resulting LedgerPeersKind should be? +-- Probably we need to use the LedgerPeerSnapshotWithBlock type +readPeerSnapshotFile :: PeerSnapshotFile -> IO (Either Text (LedgerPeerSnapshot BigLedgerPeers)) readPeerSnapshotFile (PeerSnapshotFile file) = do - content <- first renderException <$> try (BS.readFile file) - return $ first handler $ content >>= eitherDecodeStrict + _content <- first renderException <$> try (BS.readFile file) + -- return $ first handler $ content >>= eitherDecodeStrict + undefined -- TODO(10.7) where renderException :: IOException -> String renderException = displayException - handler :: String -> Text - handler msg = + _handler :: String -> Text + _handler msg = Text.pack $ "Cardano.Node.Configuration.TopologyP2P.readPeerSnapshotFile: " <> msg 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..e52d6f39324 100644 --- a/cardano-node/src/Cardano/Node/Protocol/Shelley.hs +++ b/cardano-node/src/Cardano/Node/Protocol/Shelley.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} @@ -42,6 +43,7 @@ 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 Control.Exception (IOException) import Control.Monad @@ -51,6 +53,7 @@ import qualified Data.Text as T import System.Directory (getFileSize) import qualified System.IO.MMap as MMap + ------------------------------------------------------------------------------ -- Shelley protocol -- 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/Run.hs b/cardano-node/src/Cardano/Node/Run.hs index 4921e7733cd..45916630010 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 #-} @@ -64,11 +65,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 +81,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,8 +101,9 @@ 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 (..)) +import Ouroboros.Network.Block (HeaderHash) import Ouroboros.Network.BlockFetch (FetchMode) import qualified Ouroboros.Network.Diffusion as Diffusion import qualified Ouroboros.Network.Diffusion.Types as Diffusion @@ -113,7 +115,7 @@ import Cardano.Network.NodeToNode (AcceptedConnectionsLimit (..), Conn 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) @@ -488,8 +490,8 @@ handleSimpleNode blockType runP tracers nc onKernel = do , rnPeerSharing = ncPeerSharing nc , rnGetUseBootstrapPeers = readTVar useBootstrapVar , rnFeatureFlags = mempty - , rnTxSubmissionLogicVersion = undefined -- TODO(10.7) - , rnTxSubmissionInitDelay = undefined -- TODO(10.7) + , rnTxSubmissionLogicVersion = undefined -- TODO(10.7) -- ask Network + , rnTxSubmissionInitDelay = undefined -- TODO(10.7) -- ask Network } #ifdef UNIX -- initial `SIGHUP` handler, which only rereads the topology file but @@ -518,7 +520,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, @@ -569,7 +571,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 @@ -652,7 +654,7 @@ installSigHUPHandler :: Tracer IO (StartupTrace blk) -> StrictTVar IO UseLedgerPeers -> StrictTVar IO UseBootstrapPeers -> StrictTVar IO (Maybe PeerSnapshotFile) - -> StrictTVar IO (Maybe LedgerPeerSnapshot) + -> StrictTVar IO (Maybe (LedgerPeerSnapshot BigLedgerPeers)) -> IO () #ifndef UNIX installSigHUPHandler _ _ _ _ _ _ _ _ _ _ _ = return () @@ -765,8 +767,8 @@ updateLedgerPeerSnapshot :: Tracer IO (StartupTrace blk) -> NodeConfiguration -> STM IO (Maybe PeerSnapshotFile) -> STM IO UseLedgerPeers - -> (Maybe LedgerPeerSnapshot -> STM IO ()) - -> IO (Maybe LedgerPeerSnapshot) + -> (Maybe (LedgerPeerSnapshot BigLedgerPeers) -> STM IO ()) + -> IO (Maybe (LedgerPeerSnapshot BigLedgerPeers)) updateLedgerPeerSnapshot startupTracer (NodeConfiguration {ncConsensusMode}) readLedgerPeerPath readUseLedgerVar writeVar = do (mPeerSnapshotFile, useLedgerPeers) <- atomically $ (,) <$> readLedgerPeerPath <*> readUseLedgerVar @@ -781,7 +783,7 @@ updateLedgerPeerSnapshot startupTracer (NodeConfiguration {ncConsensusMode}) rea snapshotFile <- hoistMaybe mPeerSnapshotFile eSnapshot <- liftIO $ readPeerSnapshotFile snapshotFile - lps@(LedgerPeerSnapshot (wOrigin, _)) <- + lps@(LedgerPeerSnapshotV2 (wOrigin, _)) <- case ncConsensusMode of GenesisMode -> MaybeT $ hushM eSnapshot (trace . NetworkConfigUpdateError) @@ -877,7 +879,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 @@ -954,7 +956,8 @@ producerAddresses RealNodeTopology { ntLocalRootPeersGroups , LocalRootConfig { diffusionMode = rootDiffusionMode lrp, peerAdvertise, - extraFlags = trustable lrp + extraLocalRootFlags = trustable lrp, + localProvenance = undefined -- TODO(10.7) -- ask Network } ) ) diff --git a/cardano-node/src/Cardano/Node/TraceConstraints.hs b/cardano-node/src/Cardano/Node/TraceConstraints.hs index 59c84b7bb34..d69ba33b40c 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,6 +25,7 @@ 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.Peras.SelectView import Ouroboros.Consensus.Protocol.Abstract (SelectView, ValidationErr) 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,10 @@ 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)) ) diff --git a/cardano-node/src/Cardano/Node/Tracing/API.hs b/cardano-node/src/Cardano/Node/Tracing/API.hs index be3d35535fb..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 #-} diff --git a/cardano-node/src/Cardano/Node/Tracing/Consistency.hs b/cardano-node/src/Cardano/Node/Tracing/Consistency.hs index a3213ff21b1..014083c5235 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 @@ -31,12 +36,8 @@ 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 +69,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 Cardano.Network.NodeToNode (RemoteAddress) -import qualified Cardano.Network.NodeToNode as NtN -import Ouroboros.Network.PeerSelection.Churn (ChurnCounters) import Ouroboros.Network.PeerSelection.Governor (DebugPeerSelection (..), 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,10 +90,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 @@ -282,12 +286,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 @@ -321,10 +325,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 @@ -439,7 +440,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 4fa07dbb9bd..94300aa0813 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 () @@ -44,7 +48,6 @@ 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 @@ -84,9 +87,8 @@ import qualified Ouroboros.Network.InboundGovernor as InboundGovernor import Ouroboros.Network.KeepAlive (TraceKeepAliveClient (..)) import Cardano.Network.NodeToNode (RemoteAddress) import qualified Cardano.Network.NodeToNode as NtN -import Ouroboros.Network.PeerSelection.Churn (ChurnCounters (..)) 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 +106,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 +119,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 +164,6 @@ parseTraceDocumentationCmd = ] ) -deriving instance Generic UnversionedProtocol -deriving instance Generic UnversionedProtocolData - instance ToJSON UnversionedProtocol instance ToJSON UnversionedProtocolData @@ -177,7 +177,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 +190,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 +605,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 +749,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 249ea520156..bf91b58ca69 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 @@ -35,7 +37,6 @@ 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) @@ -57,8 +58,11 @@ import qualified Ouroboros.Network.Diffusion as Diffusion import Codec.CBOR.Read (DeserialiseFailure) import Control.Monad (unless) import "contra-tracer" Control.Tracer (Tracer (..)) +import Data.Aeson (ToJSON) import 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. -- @@ -72,6 +76,7 @@ mkDispatchTracers (ConnectionId RemoteAddress) (TraceChainSyncClientEvent blk)) , LogFormatting (TraceGsmEvent (Tip blk)) , MetaTrace (TraceGsmEvent (Tip blk)) + , ToJSON (HeaderHash blk) ) => NodeKernelData blk -> Trace IO FormattedMessage @@ -190,6 +195,7 @@ mkConsensusTracers :: forall blk. (ConnectionId RemoteAddress) (TraceChainSyncClientEvent blk)) , LogFormatting (TraceGsmEvent (Tip blk)) , MetaTrace (TraceGsmEvent (Tip blk)) + , ToJSON (HeaderHash blk) ) => ConfigReflection -> Trace IO FormattedMessage @@ -331,6 +337,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 @@ -379,6 +395,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. @@ -473,6 +493,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 @@ -488,16 +513,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 @@ -565,21 +598,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"] @@ -660,14 +683,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..916ba1d6022 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/ChainDB.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/ChainDB.hs @@ -28,7 +28,7 @@ import Ouroboros.Consensus.Ledger.Abstract (LedgerError) import Ouroboros.Consensus.Ledger.Extended (ExtValidationError (..)) import Ouroboros.Consensus.Ledger.Inspect (InspectLedger, LedgerEvent (..)) import Ouroboros.Consensus.Ledger.SupportsProtocol (LedgerSupportsProtocol) -import Ouroboros.Consensus.Protocol.Abstract (SelectView, ValidationErr) +import Ouroboros.Consensus.Protocol.Abstract (ValidationErr) import qualified Ouroboros.Consensus.Protocol.PBFT as PBFT import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB import qualified Ouroboros.Consensus.Storage.ImmutableDB as ImmDB @@ -37,7 +37,11 @@ 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.Util.Condense (condense) import Ouroboros.Consensus.Util.Enclose @@ -52,6 +56,9 @@ import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import Data.Word (Word64) import Numeric (showFFloat) +import Data.Void (absurd) +import Data.Typeable (Typeable, cast) +import Ouroboros.Consensus.Peras.SelectView -- {-# ANN module ("HLint: ignore Redundant bracket" :: Text) #-} @@ -65,7 +72,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,7 +86,7 @@ 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 @@ -103,6 +110,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 +141,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 +159,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 +188,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 +235,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 +287,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 +339,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 +400,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 +429,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)]) ) @@ -392,7 +444,7 @@ instance MetaTrace (ChainDB.TraceEvent blk) where 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 @@ -423,10 +475,12 @@ 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) = + -- TODO(10.7) incorporate _reasonForSwitch into trace output + forHuman (ChainDB.AddedToCurrentChain es _ _ c _reasonForSwitch) = "Chain extended, new tip: " <> renderPointAsPhrase (AF.headPoint c) <> Text.concat [ "\nEvent: " <> showT e | e <- es ] - forHuman (ChainDB.SwitchedToAFork es _ _ c) = + -- TODO(10.7) incorporate _reasonForSwitch into trace output + forHuman (ChainDB.SwitchedToAFork es _ _ c _reasonForSwitch) = "Switched to a fork, new tip: " <> renderPointAsPhrase (AF.headPoint c) <> Text.concat [ "\nEvent: " <> showT e | e <- es ] forHuman (ChainDB.AddBlockValidation ev') = forHuman ev' @@ -480,7 +534,8 @@ instance ( LogFormatting (Header blk) mconcat [ "kind" .= String "TraceAddBlockEvent.ChangingSelection" , "block" .= forMachine dtal pt ] - forMachine DDetailed (ChainDB.AddedToCurrentChain events selChangedInfo base extended) = + -- TODO(10.7) incorporate _reasonForSwitch into trace output + forMachine DDetailed (ChainDB.AddedToCurrentChain events selChangedInfo base extended _reasonForSwitch) = let ChainInformation { .. } = chainInformation selChangedInfo base extended 0 tipBlockIssuerVkHashText :: Text tipBlockIssuerVkHashText = @@ -491,10 +546,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 +558,20 @@ instance ( LogFormatting (Header blk) ++ [ "tipBlockHash" .= tipBlockHash , "tipBlockParentHash" .= tipBlockParentHash , "tipBlockIssuerVKeyHash" .= tipBlockIssuerVkHashText] - forMachine dtal (ChainDB.AddedToCurrentChain events selChangedInfo _base extended) = + -- TODO(10.7) incorporate _reasonForSwitch into trace output + forMachine dtal (ChainDB.AddedToCurrentChain events selChangedInfo _base extended _reasonForSwitch) = 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) = + -- TODO(10.7) incorporate _reasonForSwitch into trace output + forMachine DDetailed (ChainDB.SwitchedToAFork events selChangedInfo old new _reasonForSwitch) = let ChainInformation { .. } = chainInformation selChangedInfo old new 0 tipBlockIssuerVkHashText :: Text tipBlockIssuerVkHashText = @@ -526,10 +582,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,14 +594,15 @@ instance ( LogFormatting (Header blk) ++ [ "tipBlockHash" .= tipBlockHash , "tipBlockParentHash" .= tipBlockParentHash , "tipBlockIssuerVKeyHash" .= tipBlockIssuerVkHashText] - forMachine dtal (ChainDB.SwitchedToAFork events selChangedInfo _old new) = + -- TODO(10.7) incorporate _reasonForSwitch into trace output + 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) ] @@ -585,7 +642,8 @@ instance ( LogFormatting (Header blk) ] - asMetrics (ChainDB.SwitchedToAFork _warnings selChangedInfo oldChain newChain) = + -- TODO(10.7) incorporate _reasonForSwitch into trace output + asMetrics (ChainDB.SwitchedToAFork _warnings selChangedInfo oldChain newChain _reasonForSwitch) = let forkIt = not $ AF.withinFragmentBounds (AF.headPoint oldChain) newChain ChainInformation { .. } = chainInformation selChangedInfo oldChain newChain 0 @@ -604,7 +662,8 @@ instance ( LogFormatting (Header blk) ,("parent_hash",tipBlockParentHash) ,("issuer_VKey_hash", tipBlockIssuerVkHashText)] ] - asMetrics (ChainDB.AddedToCurrentChain _warnings selChangedInfo oldChain newChain) = + -- TODO(10.7) incorporate _reasonForSwitch into trace output + asMetrics (ChainDB.AddedToCurrentChain _warnings selChangedInfo oldChain newChain _reasonForSwitch) = let ChainInformation { .. } = chainInformation selChangedInfo oldChain newChain 0 tipBlockIssuerVkHashText = @@ -674,11 +733,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 +1881,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 +1931,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 +1974,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 -instance LogFormatting V1.FlavorImplSpecificTraceOnDisk where - forMachine _dtal (V1.OnDiskBackingStoreInitialise limits) = - mconcat [ "limits" .= showT limits ] - forMachine dtal (V1.OnDiskBackingStoreTrace ev) = forMachine dtal 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 - forHuman (V1.OnDiskBackingStoreInitialise limits) = "Initializing on-disk backing store with limits " <> showT limits - forHuman (V1.OnDiskBackingStoreTrace ev) = forHuman ev + documentFor (Namespace _ ("LMDB" : _)) = + Just "An LMDB trace" + documentFor _ = Nothing + + allNamespaces = + map (nsPrependInner "LMDB") + (allNamespaces :: [Namespace (V1.Trace LMDB.LMDB)]) + +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 (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 +2100,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,42 +2258,115 @@ instance MetaTrace V1.BackingStoreValueHandleTrace where , Namespace [] ["Statted"] ] -instance LogFormatting V2.FlavorImplSpecificTrace where - forMachine _dtal V2.TraceLedgerTablesHandleCreate = +{------------------------------------------------------------------------------- + V2 +-------------------------------------------------------------------------------} + +-- TODO(10.7) incorporate _timed into trace output +instance LogFormatting V2.LedgerDBV2Trace where + forMachine _dtal (V2.TraceLedgerTablesHandleCreate _timed) = mconcat [ "kind" .= String "LedgerTablesHandleCreate" ] - forMachine _dtal V2.TraceLedgerTablesHandleClose = + forMachine _dtal (V2.TraceLedgerTablesHandleClose _timed) = mconcat [ "kind" .= String "LedgerTablesHandleClose" ] + forMachine dtal (V2.BackendTrace ev) = forMachine dtal ev + forMachine _dtal (V2.TraceLedgerTablesHandleRead _) = undefined -- TODO(10.7),TODO(lsm) + forMachine _dtal (V2.TraceLedgerTablesHandleDuplicate _) = undefined -- TODO(10.7),TODO(lsm) + forMachine _dtal (V2.TraceLedgerTablesHandleCreateFirst _) = undefined -- TODO(10.7),TODO(lsm) + forMachine _dtal (V2.TraceLedgerTablesHandlePush _) = undefined -- TODO(10.7),TODO(lsm) - forHuman V2.TraceLedgerTablesHandleCreate = + forHuman V2.TraceLedgerTablesHandleCreate{} = "Created a new 'LedgerTablesHandle', potentially by duplicating an existing one" - forHuman V2.TraceLedgerTablesHandleClose = + forHuman V2.TraceLedgerTablesHandleClose{} = "Closed a 'LedgerTablesHandle'" - -instance MetaTrace V2.FlavorImplSpecificTrace where - namespaceFor V2.TraceLedgerTablesHandleCreate = + forHuman (V2.BackendTrace ev) = forHuman ev + forHuman (V2.TraceLedgerTablesHandleRead _) = undefined -- TODO(10.7),TODO(lsm) + forHuman (V2.TraceLedgerTablesHandleDuplicate _) = undefined -- TODO(10.7),TODO(lsm) + forHuman (V2.TraceLedgerTablesHandleCreateFirst _) = undefined -- TODO(10.7),TODO(lsm) + forHuman (V2.TraceLedgerTablesHandlePush _) = undefined -- TODO(10.7),TODO(lsm) + +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 _) = undefined -- TODO(10.7),TODO(lsm) + namespaceFor (V2.TraceLedgerTablesHandleDuplicate _) = undefined -- TODO(10.7),TODO(lsm) + namespaceFor (V2.TraceLedgerTablesHandleCreateFirst _) = undefined -- TODO(10.7),TODO(lsm) + namespaceFor (V2.TraceLedgerTablesHandlePush _) = undefined -- TODO(10.7),TODO(lsm) severityFor (Namespace _ ["LedgerTablesHandleCreate"]) _ = Just Debug severityFor (Namespace _ ["LedgerTablesHandleClose"]) _ = 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 _ = Nothing allNamespaces = [ Namespace [] ["LedgerTablesHandleCreate"] , Namespace [] ["LedgerTablesHandleClose"] - ] + ] ++ 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 _) = undefined -- TODO(10.7),TODO(lsm) + forMachine _dtal (LSM.LSMUpdate _) = undefined -- TODO(10.7),TODO(lsm) + forMachine _dtal (LSM.LSMSnap _) = undefined -- TODO(10.7),TODO(lsm) + forMachine _dtal (LSM.LSMOpenSession _) = undefined -- TODO(10.7),TODO(lsm) + + forHuman (LSM.LSMTreeTrace ev) = showT ev + forHuman (LSM.LSMLookup _) = undefined -- TODO(10.7),TODO(lsm) + forHuman (LSM.LSMUpdate _) = undefined -- TODO(10.7),TODO(lsm) + forHuman (LSM.LSMSnap _) = undefined -- TODO(10.7),TODO(lsm) + forHuman (LSM.LSMOpenSession _) = undefined -- TODO(10.7),TODO(lsm) + + +instance MetaTrace (V2.Trace LSM.LSM) where + namespaceFor LSM.LSMTreeTrace{} = Namespace [] ["LSMTrace"] + namespaceFor LSM.LSMLookup {} = Namespace [] ["LSMTrace"] + namespaceFor LSM.LSMUpdate {} = Namespace [] ["LSMTrace"] + namespaceFor LSM.LSMSnap {} = Namespace [] ["LSMTrace"] + namespaceFor LSM.LSMOpenSession {} = Namespace [] ["LSMTrace"] + + severityFor (Namespace _ ["LSMTrace"]) _ = Just Debug + severityFor _ _ = Nothing + + documentFor (Namespace _ ["LSMTrace"]) = + Just "A trace from the LSM-trees backend" + documentFor _ = Nothing + + allNamespaces = [Namespace [] ["LSMTrace"]] + +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 +2982,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..2d0bc5988f7 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/Consensus.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/Consensus.hs @@ -69,10 +69,8 @@ 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 Ouroboros.Network.Tracing () import Control.Monad (guard) import Data.Aeson (ToJSON, Value (..), toJSON, (.=)) @@ -87,15 +85,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 +658,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 @@ -1063,157 +1052,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 index 840076510db..e05ae92b183 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/Diffusion.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/Diffusion.hs @@ -13,981 +13,8 @@ {-# OPTIONS_GHC -Wno-orphans #-} -module Cardano.Node.Tracing.Tracers.Diffusion - ( txsMempoolTimeoutHardCounterName - , impliesMempoolTimeoutHard - ) where +module Cardano.Node.Tracing.Tracers.Diffusion () where +import Ouroboros.Network.Tracing () +import Ouroboros.Network.Tracing.PeerSelection () -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 7142b3c07f6..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 Cardano.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 7f877112caa..3b89975d194 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/Startup.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/Startup.hs @@ -505,6 +505,7 @@ nodeToClientVersionToInt = \case NodeToClientV_20 -> 20 NodeToClientV_21 -> 21 NodeToClientV_22 -> 22 + NodeToClientV_23 -> 23 nodeToNodeVersionToInt :: NodeToNodeVersion -> Int nodeToNodeVersionToInt = \case 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 8cb0df80666..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 (..)) -import Ouroboros.Network.OrphanInstances () + 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,9 +57,8 @@ 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 Cardano.Network.NodeToClient (NodeToClientVersion (..)) import qualified Cardano.Network.NodeToClient as NtC -import Cardano.Network.NodeToNode (NodeToNodeVersion (..), RemoteAddress, +import Cardano.Network.NodeToNode (RemoteAddress, TraceSendRecv (..)) import qualified Cardano.Network.NodeToNode as NtN import Ouroboros.Network.OrphanInstances () @@ -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 953b089cce5..1ac6f70664a 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, @@ -103,14 +105,12 @@ import qualified Ouroboros.Network.InboundGovernor as InboundGovernor import Ouroboros.Network.InboundGovernor.State as InboundGovernor import Cardano.Network.NodeToClient (LocalAddress) import Cardano.Network.NodeToNode (RemoteAddress) -import Ouroboros.Network.PeerSelection.Churn (ChurnCounters (..)) 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 _ _) -> undefined -- TODO(10.7) -- ask Network + TraceLabelPeer _ (TraceTxInboundRejectedFromMempool _ _) -> undefined -- TODO(10.7) -- ask Network + TraceLabelPeer _ (TraceTxInboundError _) -> undefined -- TODO(10.7) -- ask Network + TraceLabelPeer _ (TraceTxInboundDecision _) -> undefined -- TODO(10.7) -- ask Network , 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 ) @@ -1542,6 +1571,7 @@ teeTraceBlockFetchDecisionElide :: ( Eq peer , Show peer , ToJSON peer + , ToJSON (HeaderHash blk) , HasHeader blk , ConvertRawHash blk ) @@ -1590,7 +1620,6 @@ traceConnectionManagerTraceMetrics (OnOff True) (Just ekgDirect) = cmtTracer outboundConns _ -> return () - tracePeerSelectionTracerMetrics :: forall extraDebugState extraFlags extraPeers peeraddr. OnOff TracePeerSelection @@ -1610,7 +1639,6 @@ tracePeerSelectionTracerMetrics (OnOff True) (Just ekgDirect) = pstTracer (realToFrac duration) _ -> pure () - tracePeerSelectionCountersMetrics :: OnOff TracePeerSelectionCounters -> Maybe EKGDirect @@ -1621,7 +1649,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 +1700,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 From 9860c64577f28ac09fb4285a04876a96d22c5950 Mon Sep 17 00:00:00 2001 From: Georgy Lukyanov Date: Tue, 24 Feb 2026 18:22:01 +0100 Subject: [PATCH 13/39] cardano-tracer: integrate new Network packages --- cardano-tracer/src/Cardano/Tracer/Acceptors/Server.hs | 4 ++++ cardano-tracer/test/Cardano/Tracer/Test/Forwarder.hs | 2 ++ 2 files changed, 6 insertions(+) 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/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 From 52e2be32434f01e3de3b362fb4268d93a90c5798 Mon Sep 17 00:00:00 2001 From: Georgy Lukyanov Date: Wed, 25 Feb 2026 09:21:31 +0100 Subject: [PATCH 14/39] tx-generator: update to latest Ledger and Network --- .../src/Cardano/Benchmarking/Tracer.hs | 28 ++++++------------- .../Cardano/TxGenerator/ProtocolParameters.hs | 25 +++++++++-------- .../src/Cardano/TxGenerator/Utils.hs | 3 +- bench/tx-generator/tx-generator.cabal | 2 ++ 4 files changed, 26 insertions(+), 32 deletions(-) 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/Utils.hs b/bench/tx-generator/src/Cardano/TxGenerator/Utils.hs index 6565dbc1575..d6d5ed65adf 100644 --- a/bench/tx-generator/src/Cardano/TxGenerator/Utils.hs +++ b/bench/tx-generator/src/Cardano/TxGenerator/Utils.hs @@ -18,6 +18,7 @@ import qualified Cardano.Ledger.Coin as L import Cardano.TxGenerator.Types import Data.Maybe (fromJust) +import Data.Maybe.Strict import GHC.Stack @@ -76,7 +77,7 @@ mkTxFee = TxFeeExplicit shelleyBasedEra -- `TxValidityNoUpperBound` with the constraint of `IsShelleyBasedEra`. mkTxValidityUpperBound :: forall era. IsShelleyBasedEra era => SlotNo -> TxValidityUpperBound era mkTxValidityUpperBound slotNo = - TxValidityUpperBound (fromJust $ forEraMaybeEon (cardanoEra @era)) (Just slotNo) + TxValidityUpperBound (fromJust $ forEraMaybeEon (cardanoEra @era)) (SJust slotNo) -- | `mkTxInModeCardano` never uses the `TxInByronSpecial` constructor -- because its type enforces it being a Shelley-based era. diff --git a/bench/tx-generator/tx-generator.cabal b/bench/tx-generator/tx-generator.cabal index a7db05b4d7c..2e0ae8f93a6 100644 --- a/bench/tx-generator/tx-generator.cabal +++ b/bench/tx-generator/tx-generator.cabal @@ -122,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 @@ -143,6 +144,7 @@ library , plutus-ledger-api , plutus-tx , random + , typed-protocols ^>= 1.2 , serialise , streaming , cardano-ledger-shelley From 128e9c057aa1fe23abbc3da15e45ddcc3d662fc0 Mon Sep 17 00:00:00 2001 From: Javier Sagredo Date: Thu, 26 Feb 2026 14:47:51 +0100 Subject: [PATCH 15/39] Fill in LSM traces and reason for switch (#6469) --- .../src/Cardano/Node/TraceConstraints.hs | 4 +- .../Cardano/Node/Tracing/Tracers/ChainDB.hs | 212 +++++++++++++----- 2 files changed, 158 insertions(+), 58 deletions(-) diff --git a/cardano-node/src/Cardano/Node/TraceConstraints.hs b/cardano-node/src/Cardano/Node/TraceConstraints.hs index d69ba33b40c..a17e7bf3772 100644 --- a/cardano-node/src/Cardano/Node/TraceConstraints.hs +++ b/cardano-node/src/Cardano/Node/TraceConstraints.hs @@ -26,7 +26,7 @@ import Ouroboros.Consensus.Node.NetworkProtocolVersion (HasNetworkProtocolVersion (BlockNodeToClientVersion, BlockNodeToNodeVersion)) import Ouroboros.Consensus.Node.Run (RunNode, SerialiseNodeToNodeConstraints) import Ouroboros.Consensus.Peras.SelectView -import Ouroboros.Consensus.Protocol.Abstract (SelectView, ValidationErr) +import Ouroboros.Consensus.Protocol.Abstract (SelectView, ValidationErr, SelectViewReasonForSwitch, ReasonForSwitch, TiebreakerView) import Ouroboros.Consensus.Shelley.Ledger.Mempool (GenTx, TxId) import Ouroboros.Network.Block (Serialised) @@ -76,4 +76,6 @@ type TraceConstraints blk = , LogFormatting (ForgeStateUpdateError blk) , 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/Tracers/ChainDB.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/ChainDB.hs index 916ba1d6022..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 (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 @@ -43,22 +49,23 @@ 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) -import Data.Void (absurd) -import Data.Typeable (Typeable, cast) -import Ouroboros.Consensus.Peras.SelectView -- {-# ANN module ("HLint: ignore Redundant bracket" :: Text) #-} @@ -92,6 +99,8 @@ instance ( LogFormatting (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" @@ -440,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 (WeightedSelectView (BlockProtocol blk)) + , LogFormatting (Either (WithEmptyFragmentReasonForSwitch (WeightedSelectView (BlockProtocol blk))) (SelectViewReasonForSwitch (BlockProtocol blk))) , ConvertRawHash blk , ConvertRawHash (Header blk) , LedgerSupportsProtocol blk @@ -475,14 +536,13 @@ instance ( LogFormatting (Header blk) "Block fits onto some fork: " <> renderRealPointAsPhrase pt forHuman (ChainDB.ChangingSelection pt) = "Changing selection to: " <> renderPointAsPhrase pt - -- TODO(10.7) incorporate _reasonForSwitch into trace output - forHuman (ChainDB.AddedToCurrentChain es _ _ c _reasonForSwitch) = + forHuman (ChainDB.AddedToCurrentChain es _ _ c _) = "Chain extended, new tip: " <> renderPointAsPhrase (AF.headPoint c) <> Text.concat [ "\nEvent: " <> showT e | e <- es ] - -- TODO(10.7) incorporate _reasonForSwitch into trace output - forHuman (ChainDB.SwitchedToAFork es _ _ c _reasonForSwitch) = + 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 @@ -534,8 +594,7 @@ instance ( LogFormatting (Header blk) mconcat [ "kind" .= String "TraceAddBlockEvent.ChangingSelection" , "block" .= forMachine dtal pt ] - -- TODO(10.7) incorporate _reasonForSwitch into trace output - forMachine DDetailed (ChainDB.AddedToCurrentChain events selChangedInfo base extended _reasonForSwitch) = + forMachine DDetailed (ChainDB.AddedToCurrentChain events selChangedInfo base extended _) = let ChainInformation { .. } = chainInformation selChangedInfo base extended 0 tipBlockIssuerVkHashText :: Text tipBlockIssuerVkHashText = @@ -558,8 +617,7 @@ instance ( LogFormatting (Header blk) ++ [ "tipBlockHash" .= tipBlockHash , "tipBlockParentHash" .= tipBlockParentHash , "tipBlockIssuerVKeyHash" .= tipBlockIssuerVkHashText] - -- TODO(10.7) incorporate _reasonForSwitch into trace output - forMachine dtal (ChainDB.AddedToCurrentChain events selChangedInfo _base extended _reasonForSwitch) = + forMachine dtal (ChainDB.AddedToCurrentChain events selChangedInfo _base extended _) = mconcat $ [ "kind" .= String "AddedToCurrentChain" , "newtip" .= renderPointForDetails dtal (AF.headPoint extended) @@ -570,8 +628,7 @@ instance ( LogFormatting (Header blk) ] ++ [ "events" .= toJSON (map (forMachine dtal) events) | not (null events) ] - -- TODO(10.7) incorporate _reasonForSwitch into trace output - forMachine DDetailed (ChainDB.SwitchedToAFork events selChangedInfo old new _reasonForSwitch) = + forMachine DDetailed (ChainDB.SwitchedToAFork events selChangedInfo old new reasonForSwitch) = let ChainInformation { .. } = chainInformation selChangedInfo old new 0 tipBlockIssuerVkHashText :: Text tipBlockIssuerVkHashText = @@ -594,8 +651,8 @@ instance ( LogFormatting (Header blk) ++ [ "tipBlockHash" .= tipBlockHash , "tipBlockParentHash" .= tipBlockParentHash , "tipBlockIssuerVKeyHash" .= tipBlockIssuerVkHashText] - -- TODO(10.7) incorporate _reasonForSwitch into trace output - forMachine dtal (ChainDB.SwitchedToAFork events selChangedInfo _old new _reasonForSwitch) = + ++ [ "reason" .= forMachine DDetailed reasonForSwitch ] + forMachine dtal (ChainDB.SwitchedToAFork events selChangedInfo _old new reasonForSwitch) = mconcat $ [ "kind" .= String "TraceAddBlockEvent.SwitchedToAFork" , "newtip" .= renderPointForDetails dtal (AF.headPoint new) @@ -606,6 +663,7 @@ instance ( LogFormatting (Header blk) ] ++ [ "events" .= toJSON (map (forMachine dtal) events) | not (null events) ] + ++ [ "reason" .= forMachine dtal reasonForSwitch ] forMachine dtal (ChainDB.AddBlockValidation ev') = forMachine dtal ev' @@ -642,8 +700,7 @@ instance ( LogFormatting (Header blk) ] - -- TODO(10.7) incorporate _reasonForSwitch into trace output - asMetrics (ChainDB.SwitchedToAFork _warnings selChangedInfo oldChain newChain _reasonForSwitch) = + asMetrics (ChainDB.SwitchedToAFork _warnings selChangedInfo oldChain newChain _) = let forkIt = not $ AF.withinFragmentBounds (AF.headPoint oldChain) newChain ChainInformation { .. } = chainInformation selChangedInfo oldChain newChain 0 @@ -662,8 +719,7 @@ instance ( LogFormatting (Header blk) ,("parent_hash",tipBlockParentHash) ,("issuer_VKey_hash", tipBlockIssuerVkHashText)] ] - -- TODO(10.7) incorporate _reasonForSwitch into trace output - asMetrics (ChainDB.AddedToCurrentChain _warnings selChangedInfo oldChain newChain _reasonForSwitch) = + asMetrics (ChainDB.AddedToCurrentChain _warnings selChangedInfo oldChain newChain _) = let ChainInformation { .. } = chainInformation selChangedInfo oldChain newChain 0 tipBlockIssuerVkHashText = @@ -2262,27 +2318,35 @@ instance MetaTrace V1.BackingStoreValueHandleTrace where V2 -------------------------------------------------------------------------------} --- TODO(10.7) incorporate _timed into trace output +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 _timed) = - mconcat [ "kind" .= String "LedgerTablesHandleCreate" ] - forMachine _dtal (V2.TraceLedgerTablesHandleClose _timed) = - mconcat [ "kind" .= String "LedgerTablesHandleClose" ] + 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 _) = undefined -- TODO(10.7),TODO(lsm) - forMachine _dtal (V2.TraceLedgerTablesHandleDuplicate _) = undefined -- TODO(10.7),TODO(lsm) - forMachine _dtal (V2.TraceLedgerTablesHandleCreateFirst _) = undefined -- TODO(10.7),TODO(lsm) - forMachine _dtal (V2.TraceLedgerTablesHandlePush _) = undefined -- TODO(10.7),TODO(lsm) - - forHuman V2.TraceLedgerTablesHandleCreate{} = - "Created a new 'LedgerTablesHandle', potentially by duplicating an existing one" - forHuman V2.TraceLedgerTablesHandleClose{} = - "Closed a 'LedgerTablesHandle'" + 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 _) = undefined -- TODO(10.7),TODO(lsm) - forHuman (V2.TraceLedgerTablesHandleDuplicate _) = undefined -- TODO(10.7),TODO(lsm) - forHuman (V2.TraceLedgerTablesHandleCreateFirst _) = undefined -- TODO(10.7),TODO(lsm) - forHuman (V2.TraceLedgerTablesHandlePush _) = undefined -- TODO(10.7),TODO(lsm) + 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{} = @@ -2290,13 +2354,17 @@ instance MetaTrace V2.LedgerDBV2Trace where namespaceFor V2.TraceLedgerTablesHandleClose{} = Namespace [] ["LedgerTablesHandleClose"] namespaceFor (V2.BackendTrace ev) = nsPrependInner "BackendTrace" (namespaceFor ev) - namespaceFor (V2.TraceLedgerTablesHandleRead _) = undefined -- TODO(10.7),TODO(lsm) - namespaceFor (V2.TraceLedgerTablesHandleDuplicate _) = undefined -- TODO(10.7),TODO(lsm) - namespaceFor (V2.TraceLedgerTablesHandleCreateFirst _) = undefined -- TODO(10.7),TODO(lsm) - namespaceFor (V2.TraceLedgerTablesHandlePush _) = undefined -- TODO(10.7),TODO(lsm) + 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 @@ -2304,11 +2372,23 @@ instance MetaTrace V2.LedgerDBV2Trace where Just "Created a ledger tables handle" documentFor (Namespace _ ["LedgerTablesHandleClose"]) = 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 @@ -2331,33 +2411,51 @@ instance MetaTrace V2.SomeBackendTrace where instance LogFormatting (V2.Trace LSM.LSM) where forMachine _dtal (LSM.LSMTreeTrace ev) = mconcat [ "kind" .= String "LSMTreeTrace", "content" .= showT ev] - forMachine _dtal (LSM.LSMLookup _) = undefined -- TODO(10.7),TODO(lsm) - forMachine _dtal (LSM.LSMUpdate _) = undefined -- TODO(10.7),TODO(lsm) - forMachine _dtal (LSM.LSMSnap _) = undefined -- TODO(10.7),TODO(lsm) - forMachine _dtal (LSM.LSMOpenSession _) = undefined -- TODO(10.7),TODO(lsm) + 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 _) = undefined -- TODO(10.7),TODO(lsm) - forHuman (LSM.LSMUpdate _) = undefined -- TODO(10.7),TODO(lsm) - forHuman (LSM.LSMSnap _) = undefined -- TODO(10.7),TODO(lsm) - forHuman (LSM.LSMOpenSession _) = undefined -- TODO(10.7),TODO(lsm) + 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 [] ["LSMTrace"] - namespaceFor LSM.LSMUpdate {} = Namespace [] ["LSMTrace"] - namespaceFor LSM.LSMSnap {} = Namespace [] ["LSMTrace"] - namespaceFor LSM.LSMOpenSession {} = 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"]] + 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 = From 11775fec8e338a82337260b0c7effef5b22e5cef Mon Sep 17 00:00:00 2001 From: Georgy Lukyanov Date: Thu, 26 Feb 2026 17:57:47 +0100 Subject: [PATCH 16/39] cardano-testnet: adapt to latest ledger - fix blockfrost response types to match alonzo genesis ones --- cardano-testnet/src/Testnet/Blockfrost.hs | 149 ++++++++++-------- .../src/Testnet/Components/Configuration.hs | 4 +- .../src/Testnet/Components/Query.hs | 10 +- .../src/Testnet/Process/Cli/SPO.hs | 2 +- .../Test/Gov/ProposeNewConstitution.hs | 2 +- 5 files changed, 90 insertions(+), 77 deletions(-) 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..22eb39bf314 100644 --- a/cardano-testnet/src/Testnet/Components/Configuration.hs +++ b/cardano-testnet/src/Testnet/Components/Configuration.hs @@ -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/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/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 ) From e363c2aa0deede3e121a02c54f7f91d7f4112f9a Mon Sep 17 00:00:00 2001 From: John Lotoski Date: Tue, 3 Mar 2026 19:00:57 -0600 Subject: [PATCH 17/39] nix: don't generate Haddocks for cardano-diffusion --- nix/haskell.nix | 1 + 1 file changed, 1 insertion(+) diff --git a/nix/haskell.nix b/nix/haskell.nix index ae1593eb1ec..be2cab132e4 100644 --- a/nix/haskell.nix +++ b/nix/haskell.nix @@ -140,6 +140,7 @@ let packages.cardano-protocol-tpraos.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) { From baba5aa686bc322457c1a02440833f19e14484ec Mon Sep 17 00:00:00 2001 From: Georgy Lukyanov Date: Wed, 4 Mar 2026 13:26:40 +0100 Subject: [PATCH 18/39] plutus-scripts-bench: Bump plutus to 1.59 --- bench/plutus-scripts-bench/plutus-scripts-bench.cabal | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/bench/plutus-scripts-bench/plutus-scripts-bench.cabal b/bench/plutus-scripts-bench/plutus-scripts-bench.cabal index 3815b0a3be1..e61ae793b99 100644 --- a/bench/plutus-scripts-bench/plutus-scripts-bench.cabal +++ b/bench/plutus-scripts-bench/plutus-scripts-bench.cabal @@ -83,9 +83,9 @@ library -------------------------- build-depends: , cardano-api ^>=10.24.1 - , plutus-ledger-api ^>=1.58 - , plutus-tx ^>=1.58 - , plutus-tx-plugin ^>=1.58 + , plutus-ledger-api ^>=1.59 + , plutus-tx ^>=1.59 + , plutus-tx-plugin ^>=1.59 ------------------------ -- Non-IOG dependencies From d7ca434775ca8212d06950c9f03101f3d5b5b5f1 Mon Sep 17 00:00:00 2001 From: Georgy Lukyanov Date: Fri, 6 Mar 2026 12:23:01 +0100 Subject: [PATCH 19/39] [wip] Config for TxSubmissionLogicVersion and TxSubmissionInitDelay --- .../src/Cardano/Node/Configuration/POM.hs | 24 +++++++++++++++++++ cardano-node/src/Cardano/Node/Parsers.hs | 2 ++ cardano-node/src/Cardano/Node/Run.hs | 4 ++-- 3 files changed, 28 insertions(+), 2 deletions(-) diff --git a/cardano-node/src/Cardano/Node/Configuration/POM.hs b/cardano-node/src/Cardano/Node/Configuration/POM.hs index b0c488e3dd3..c6eb0883c61 100644 --- a/cardano-node/src/Cardano/Node/Configuration/POM.hs +++ b/cardano-node/src/Cardano/Node/Configuration/POM.hs @@ -50,6 +50,7 @@ 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 (TxSubmissionLogicVersion(..), TxSubmissionInitDelay(..)) import Control.Concurrent (getNumCapabilities) import Control.Monad (unless, void, when) @@ -197,6 +198,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. @@ -297,6 +301,9 @@ data PartialNodeConfiguration , pncGenesisConfigFlags :: !(Last GenesisConfigFlags) , pncResponderCoreAffinityPolicy :: !(Last ResponderCoreAffinityPolicy) + + , pncTxSubmissionLogicVersion :: !(Last TxSubmissionLogicVersion) + , pncTxSubmissionInitDelay :: !(Last TxSubmissionInitDelay) } deriving (Eq, Generic, Show) instance AdjustFilePaths PartialNodeConfiguration where @@ -413,6 +420,13 @@ instance FromJSON PartialNodeConfiguration where <$> v .:? "ResponderCoreAffinityPolicy" <*> v .:? "ForkPolicy" -- deprecated + pncTxSubmissionLogicVersion <- undefined -- TODO(10.7) + -- the following needs FromJSON TxSubmissionLogicVersion + -- pncTxSubmissionLogicVersion <- Last <$> v .:? "TxSubmissionLogicVersion" + pncTxSubmissionInitDelay <- undefined -- TODO(10.7) + -- the following needs FromJSON TxSubmissionInitDelay + -- pncTxSubmissionInitDelay <- Last <$> v .:? "TxSubmissionInitDelay" + pure PartialNodeConfiguration { pncProtocolConfig , pncSocketConfig = Last . Just $ SocketConfig mempty mempty mempty pncSocketPath @@ -460,6 +474,8 @@ instance FromJSON PartialNodeConfiguration where , pncPeerSharing , pncGenesisConfigFlags , pncResponderCoreAffinityPolicy + , pncTxSubmissionLogicVersion + , pncTxSubmissionInitDelay } where parseMempoolCapacityBytesOverride v = parseNoOverride <|> parseOverride @@ -725,6 +741,9 @@ defaultPartialNodeConfiguration = , 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 -- TODO(10.7) + , pncTxSubmissionInitDelay = Last $ Just NoTxSubmissionInitDelay -- TODO(10.7) } lastOption :: Parser a -> Parser (Last a) @@ -846,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, @@ -923,6 +945,8 @@ makeNodeConfiguration pnc = do , ncConsensusMode , ncGenesisConfig , ncResponderCoreAffinityPolicy + , ncTxSubmissionLogicVersion + , ncTxSubmissionInitDelay } ncProtocol :: NodeConfiguration -> Protocol diff --git a/cardano-node/src/Cardano/Node/Parsers.hs b/cardano-node/src/Cardano/Node/Parsers.hs index b6ec0c7441b..bea9fe5b95c 100644 --- a/cardano-node/src/Cardano/Node/Parsers.hs +++ b/cardano-node/src/Cardano/Node/Parsers.hs @@ -144,6 +144,8 @@ nodeRunParser = do , pncPeerSharing = mempty , pncGenesisConfigFlags = mempty , pncResponderCoreAffinityPolicy = mempty + , pncTxSubmissionLogicVersion = mempty + , pncTxSubmissionInitDelay = mempty } parseSocketPath :: Text -> Parser SocketPath diff --git a/cardano-node/src/Cardano/Node/Run.hs b/cardano-node/src/Cardano/Node/Run.hs index 45916630010..9586399789b 100644 --- a/cardano-node/src/Cardano/Node/Run.hs +++ b/cardano-node/src/Cardano/Node/Run.hs @@ -490,8 +490,8 @@ handleSimpleNode blockType runP tracers nc onKernel = do , rnPeerSharing = ncPeerSharing nc , rnGetUseBootstrapPeers = readTVar useBootstrapVar , rnFeatureFlags = mempty - , rnTxSubmissionLogicVersion = undefined -- TODO(10.7) -- ask Network - , rnTxSubmissionInitDelay = undefined -- TODO(10.7) -- ask Network + , rnTxSubmissionLogicVersion = ncTxSubmissionLogicVersion nc + , rnTxSubmissionInitDelay = ncTxSubmissionInitDelay nc } #ifdef UNIX -- initial `SIGHUP` handler, which only rereads the topology file but From 5ecf118e15b738417275f02c4ee1cbb27603cdf3 Mon Sep 17 00:00:00 2001 From: Georgy Lukyanov Date: Mon, 9 Mar 2026 09:43:38 +0100 Subject: [PATCH 20/39] Fix TODO in LedgerPeerSnapshot reading --- .../src/Cardano/Node/Configuration/TopologyP2P.hs | 11 ++++------- 1 file changed, 4 insertions(+), 7 deletions(-) diff --git a/cardano-node/src/Cardano/Node/Configuration/TopologyP2P.hs b/cardano-node/src/Cardano/Node/Configuration/TopologyP2P.hs index f8ccb8239d6..0d7467e4440 100644 --- a/cardano-node/src/Cardano/Node/Configuration/TopologyP2P.hs +++ b/cardano-node/src/Cardano/Node/Configuration/TopologyP2P.hs @@ -349,19 +349,16 @@ readTopologyFileOrError nc tr = <> Text.unpack err) pure --- TODO(10.7): what the resulting LedgerPeersKind should be? --- Probably we need to use the LedgerPeerSnapshotWithBlock type readPeerSnapshotFile :: PeerSnapshotFile -> IO (Either Text (LedgerPeerSnapshot BigLedgerPeers)) readPeerSnapshotFile (PeerSnapshotFile file) = do - _content <- first renderException <$> try (BS.readFile file) - -- return $ first handler $ content >>= eitherDecodeStrict - undefined -- TODO(10.7) + content <- first renderException <$> try (BS.readFile file) + return $ first handler $ content >>= eitherDecodeStrict where renderException :: IOException -> String renderException = displayException - _handler :: String -> Text - _handler msg = + handler :: String -> Text + handler msg = Text.pack $ "Cardano.Node.Configuration.TopologyP2P.readPeerSnapshotFile: " <> msg From a58854c8e1de58adeabfe961a226b382d969a8de Mon Sep 17 00:00:00 2001 From: Fraser Murray Date: Thu, 26 Jun 2025 13:20:20 +0100 Subject: [PATCH 21/39] [wip] node with kes-agent support --- cabal.project | 2 +- cardano-node/src/Cardano/Node/Parsers.hs | 30 ++++++++----- .../src/Cardano/Node/Protocol/Shelley.hs | 45 ++++++++++++------- cardano-node/src/Cardano/Node/Types.hs | 12 +++-- 4 files changed, 57 insertions(+), 32 deletions(-) diff --git a/cabal.project b/cabal.project index 1e2db6e8cf7..426d9bccfa7 100644 --- a/cabal.project +++ b/cabal.project @@ -14,7 +14,7 @@ repository cardano-haskell-packages -- you need to run if you change them index-state: , hackage.haskell.org 2026-02-17T10:15:41Z - , cardano-haskell-packages 2026-03-09T20:37:06Z + , cardano-haskell-packages 2026-03-09T20:37:06Z constraints: -- haskell.nix patch does not work for 1.6.8 diff --git a/cardano-node/src/Cardano/Node/Parsers.hs b/cardano-node/src/Cardano/Node/Parsers.hs index bea9fe5b95c..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 @@ -382,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/Shelley.hs b/cardano-node/src/Cardano/Node/Protocol/Shelley.hs index e52d6f39324..7da3969cd27 100644 --- a/cardano-node/src/Cardano/Node/Protocol/Shelley.hs +++ b/cardano-node/src/Cardano/Node/Protocol/Shelley.hs @@ -167,27 +167,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) - return [mkPraosLeaderCredentials opCert vrfSKey kesSKey] + -- TODO(10.7): 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 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 @@ -227,9 +238,9 @@ readLeaderCredentialsBulk ProtocolFilepaths { shelleyBulkCredsFile = mfp } = -> ExceptT PraosLeaderCredentialsError IO (ShelleyLeaderCredentials StandardCrypto) parseShelleyCredentials ShelleyCredentials { scCert, scVrf, scKes } = do mkPraosLeaderCredentials - <$> parseEnvelope scCert - <*> parseEnvelope scVrf - <*> parseEnvelope scKes + <$> undefined scCert -- parseEnvelope scCert + <*> undefined scVrf -- parseEnvelope scVrf + <*> undefined scKes -- parseEnvelope scKes readBulkFile :: Maybe FilePath @@ -251,29 +262,29 @@ 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" } -parseEnvelope :: +_parseEnvelope :: HasTextEnvelope a => (TextEnvelope, String) -> ExceptT PraosLeaderCredentialsError IO a -parseEnvelope (te, loc) = +_parseEnvelope (te, loc) = firstExceptT (FileError . Api.FileError loc) . hoistEither $ deserialiseFromTextEnvelope te diff --git a/cardano-node/src/Cardano/Node/Types.hs b/cardano-node/src/Cardano/Node/Types.hs index 240a8f4def1..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(..) @@ -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 From 15c3df7f0cd1ada7b40358bd865e05d9cee0b0e6 Mon Sep 17 00:00:00 2001 From: Georgy Lukyanov Date: Fri, 28 Nov 2025 15:11:25 +0100 Subject: [PATCH 22/39] kes-agent: fix compilation of tx-generator --- .../tx-generator/src/Cardano/TxGenerator/Setup/NodeConfig.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) 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 "" From 10cbaa11d0572778296e724b7502e1ec65859c2b Mon Sep 17 00:00:00 2001 From: Georgy Lukyanov Date: Tue, 2 Dec 2025 14:09:22 +0100 Subject: [PATCH 23/39] kes-agent: run kes-agent in cardano-testnet Allow testing block production with kes-agent via cardano-testnet --use-kes-agent --- cardano-testnet/src/Parsers/Cardano.hs | 5 + .../src/Testnet/Components/Configuration.hs | 2 +- cardano-testnet/src/Testnet/Process/Run.hs | 42 ++- cardano-testnet/src/Testnet/Runtime.hs | 240 ++++++++++++++++-- cardano-testnet/src/Testnet/Start/Cardano.hs | 32 ++- cardano-testnet/src/Testnet/Start/Types.hs | 11 +- cardano-testnet/src/Testnet/Types.hs | 13 +- 7 files changed, 310 insertions(+), 35 deletions(-) diff --git a/cardano-testnet/src/Parsers/Cardano.hs b/cardano-testnet/src/Parsers/Cardano.hs index d6797eb1ac4..9824d28c814 100644 --- a/cardano-testnet/src/Parsers/Cardano.hs +++ b/cardano-testnet/src/Parsers/Cardano.hs @@ -86,6 +86,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/Testnet/Components/Configuration.hs b/cardano-testnet/src/Testnet/Components/Configuration.hs index 22eb39bf314..7cf7e169954 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' 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/Runtime.hs b/cardano-testnet/src/Testnet/Runtime.hs index 1ef96d658e3..2b3ab34fe3b 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 @@ -54,7 +57,7 @@ import qualified Testnet.Ping as Ping import Testnet.Process.Run (ProcessError (..), initiateProcess) import Testnet.Process.RunIO (liftIOAnnotated, procNode) 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 @@ -228,33 +231,214 @@ startNode tp node ipv4 port _testnetMagic nodeCmd = GHC.withFrozenCallStack $ 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) +-- | Start a kes-agent for a particular node +startKESAgent + :: HasCallStack + => MonadResource m + => MonadCatch m + => MonadFail m + => MonadTest 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 $ 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 <- + H.evalIO $ + Ping.waitForSprocket + 120 -- timeout + 0.2 -- check interval + serviceSprocket + eControlSprocketError <- + H.evalIO $ + 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 + => MonadTest 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 + 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 a7225e28376..c6a6bead868 100644 --- a/cardano-testnet/src/Testnet/Start/Cardano.hs +++ b/cardano-testnet/src/Testnet/Start/Cardano.hs @@ -80,6 +80,7 @@ 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 RIO (MonadUnliftIO, RIO (..), runRIO, throwString, timeout) @@ -236,6 +237,7 @@ cardanoTestnet let CardanoTestnetOptions { cardanoEnableNewEpochStateLogging=enableNewEpochStateLogging , cardanoNodes + , cardanoKESSource } = testnetOptions nPools = cardanoNumPools testnetOptions nodeConfigFile = tmpAbsPath "configuration.yaml" @@ -329,8 +331,7 @@ cardanoTestnet RelayNodeOptions{} -> (Nothing, []) SpoNodeOptions{} -> (Just keys, shelleyCliArgs <> byronCliArgs) where - shelleyCliArgs = [ "--shelley-kes-key", nodePoolKeysDir "kes.skey" - , "--shelley-vrf-key", unFile $ signingKey poolNodeKeysVrf + shelleyCliArgs = [ "--shelley-vrf-key", unFile $ signingKey poolNodeKeysVrf , "--shelley-operational-certificate", nodePoolKeysDir "opcert.cert" ] byronCliArgs = [ "--byron-delegation-certificate", nodePoolKeysDir "byron-delegation.cert" @@ -338,6 +339,32 @@ cardanoTestnet ] keys@SpoNodeKeys{poolNodeKeysVrf} = mkTestnetNodeKeyPaths i + -- 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-jenesis.json is not in the future, + -- as otherwise we will trigger an underflow in kes-agent with a negative time difference. + H.threadDelay (startTimeOffsetSeconds * 1_000_000) + H.noteShowIO_ DTC.getCurrentTime + 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 + H.annotateShow $ "Could not start KES agent: " <> show e + pure ["--shelley-kes-key", nodePoolKeysDir "kes.skey"] + Right (TestnetKESAgent{kesAgentServiceSprocket}) -> + pure ["--shelley-kes-agent-socket", sprocketSystemName kesAgentServiceSprocket] + eRuntime <- runExceptT . retryOnAddressInUseError $ startNode (TmpAbsolutePath tmpAbsPath) nodeName testnetDefaultIpv4Address port testnetMagic $ [ "run" @@ -345,6 +372,7 @@ cardanoTestnet , "--topology", nodeDataDir "topology.json" , "--database-path", nodeDataDir "db" ] + <> kesSourceCliArg <> spoNodeCliArgs <> extraCliArgs nodeOptions diff --git a/cardano-testnet/src/Testnet/Start/Types.hs b/cardano-testnet/src/Testnet/Start/Types.hs index 9e3059b4ff6..ad41b4040e6 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(..) @@ -138,6 +139,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 @@ -186,6 +193,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 @@ -222,6 +230,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. @@ -236,7 +245,7 @@ instance Default GenesisOptions where def = GenesisOptions { genesisTestnetMagic = defaultTestnetMagic , genesisEpochLength = 500 - , genesisSlotLength = 0.1 + , genesisSlotLength = 1 -- 0.1 , genesisActiveSlotsCoeff = 0.05 } 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 - From 6d5e51b4d12a88c1beb579bdc9a27dd13512b2cf Mon Sep 17 00:00:00 2001 From: Georgy Lukyanov Date: Tue, 10 Mar 2026 12:06:48 +0100 Subject: [PATCH 24/39] [wip] kes-agent and cardano-testnet --- .../src/Testnet/Components/Configuration.hs | 4 ++-- cardano-testnet/src/Testnet/Process/RunIO.hs | 20 +++++++++++++++++++ cardano-testnet/src/Testnet/Runtime.hs | 19 +++++------------- cardano-testnet/src/Testnet/Start/Cardano.hs | 9 ++++----- 4 files changed, 31 insertions(+), 21 deletions(-) diff --git a/cardano-testnet/src/Testnet/Components/Configuration.hs b/cardano-testnet/src/Testnet/Components/Configuration.hs index 7cf7e169954..b072e38a545 100644 --- a/cardano-testnet/src/Testnet/Components/Configuration.hs +++ b/cardano-testnet/src/Testnet/Components/Configuration.hs @@ -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" ] diff --git a/cardano-testnet/src/Testnet/Process/RunIO.hs b/cardano-testnet/src/Testnet/Process/RunIO.hs index 69a5baeaeec..ed34b5a1fa3 100644 --- a/cardano-testnet/src/Testnet/Process/RunIO.hs +++ b/cardano-testnet/src/Testnet/Process/RunIO.hs @@ -10,6 +10,8 @@ module Testnet.Process.RunIO , execCli_ , mkExecConfig , procNode + , procKESAgent + , execKESAgentControl_ , procFlex , liftIOAnnotated ) where @@ -268,6 +270,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 2b3ab34fe3b..b3dca04f111 100644 --- a/cardano-testnet/src/Testnet/Runtime.hs +++ b/cardano-testnet/src/Testnet/Runtime.hs @@ -55,7 +55,7 @@ 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, TestnetKESAgent(..)) @@ -223,13 +223,6 @@ startNode tp node ipv4 port _testnetMagic nodeCmd = GHC.withFrozenCallStack $ do , nodeStderr = nodeStderrFile , nodeProcessHandle = hProcess } - 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 -- | Start a kes-agent for a particular node startKESAgent @@ -237,7 +230,6 @@ startKESAgent => MonadResource m => MonadCatch m => MonadFail m - => MonadTest m => TmpAbsolutePath -- ^ The temporary absolute path -> String @@ -251,7 +243,7 @@ startKESAgent tp node args = GHC.withFrozenCallStack $ do logDir = makeLogDir tp kesAgentStr= "kes-agent" - liftIO $ createDirectoryIfMissingNew_ $ logDir node kesAgentStr + _ <- liftIO $ createDirectoryIfMissingNew $ logDir node kesAgentStr void . liftIO $ createSubdirectoryIfMissingNew tempBaseAbsPath (socketDir node kesAgentStr) let nodeStdoutFile = logDir node kesAgentStr "stdout.log" @@ -280,7 +272,7 @@ startKESAgent tp node args = GHC.withFrozenCallStack $ do , "-c", tempBaseAbsPath controlSocketRelPath ] ++ args - kesAgentProcess <- newExceptT . fmap (first ExecutableRelatedFailure) . try $ procKESAgent kesAgentCmd + kesAgentProcess <- newExceptT . fmap (first ExecutableRelatedFailure) . try $ runRIO () $ procKESAgent kesAgentCmd (Just stdIn, _, _, hProcess, _) <- firstExceptT ProcessRelatedFailure $ initiateProcess @@ -301,13 +293,13 @@ startKESAgent tp node args = GHC.withFrozenCallStack $ do -- Wait for the service and control sockets to be created eServiceSprocketError <- - H.evalIO $ + liftIOAnnotated $ Ping.waitForSprocket 120 -- timeout 0.2 -- check interval serviceSprocket eControlSprocketError <- - H.evalIO $ + liftIOAnnotated $ Ping.waitForSprocket 120 -- timeout 0.2 -- check interval @@ -364,7 +356,6 @@ initAndStartKESAgent => MonadResource m => MonadCatch m => MonadFail m - => MonadTest m => TmpAbsolutePath -- ^ The temporary absolute path diff --git a/cardano-testnet/src/Testnet/Start/Cardano.hs b/cardano-testnet/src/Testnet/Start/Cardano.hs index c6a6bead868..df451ce769e 100644 --- a/cardano-testnet/src/Testnet/Start/Cardano.hs +++ b/cardano-testnet/src/Testnet/Start/Cardano.hs @@ -79,9 +79,9 @@ import Testnet.TxGenRuntime (startTxGenRuntime) 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) @@ -307,7 +307,7 @@ cardanoTestnet -- 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 @@ -346,8 +346,7 @@ cardanoTestnet UseKESSocket -> do -- wait startTimeOffsetSeconds so that the startTime from shelly-jenesis.json is not in the future, -- as otherwise we will trigger an underflow in kes-agent with a negative time difference. - H.threadDelay (startTimeOffsetSeconds * 1_000_000) - H.noteShowIO_ DTC.getCurrentTime + liftIOAnnotated $ threadDelay (startTimeOffsetSeconds * 1_000_000) kesAgent <- runExceptT $ initAndStartKESAgent (TmpAbsolutePath tmpAbsPath) nodeName TestnetKESAgentArgs{ tkaaShelleyGenesisFile = shelleyGenesisFile @@ -360,7 +359,7 @@ cardanoTestnet case kesAgent of Left e -> do -- TODO: fail if could not start KES agent - H.annotateShow $ "Could not start KES agent: " <> show e + 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] From af768edce389bdb6603bf27caba50c0f72c33286 Mon Sep 17 00:00:00 2001 From: Georgy Lukyanov Date: Tue, 10 Mar 2026 15:33:04 +0100 Subject: [PATCH 25/39] [wip] kes-agent: work on HasTextEnvelope TODOs --- .../src/Cardano/Node/Protocol/Shelley.hs | 38 ++++++++++++++++--- 1 file changed, 32 insertions(+), 6 deletions(-) diff --git a/cardano-node/src/Cardano/Node/Protocol/Shelley.hs b/cardano-node/src/Cardano/Node/Protocol/Shelley.hs index 7da3969cd27..61b33c9b41e 100644 --- a/cardano-node/src/Cardano/Node/Protocol/Shelley.hs +++ b/cardano-node/src/Cardano/Node/Protocol/Shelley.hs @@ -1,9 +1,13 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} +-- TODO(10.7): remove once the HasTextEnvelope instance is in the right place +{-# OPTIONS_GHC -Wno-orphans #-} module Cardano.Node.Protocol.Shelley ( mkSomeConsensusProtocolShelley @@ -30,13 +34,14 @@ import qualified Cardano.Crypto.Hash.Class as Crypto import Cardano.Ledger.BaseTypes (ProtVer (..), natVersion) import Cardano.Ledger.Keys (coerceKeyRole) import qualified Cardano.Ledger.Shelley.Genesis as Shelley +import qualified Cardano.Crypto.KES.Class as Crypto import Cardano.Node.Protocol.Types import Cardano.Node.Tracing.Era.HardFork () import Cardano.Node.Tracing.Era.Shelley () import Cardano.Node.Tracing.Formatting () import Cardano.Node.Tracing.Tracers.ChainDB () import Cardano.Node.Types -import Cardano.Protocol.Crypto (StandardCrypto) +import Cardano.Protocol.Crypto (StandardCrypto, KES) import Cardano.Tracing.OrphanInstances.HardFork () import Cardano.Tracing.OrphanInstances.Shelley () import qualified Ouroboros.Consensus.Cardano as Consensus @@ -45,6 +50,7 @@ import Ouroboros.Consensus.Shelley.Node (Nonce (..), ProtocolParamsShe ShelleyLeaderCredentials (..)) import Ouroboros.Consensus.HardFork.Combinator.AcrossEras () +import Data.String (IsString (..)) import Control.Exception (IOException) import Control.Monad import qualified Data.Aeson as Aeson @@ -227,6 +233,26 @@ data ShelleyCredentials , scKes :: (TextEnvelope, FilePath) } +instance HasTypeProxy (PraosCredentialsSource StandardCrypto) where + data AsType (PraosCredentialsSource StandardCrypto) = AsPraosCredentialsSource + proxyToAsType _ = AsPraosCredentialsSource + +instance ToCBOR (PraosCredentialsSource StandardCrypto) where + toCBOR = \case + PraosCredentialsUnsound ocert kesKey -> toCBOR (ocert, kesKey) + PraosCredentialsAgent _path -> + error "PraosCredentialsAgent cannot be serialized to CBOR" +instance FromCBOR (PraosCredentialsSource StandardCrypto) where + fromCBOR = do + (ocert, kesKey) <- fromCBOR + pure $ PraosCredentialsUnsound ocert kesKey +instance SerialiseAsCBOR (PraosCredentialsSource StandardCrypto) + +instance HasTextEnvelope (PraosCredentialsSource StandardCrypto) where + textEnvelopeType _ = + "PraosCredentialsSource_" + <> fromString (Crypto.algorithmNameKES (Proxy @(KES StandardCrypto))) + readLeaderCredentialsBulk :: ProtocolFilepaths -> ExceptT PraosLeaderCredentialsError IO [ShelleyLeaderCredentials StandardCrypto] @@ -238,9 +264,9 @@ readLeaderCredentialsBulk ProtocolFilepaths { shelleyBulkCredsFile = mfp } = -> ExceptT PraosLeaderCredentialsError IO (ShelleyLeaderCredentials StandardCrypto) parseShelleyCredentials ShelleyCredentials { scCert, scVrf, scKes } = do mkPraosLeaderCredentials - <$> undefined scCert -- parseEnvelope scCert - <*> undefined scVrf -- parseEnvelope scVrf - <*> undefined scKes -- parseEnvelope scKes + <$> parseEnvelope scCert -- TODO(10.7) + <*> parseEnvelope scVrf -- TODO(10.7) + <*> parseEnvelope scKes -- TODO(10.7) readBulkFile :: Maybe FilePath @@ -280,11 +306,11 @@ mkPraosLeaderCredentials shelleyLeaderCredentialsLabel = "Shelley" } -_parseEnvelope :: +parseEnvelope :: HasTextEnvelope a => (TextEnvelope, String) -> ExceptT PraosLeaderCredentialsError IO a -_parseEnvelope (te, loc) = +parseEnvelope (te, loc) = firstExceptT (FileError . Api.FileError loc) . hoistEither $ deserialiseFromTextEnvelope te From a33f7ff0c4b6bbdd8d800a25d26a5ff852a17765 Mon Sep 17 00:00:00 2001 From: Georgy Lukyanov Date: Tue, 10 Mar 2026 17:23:04 +0100 Subject: [PATCH 26/39] [wip] Fix Network traces --- cardano-node/src/Cardano/Tracing/Tracers.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/cardano-node/src/Cardano/Tracing/Tracers.hs b/cardano-node/src/Cardano/Tracing/Tracers.hs index 1ac6f70664a..a12d5c72490 100644 --- a/cardano-node/src/Cardano/Tracing/Tracers.hs +++ b/cardano-node/src/Cardano/Tracing/Tracers.hs @@ -838,10 +838,10 @@ mkConsensusTracers mbEKGDirect trSel verb tr nodeKern fStats = do TraceLabelPeer _ TraceTxInboundTerminated -> return () TraceLabelPeer _ (TraceTxInboundCanRequestMoreTxs _) -> return () TraceLabelPeer _ (TraceTxInboundCannotRequestMoreTxs _) -> return () - TraceLabelPeer _ (TraceTxInboundAddedToMempool _ _) -> undefined -- TODO(10.7) -- ask Network - TraceLabelPeer _ (TraceTxInboundRejectedFromMempool _ _) -> undefined -- TODO(10.7) -- ask Network - TraceLabelPeer _ (TraceTxInboundError _) -> undefined -- TODO(10.7) -- ask Network - TraceLabelPeer _ (TraceTxInboundDecision _) -> undefined -- TODO(10.7) -- ask Network + 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 From 2a59027547f0089c2d5448973d8d93709e43b888 Mon Sep 17 00:00:00 2001 From: Georgy Lukyanov Date: Tue, 10 Mar 2026 17:47:11 +0100 Subject: [PATCH 27/39] [wip] work on Network-related configuration parsing --- cardano-node/src/Cardano/Node/Configuration/POM.hs | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) diff --git a/cardano-node/src/Cardano/Node/Configuration/POM.hs b/cardano-node/src/Cardano/Node/Configuration/POM.hs index c6eb0883c61..fce67d5b230 100644 --- a/cardano-node/src/Cardano/Node/Configuration/POM.hs +++ b/cardano-node/src/Cardano/Node/Configuration/POM.hs @@ -420,12 +420,11 @@ instance FromJSON PartialNodeConfiguration where <$> v .:? "ResponderCoreAffinityPolicy" <*> v .:? "ForkPolicy" -- deprecated - pncTxSubmissionLogicVersion <- undefined -- TODO(10.7) - -- the following needs FromJSON TxSubmissionLogicVersion - -- pncTxSubmissionLogicVersion <- Last <$> v .:? "TxSubmissionLogicVersion" - pncTxSubmissionInitDelay <- undefined -- TODO(10.7) - -- the following needs FromJSON TxSubmissionInitDelay - -- pncTxSubmissionInitDelay <- Last <$> v .:? "TxSubmissionInitDelay" + let txSubmissionLogicVersion = pncTxSubmissionLogicVersion defaultPartialNodeConfiguration -- TODO(10.7) actually parse the configuration + let parseInitDelay = + maybe (pncTxSubmissionInitDelay defaultPartialNodeConfiguration) (fmap TxSubmissionInitDelay) + <$> v .:? "TxSubmissionInitDelay" + pncTxSubmissionInitDelay <- parseInitDelay pure PartialNodeConfiguration { pncProtocolConfig @@ -474,7 +473,7 @@ instance FromJSON PartialNodeConfiguration where , pncPeerSharing , pncGenesisConfigFlags , pncResponderCoreAffinityPolicy - , pncTxSubmissionLogicVersion + , pncTxSubmissionLogicVersion = txSubmissionLogicVersion , pncTxSubmissionInitDelay } where From 4fa347d9efe9587bf85667515bd55c83fd4d8090 Mon Sep 17 00:00:00 2001 From: Georgy Lukyanov Date: Tue, 10 Mar 2026 20:25:01 +0100 Subject: [PATCH 28/39] [wip] set localProvenance as Outbound --- cardano-node/src/Cardano/Node/Run.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/cardano-node/src/Cardano/Node/Run.hs b/cardano-node/src/Cardano/Node/Run.hs index 9586399789b..7e0b717a172 100644 --- a/cardano-node/src/Cardano/Node/Run.hs +++ b/cardano-node/src/Cardano/Node/Run.hs @@ -119,6 +119,7 @@ import Ouroboros.Network.PeerSelection.LedgerPeers.Type (LedgerPeerSna 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 @@ -957,7 +958,7 @@ producerAddresses RealNodeTopology { ntLocalRootPeersGroups diffusionMode = rootDiffusionMode lrp, peerAdvertise, extraLocalRootFlags = trustable lrp, - localProvenance = undefined -- TODO(10.7) -- ask Network + localProvenance = Outbound -- TODO(10.7) check this makes sense } ) ) From 4c9c26558b81a50ff8b483ddd82d0c091afbec00 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcin=20W=C3=B3jtowicz?= Date: Wed, 11 Mar 2026 07:15:07 +0100 Subject: [PATCH 29/39] network integration --- .../src/Cardano/Node/Configuration/POM.hs | 7 +- cardano-node/src/Cardano/Node/Run.hs | 73 ++++++++++++------- cardano-node/src/Cardano/Node/Startup.hs | 10 +-- .../Cardano/Node/Tracing/Tracers/Startup.hs | 52 +------------ 4 files changed, 55 insertions(+), 87 deletions(-) diff --git a/cardano-node/src/Cardano/Node/Configuration/POM.hs b/cardano-node/src/Cardano/Node/Configuration/POM.hs index fce67d5b230..09ebc4ac273 100644 --- a/cardano-node/src/Cardano/Node/Configuration/POM.hs +++ b/cardano-node/src/Cardano/Node/Configuration/POM.hs @@ -50,7 +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 (TxSubmissionLogicVersion(..), TxSubmissionInitDelay(..)) +import Ouroboros.Network.TxSubmission.Inbound.V2.Types + (TxSubmissionInitDelay(..), TxSubmissionLogicVersion(..), defaultTxSubmissionInitDelay) import Control.Concurrent (getNumCapabilities) import Control.Monad (unless, void, when) @@ -741,8 +742,8 @@ defaultPartialNodeConfiguration = -- 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 -- TODO(10.7) - , pncTxSubmissionInitDelay = Last $ Just NoTxSubmissionInitDelay -- TODO(10.7) + , pncTxSubmissionLogicVersion = Last $ Just TxSubmissionLogicV1 + , pncTxSubmissionInitDelay = Last $ Just defaultTxSubmissionInitDelay } lastOption :: Parser a -> Parser (Last a) diff --git a/cardano-node/src/Cardano/Node/Run.hs b/cardano-node/src/Cardano/Node/Run.hs index 7e0b717a172..8af5e115ebd 100644 --- a/cardano-node/src/Cardano/Node/Run.hs +++ b/cardano-node/src/Cardano/Node/Run.hs @@ -8,6 +8,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE PackageImports #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -103,11 +104,12 @@ import qualified Cardano.Network.PeerSelection.PeerSelectionActions as Cardano import qualified Cardano.Network.PeerSelection.Churn as Cardano.Churn import Cardano.Network.PeerSelection (NumberOfBigLedgerPeers (..)) -import Ouroboros.Network.Block (HeaderHash) +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 Cardano.Network.NodeToClient (LocalAddress (..), LocalSocket (..)) import Cardano.Network.NodeToNode (AcceptedConnectionsLimit (..), ConnectionId, @@ -264,7 +266,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) @@ -310,7 +312,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) @@ -383,12 +385,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 @@ -460,6 +463,7 @@ handleSimpleNode blockType runP tracers nc onKernel = do ledgerPeerSnapshotVar <- newTVarIO =<< updateLedgerPeerSnapshot (startupTracer tracers) nc + networkMagic (readTVar ledgerPeerSnapshotPathVar) (readTVar useLedgerVar) (const . pure $ ()) @@ -508,6 +512,7 @@ handleSimpleNode blockType runP tracers nc onKernel = do void $ updateLedgerPeerSnapshot (startupTracer tracers) nc + networkMagic (readTVar ledgerPeerSnapshotPathVar) (readTVar useLedgerVar) (writeTVar ledgerPeerSnapshotVar) @@ -553,9 +558,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 @@ -649,6 +654,7 @@ 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) @@ -658,10 +664,10 @@ installSigHUPHandler :: Tracer IO (StartupTrace blk) -> 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 @@ -671,6 +677,7 @@ installSigHUPHandler startupTracer kesAgentTracer blockType nc nodeKernel localR void $ updateLedgerPeerSnapshot startupTracer nc + networkMagic (readTVar ledgerPeerSnapshotPathVar) (readTVar useLedgerVar) (writeTVar ledgerPeerSnapshotVar) @@ -766,11 +773,14 @@ updateTopologyConfiguration startupTracer nc localRootsVar publicRootsVar useLed updateLedgerPeerSnapshot :: Tracer IO (StartupTrace blk) -> NodeConfiguration + -> NetworkMagic -> STM IO (Maybe PeerSnapshotFile) -> STM IO UseLedgerPeers -> (Maybe (LedgerPeerSnapshot BigLedgerPeers) -> STM IO ()) -> IO (Maybe (LedgerPeerSnapshot BigLedgerPeers)) -updateLedgerPeerSnapshot startupTracer (NodeConfiguration {ncConsensusMode}) readLedgerPeerPath readUseLedgerVar writeVar = do +updateLedgerPeerSnapshot startupTracer + (NodeConfiguration {ncConsensusMode}) + networkMagic readLedgerPeerPath readUseLedgerVar writeVar = do (mPeerSnapshotFile, useLedgerPeers) <- atomically $ (,) <$> readLedgerPeerPath <*> readUseLedgerVar @@ -784,30 +794,37 @@ updateLedgerPeerSnapshot startupTracer (NodeConfiguration {ncConsensusMode}) rea snapshotFile <- hoistMaybe mPeerSnapshotFile eSnapshot <- liftIO $ readPeerSnapshotFile snapshotFile - lps@(LedgerPeerSnapshotV2 (wOrigin, _)) <- - case ncConsensusMode of - GenesisMode -> - MaybeT $ hushM eSnapshot (trace . NetworkConfigUpdateError) - PraosMode -> - MaybeT $ hushM eSnapshot (trace . NetworkConfigUpdateWarning) + lps <- case eSnapshot of + Left e -> do + traceL $ NetworkConfigUpdateError e + case ncConsensusMode of + GenesisMode -> error "updateLedgerPeerSnapshot error" + PraosMode -> empty + Right lps -> pure lps + fileSlot <- case lps of + LedgerBigPeerSnapshotV23 pt magic _pools + | networkMagic == magic, BlockPoint { atSlot } <- pt -> pure atSlot + | GenesisPoint <- pt -> do + traceL $ NetworkConfigUpdateError "Invalid peer snapshot file" + error "updateLedgerPeerSnapshot error" + | otherwise -> do + traceL . NetworkConfigUpdateError . pack $ + "NetworkMagic " <> show networkMagic <> " doesn't match " + <> "peer snapshot NetworkMagic " <> show magic + error "updateLedgerPeerSnapshot error" + LedgerPeerSnapshotV2 {} -> do + traceL $ NetworkConfigUpdateError "Unsupported legacy peer snapshot version." + error "updateLedgerPeerSnapshot error" 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) diff --git a/cardano-node/src/Cardano/Node/Startup.hs b/cardano-node/src/Cardano/Node/Startup.hs index c0a570b7fef..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) @@ -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/Tracing/Tracers/Startup.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/Startup.hs index 3b89975d194..d6e259d72f6 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/Startup.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/Startup.hs @@ -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 {} = @@ -599,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 " <> showT slotNo <> " loaded." ppStartupInfoTrace NonP2PWarning = nonP2PWarningMessage From b363de9751601ba330f3e9543bfed53898dabf11 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Wed, 11 Mar 2026 09:32:58 +0100 Subject: [PATCH 30/39] Removed connectedPeers metrics John Lotoski found that it doesn't appear under any condition (GenesisMode, PraosMode). Now connection manager & peer selection exposes a more detailed metrics including `cardano_node_metrics_peerSelection_ActivePeers_int` --- .../src/Cardano/Node/Tracing/Tracers/Consensus.hs | 2 +- cardano-node/src/Cardano/Tracing/Tracers.hs | 10 ---------- cardano-tracer/configuration/metrics_help.json | 1 - 3 files changed, 1 insertion(+), 12 deletions(-) diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/Consensus.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/Consensus.hs index 2d0bc5988f7..dc1e4abaf28 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/Consensus.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/Consensus.hs @@ -683,7 +683,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 diff --git a/cardano-node/src/Cardano/Tracing/Tracers.hs b/cardano-node/src/Cardano/Tracing/Tracers.hs index a12d5c72490..3c2259aa9c1 100644 --- a/cardano-node/src/Cardano/Tracing/Tracers.hs +++ b/cardano-node/src/Cardano/Tracing/Tracers.hs @@ -1552,21 +1552,11 @@ 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 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", From b0b3057578ca98087614dfa0c791cc3c4f12aaa6 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Wed, 11 Mar 2026 09:35:35 +0100 Subject: [PATCH 31/39] Removed Cardano.Node.Tracing.Tracers.Diffusion Its imports are not necessary, so it can be removed. --- cardano-node/cardano-node.cabal | 1 - .../src/Cardano/Node/Tracing/Consistency.hs | 1 - .../src/Cardano/Node/Tracing/Documentation.hs | 1 - .../src/Cardano/Node/Tracing/Tracers.hs | 1 - .../Cardano/Node/Tracing/Tracers/Diffusion.hs | 20 ------------------- 5 files changed, 24 deletions(-) delete mode 100644 cardano-node/src/Cardano/Node/Tracing/Tracers/Diffusion.hs diff --git a/cardano-node/cardano-node.cabal b/cardano-node/cardano-node.cabal index 12e9dce2fac..a2395ed0db9 100644 --- a/cardano-node/cardano-node.cabal +++ b/cardano-node/cardano-node.cabal @@ -104,7 +104,6 @@ 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 diff --git a/cardano-node/src/Cardano/Node/Tracing/Consistency.hs b/cardano-node/src/Cardano/Node/Tracing/Consistency.hs index 014083c5235..0bf208a34ad 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Consistency.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Consistency.hs @@ -30,7 +30,6 @@ 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 () diff --git a/cardano-node/src/Cardano/Node/Tracing/Documentation.hs b/cardano-node/src/Cardano/Node/Tracing/Documentation.hs index 94300aa0813..f5653d99ebb 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Documentation.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Documentation.hs @@ -41,7 +41,6 @@ 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) diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers.hs index bf91b58ca69..f81340f475b 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers.hs @@ -30,7 +30,6 @@ 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 () 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 e05ae92b183..00000000000 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/Diffusion.hs +++ /dev/null @@ -1,20 +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 () where - -import Ouroboros.Network.Tracing () -import Ouroboros.Network.Tracing.PeerSelection () - From 34a3a5cebcc556b781f8428578574690fd31bc98 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Wed, 11 Mar 2026 09:51:17 +0100 Subject: [PATCH 32/39] Removed an unused import --- cardano-node/src/Cardano/Node/Tracing/Tracers/Consensus.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/Consensus.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/Consensus.hs index dc1e4abaf28..62eaeecef34 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/Consensus.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/Consensus.hs @@ -70,7 +70,6 @@ import qualified Ouroboros.Network.BlockFetch.ClientState as BlockFetch import Ouroboros.Network.BlockFetch.Decision import Ouroboros.Network.BlockFetch.Decision.Trace (TraceDecisionEvent (..)) import Ouroboros.Network.SizeInBytes (SizeInBytes (..)) -import Ouroboros.Network.Tracing () import Control.Monad (guard) import Data.Aeson (ToJSON, Value (..), toJSON, (.=)) From 0f73cb206e0a9ac6c83d5bbd4bee65e2732dbf85 Mon Sep 17 00:00:00 2001 From: Georgy Lukyanov Date: Wed, 11 Mar 2026 10:56:44 +0100 Subject: [PATCH 33/39] cardano-tracer: fix cardano-tracer-test-ext --- cardano-tracer/cardano-tracer.cabal | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/cardano-tracer/cardano-tracer.cabal b/cardano-tracer/cardano-tracer.cabal index 2fd20fea8b7..8db8bf7b5a5 100644 --- a/cardano-tracer/cardano-tracer.cabal +++ b/cardano-tracer/cardano-tracer.cabal @@ -402,6 +402,7 @@ test-suite cardano-tracer-test-ext build-depends: aeson , async , bytestring + , cardano-diffusion , cardano-tracer , cborg , containers @@ -417,7 +418,7 @@ test-suite cardano-tracer-test-ext , network , network-mux , optparse-applicative - , ouroboros-network:{api, framework, ouroboros-network} ^>= 1.0 + , ouroboros-network:{api, framework} , process , QuickCheck , tasty From 702b6921faf3810ed7c29a0670fd975176d95373 Mon Sep 17 00:00:00 2001 From: Georgy Lukyanov Date: Wed, 11 Mar 2026 11:29:15 +0100 Subject: [PATCH 34/39] trace-forward: fix tests --- .../test/Test/Trace/Forward/Protocol/DataPoint/Tests.hs | 7 ++++--- .../test/Test/Trace/Forward/Protocol/TraceObject/Tests.hs | 7 ++++--- trace-forward/trace-forward.cabal | 2 +- 3 files changed, 9 insertions(+), 7 deletions(-) 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 b55ecd8b437..a8ce2ed8cac 100644 --- a/trace-forward/trace-forward.cabal +++ b/trace-forward/trace-forward.cabal @@ -110,7 +110,7 @@ test-suite test , serialise , tasty , tasty-quickcheck - , typed-protocols + , typed-protocols:{typed-protocols, codec-properties} , text ghc-options: -rtsopts From 6563fb4bdf9660abb80a9837e15c2bf1c3d15015 Mon Sep 17 00:00:00 2001 From: Georgy Lukyanov Date: Wed, 11 Mar 2026 12:04:36 +0100 Subject: [PATCH 35/39] cardano-note: fix tests --- cardano-node/cardano-node.cabal | 1 + cardano-node/test/Test/Cardano/Node/POM.hs | 10 +++++++++- .../Cardano/Testnet/Test/DumpConfig.hs | 2 +- 3 files changed, 11 insertions(+), 2 deletions(-) diff --git a/cardano-node/cardano-node.cabal b/cardano-node/cardano-node.cabal index a2395ed0db9..061c70be8e7 100644 --- a/cardano-node/cardano-node.cabal +++ b/cardano-node/cardano-node.cabal @@ -245,6 +245,7 @@ test-suite cardano-node-test , cardano-crypto-class , cardano-crypto-wrapper , cardano-api + , cardano-diffusion:{api, cardano-diffusion} , cardano-protocol-tpraos , cardano-node , cardano-slotting diff --git a/cardano-node/test/Test/Cardano/Node/POM.hs b/cardano-node/test/Test/Cardano/Node/POM.hs index b3ac51bb555..eee56690822 100644 --- a/cardano-node/test/Test/Cardano/Node/POM.hs +++ b/cardano-node/test/Test/Cardano/Node/POM.hs @@ -8,7 +8,7 @@ module Test.Cardano.Node.POM import Cardano.Crypto.ProtocolMagic (RequiresNetworkMagic (..)) -import Cardano.Network.Diffusion.Configuration (defaultNumberOfBigLedgerPeers) +import Cardano.Network.Diffusion.Configuration (defaultNumberOfBigLedgerPeers, TxSubmissionLogicVersion(..)) import Cardano.Node.Configuration.LedgerDB import Cardano.Node.Configuration.POM import Cardano.Node.Configuration.Socket @@ -26,6 +26,8 @@ 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 + (defaultTxSubmissionInitDelay) import Data.Monoid (Last (..)) import Data.Text (Text) @@ -174,6 +176,8 @@ testPartialYamlConfig = , pncResponderCoreAffinityPolicy = mempty , pncLedgerDbConfig = mempty , pncEgressPollInterval = mempty + , pncTxSubmissionLogicVersion = mempty + , pncTxSubmissionInitDelay = mempty } -- | Example partial configuration theoretically created @@ -227,6 +231,8 @@ testPartialCliConfig = , pncResponderCoreAffinityPolicy = mempty , pncLedgerDbConfig = mempty , pncEgressPollInterval = mempty + , pncTxSubmissionLogicVersion = mempty + , pncTxSubmissionInitDelay = mempty } -- | Expected final NodeConfiguration @@ -286,6 +292,8 @@ eExpectedConfig = do , ncGenesisConfig = disableGenesisConfig , ncResponderCoreAffinityPolicy = NoResponderCoreAffinity , ncLedgerDbConfig = LedgerDbConfiguration DefaultNumOfDiskSnapshots DefaultSnapshotInterval DefaultQueryBatchSize V2InMemory noDeprecatedOptions + , ncTxSubmissionLogicVersion = TxSubmissionLogicV1 + , ncTxSubmissionInitDelay = defaultTxSubmissionInitDelay } -- ----------------------------------------------------------------------------- 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 From 9413ba0d67ca3ad481533a11967e58468c6b7d1d Mon Sep 17 00:00:00 2001 From: Georgy Lukyanov Date: Wed, 11 Mar 2026 13:42:40 +0100 Subject: [PATCH 36/39] [wip] Add SRP on Network --- cabal.project | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/cabal.project b/cabal.project index 426d9bccfa7..6c19b4d6251 100644 --- a/cabal.project +++ b/cabal.project @@ -141,3 +141,13 @@ source-repository-package --sha256: sha256-2YQ40E4QLJj0Zt4xlLqtEBypf3SfmxOPgjtksQFbhlc= subdir: cardano-cli + +source-repository-package + type: git + location: https://github.com/IntersectMBO/ouroboros-network + tag: b6b388aa2497bd689cf7f2cc7a826df1e4b22f2a + --sha256: sha256-iZqGWxLukOaDZkxQIAPHK856EnfPSYjH72xvyaYa9MI= + subdir: + ouroboros-network + network-mux + cardano-diffusion From f04b771590f092e0197de76ace0e0667879e3cb3 Mon Sep 17 00:00:00 2001 From: John Lotoski Date: Tue, 10 Mar 2026 15:52:07 -0500 Subject: [PATCH 37/39] musl: keep the static liuring.a file in postInstall --- flake.nix | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/flake.nix b/flake.nix index 0636e6fe72e..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 From ef3b98d90792091df180a1a7f42850c455cb4df9 Mon Sep 17 00:00:00 2001 From: Georgy Lukyanov Date: Wed, 11 Mar 2026 14:37:18 +0100 Subject: [PATCH 38/39] cardano-testnet: fix golden tests --- .../test/cardano-testnet-golden/files/golden/help.cli | 2 ++ .../cardano-testnet-golden/files/golden/help/cardano.cli | 5 ++++- .../cardano-testnet-golden/files/golden/help/create-env.cli | 5 ++++- 3 files changed, 10 insertions(+), 2 deletions(-) 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 d3921a1cf8d..0056ef25260 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 | --run-tx-generator] [--output-dir DIRECTORY] + [--use-kes-agent] [--testnet-magic INT] [--epoch-length SLOTS] [--slot-length SECONDS] @@ -23,6 +24,7 @@ Usage: cardano-testnet create-env [--num-pool-nodes COUNT] [--enable-new-epoch-state-logging] [--generate-tx-generator-config | --run-tx-generator] [--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 cc26e43d032..b2152080883 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 | --run-tx-generator] [--output-dir DIRECTORY] + [--use-kes-agent] [--testnet-magic INT] [--epoch-length SLOTS] [--slot-length SECONDS] @@ -38,11 +39,13 @@ 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) --slot-length SECONDS Slot length. Ignored if a node environment is passed. - (default: 0.1) + (default: 1.0) --active-slots-coeff DOUBLE Active slots coefficient. Ignored if a node environment is passed. (default: 5.0e-2) 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 7e079ee325d..dabc1fd9cb6 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 | --run-tx-generator] [--output-dir DIRECTORY] + [--use-kes-agent] [--testnet-magic INT] [--epoch-length SLOTS] [--slot-length SECONDS] @@ -38,11 +39,13 @@ 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) --slot-length SECONDS Slot length. Ignored if a node environment is passed. - (default: 0.1) + (default: 1.0) --active-slots-coeff DOUBLE Active slots coefficient. Ignored if a node environment is passed. (default: 5.0e-2) From 8633bf29e880c0f5f4c781eea63771e41bb5283e Mon Sep 17 00:00:00 2001 From: Georgy Lukyanov Date: Wed, 11 Mar 2026 15:47:33 +0100 Subject: [PATCH 39/39] [wip] work on cardano-testnet + kes-agent --- cardano-testnet/src/Testnet/Start/Cardano.hs | 72 ++++++++++---------- 1 file changed, 35 insertions(+), 37 deletions(-) diff --git a/cardano-testnet/src/Testnet/Start/Cardano.hs b/cardano-testnet/src/Testnet/Start/Cardano.hs index df451ce769e..71a6bf19ac8 100644 --- a/cardano-testnet/src/Testnet/Start/Cardano.hs +++ b/cardano-testnet/src/Testnet/Start/Cardano.hs @@ -326,43 +326,42 @@ cardanoTestnet 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-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 - - -- 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-jenesis.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] + keys@SpoNodeKeys{poolNodeKeysVrf} = mkTestnetNodeKeyPaths i + pure (Just keys, kesSourceCliArg <> shelleyCliArgs <> byronCliArgs) eRuntime <- runExceptT . retryOnAddressInUseError $ startNode (TmpAbsolutePath tmpAbsPath) nodeName testnetDefaultIpv4Address port testnetMagic $ @@ -371,7 +370,6 @@ cardanoTestnet , "--topology", nodeDataDir "topology.json" , "--database-path", nodeDataDir "db" ] - <> kesSourceCliArg <> spoNodeCliArgs <> extraCliArgs nodeOptions