From f9fd8b71152e1564be14d242f5fd7f23efdba023 Mon Sep 17 00:00:00 2001 From: Georgy Lukyanov Date: Fri, 6 Feb 2026 10:45:36 +0100 Subject: [PATCH 01/27] Bump Hackage and CHaP index states --- cabal.project | 5 ++--- flake.lock | 12 ++++++------ 2 files changed, 8 insertions(+), 9 deletions(-) diff --git a/cabal.project b/cabal.project index 57901992a17..459b71ff679 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 2025-09-29T13:55:56Z - , cardano-haskell-packages 2026-02-09T17:36:58Z + , hackage.haskell.org 2026-02-17T10:15:41Z + , cardano-haskell-packages 2026-02-17T21:19:19Z constraints: crypton-x509-system ==1.6.7 @@ -75,4 +75,3 @@ 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. - diff --git a/flake.lock b/flake.lock index 79661f99420..de1ba351ad7 100644 --- a/flake.lock +++ b/flake.lock @@ -3,11 +3,11 @@ "CHaP": { "flake": false, "locked": { - "lastModified": 1770667523, - "narHash": "sha256-NTZeJP2ETCS/9hAUottupnhI7b5RmYKiB4jJqhyvHhs=", + "lastModified": 1771469693, + "narHash": "sha256-y1tKTheSvtSi00SC0QjX7ApRHwQ7P2a7EmWmu5AnC2o=", "owner": "intersectmbo", "repo": "cardano-haskell-packages", - "rev": "da32b7c7513f0f5383d233a0f97e03538b0c7726", + "rev": "61c000dd1c4db468676d5a08d1d43f899d73bdf9", "type": "github" }, "original": { @@ -273,11 +273,11 @@ "hackageNix_2": { "flake": false, "locked": { - "lastModified": 1768311066, - "narHash": "sha256-g2WdhScDFQNkJs2GBjWIGG49upIQuBshgaeAxddujrE=", + "lastModified": 1771502057, + "narHash": "sha256-XwoLg6wftnU50KPn5jY4jtuGulyNPyspB4lSDSrmR1g=", "owner": "input-output-hk", "repo": "hackage.nix", - "rev": "adbb09d536f3a2797f9bd0762a0577a30672b8b1", + "rev": "e6bb05af1f45a616f534798263a5a13f2299e3bc", "type": "github" }, "original": { From 0a13897631de07ecfc0d62dc5a23e052e4fb6c71 Mon Sep 17 00:00:00 2001 From: Georgy Lukyanov Date: Mon, 5 Jan 2026 14:53:33 +0100 Subject: [PATCH 02/27] [wip] Add SRPs --- cabal.project | 105 +++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 104 insertions(+), 1 deletion(-) diff --git a/cabal.project b/cabal.project index 459b71ff679..766e47eda0e 100644 --- a/cabal.project +++ b/cabal.project @@ -35,11 +35,15 @@ packages: trace-resources trace-forward + -- ../network/ouroboros-network + -- ../network/cardano-diffusion + -- ../network/network-mux + -- Needed when cross compiling extra-packages: alex program-options - ghc-options: -Werror + -- ghc-options: -Werror test-show-details: direct @@ -75,3 +79,102 @@ 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: bd2c3fc558c8b053b03f25a84fc02e26dd17d927 + --sha256: sha256-JCzOtN0/eQob9IneXjihwxDgWZlSZ2ZdIkz2qBPhtU8= + 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: 3508bb44011c501099b5b1692dd1ebe7c5e9c1cc + --sha256: sha256-Xg+s7ZR00HIdSPCuBH1NUp0GbuSfa7QM4bXOZDfUoeg= + subdir: + ouroboros-consensus + ouroboros-consensus-cardano + ouroboros-consensus-diffusion + ouroboros-consensus-protocol + strict-sop-core + sop-extras + +-- Network main several commits past the o-n-24 release +source-repository-package + type: git + location: https://github.com/IntersectMBO/ouroboros-network + tag: fdb48717260acf4414b73fc5186f1be11c066d9a + --sha256: sha256-7ImdsdRwiQaFZduxYd6CMHwrho1XkieDXX1oVXX6Tqk= + subdir: + ouroboros-network + cardano-diffusion + network-mux + +-- TODO: remove once plutus packages are released +source-repository-package + type: git + location: https://github.com/IntersectMBO/plutus + tag: 9b47adbd2e0cf9b4749e53f5138b3817eaa5f0b4 + --sha256: sha256-wqriBVjkC1mW/Mp+FButFNBRClync9cDwZtgG+a6lb0= + subdir: + plutus-core + plutus-ledger-api + +-- Network main several commits past the o-n-24 release +source-repository-package + type: git + location: https://github.com/input-output-hk/kes-agent + tag: 84c98f369d58e86cf7a339ccce583252d4cb5773 + --sha256: sha256-0RsKmpXcJfO4bFos5Mx71lUye3bo7g6lc+gXCaKzxJs= + subdir: + kes-agent + kes-agent-crypto + +source-repository-package + type: git + location: https://github.com/IntersectMBO/cardano-api + tag: 52fefc49d1fa369708ebf3563cd7141a69fd4be6 + --sha256: sha256-/sodH3WqJzf5oCASbuUY5wC6tsMgjJVTzhryqHu6oGM= + subdir: + cardano-api + +source-repository-package + type: git + location: https://github.com/IntersectMBO/cardano-cli + tag: a8f913f99bd11c3eead3e5a924610167883a5e64 + --sha256: sha256-QxcDa45F6W/DXq0epm7+Oc6Y+oLnkG5ibeHL2nE5hPA= + subdir: + cardano-cli + +source-repository-package + type: git + location: https://github.com/input-output-hk/ekg-forward + tag: 8651aff14954803c61d81482914c672054b0ac06 + --sha256: sha256-ZrA7hoTbvZVJ4tg/A0zEXGBpnLIDPHV4YNQF2MvKYcQ= + subdir: + . From aa9f63c4b762009bd0952e405c7d9cdb436e9ebd Mon Sep 17 00:00:00 2001 From: Georgy Lukyanov Date: Thu, 12 Feb 2026 19:36:32 +0100 Subject: [PATCH 03/27] 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 20393409a69..44714a285ff 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 dac88bc83a3..2e0f174c7b8 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.23 , cardano-binary , cardano-cli ^>= 10.15 - , 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 dfddd4183ef..bce17dea2bf 100644 --- a/cardano-testnet/cardano-testnet.cabal +++ b/cardano-testnet/cardano-testnet.cabal @@ -43,7 +43,7 @@ library , bytestring , cardano-api ^>= 10.23 , cardano-cli:{cardano-cli, cardano-cli-test-lib} ^>= 10.15 - , 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 3c7fd16146a0c05c0bcc8b0f28b9c71d3e59313b Mon Sep 17 00:00:00 2001 From: Georgy Lukyanov Date: Thu, 12 Feb 2026 19:36:48 +0100 Subject: [PATCH 04/27] 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 2c523934fa7..d93b8b04cf3 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 b4012682fa9fec9f32fe50fd258962a2319644f3 Mon Sep 17 00:00:00 2001 From: Georgy Lukyanov Date: Mon, 5 Jan 2026 14:52:58 +0100 Subject: [PATCH 05/27] Bump Plutus and API --- bench/plutus-scripts-bench/plutus-scripts-bench.cabal | 8 ++++---- bench/tx-generator/tx-generator.cabal | 2 +- cardano-node-chairman/cardano-node-chairman.cabal | 4 ++-- cardano-node/cardano-node.cabal | 6 +++--- cardano-submit-api/cardano-submit-api.cabal | 2 +- cardano-testnet/cardano-testnet.cabal | 2 +- 6 files changed, 12 insertions(+), 12 deletions(-) diff --git a/bench/plutus-scripts-bench/plutus-scripts-bench.cabal b/bench/plutus-scripts-bench/plutus-scripts-bench.cabal index 37bfbb5cd8a..f23c316e1d8 100644 --- a/bench/plutus-scripts-bench/plutus-scripts-bench.cabal +++ b/bench/plutus-scripts-bench/plutus-scripts-bench.cabal @@ -82,10 +82,10 @@ library -- IOG dependencies -------------------------- build-depends: - , cardano-api ^>=10.23 - , plutus-ledger-api ^>=1.57 - , plutus-tx ^>=1.57 - , plutus-tx-plugin ^>=1.57 + , cardano-api ^>=10.24 + , plutus-ledger-api ^>=1.58 + , plutus-tx ^>=1.58 + , plutus-tx-plugin ^>=1.58 ------------------------ -- Non-IOG dependencies diff --git a/bench/tx-generator/tx-generator.cabal b/bench/tx-generator/tx-generator.cabal index d3116179117..c14e224c186 100644 --- a/bench/tx-generator/tx-generator.cabal +++ b/bench/tx-generator/tx-generator.cabal @@ -108,7 +108,7 @@ library , attoparsec-aeson , base16-bytestring , bytestring - , cardano-api ^>= 10.23 + , cardano-api ^>= 10.24 , cardano-binary , cardano-cli ^>= 10.15 , cardano-crypto-class diff --git a/cardano-node-chairman/cardano-node-chairman.cabal b/cardano-node-chairman/cardano-node-chairman.cabal index 44714a285ff..162e7495ecb 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 d93b8b04cf3..a2ccf28d074 100644 --- a/cardano-node/cardano-node.cabal +++ b/cardano-node/cardano-node.cabal @@ -138,8 +138,8 @@ library , async , base16-bytestring , bytestring - , cardano-api ^>= 10.23 - , cardano-crypto-class ^>=2.2.3.2 + , cardano-api ^>= 10.24 + , 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 diff --git a/cardano-submit-api/cardano-submit-api.cabal b/cardano-submit-api/cardano-submit-api.cabal index 2e0f174c7b8..95c24078767 100644 --- a/cardano-submit-api/cardano-submit-api.cabal +++ b/cardano-submit-api/cardano-submit-api.cabal @@ -39,7 +39,7 @@ library , aeson , async , bytestring - , cardano-api ^>= 10.23 + , cardano-api ^>= 10.24 , cardano-binary , cardano-cli ^>= 10.15 , cardano-crypto-class ^>=2.3 diff --git a/cardano-testnet/cardano-testnet.cabal b/cardano-testnet/cardano-testnet.cabal index bce17dea2bf..dc79608cd3a 100644 --- a/cardano-testnet/cardano-testnet.cabal +++ b/cardano-testnet/cardano-testnet.cabal @@ -41,7 +41,7 @@ library , annotated-exception , ansi-terminal , bytestring - , cardano-api ^>= 10.23 + , cardano-api ^>= 10.24 , cardano-cli:{cardano-cli, cardano-cli-test-lib} ^>= 10.15 , cardano-crypto-class ^>=2.3 , cardano-crypto-wrapper From caf54707e2bb5ce8866c98d0a16badcfabdd9779 Mon Sep 17 00:00:00 2001 From: Georgy Lukyanov Date: Fri, 6 Feb 2026 10:50:10 +0100 Subject: [PATCH 06/27] Bump Network packages --- bench/locli/locli.cabal | 2 +- bench/tx-generator/tx-generator.cabal | 5 +---- .../cardano-node-chairman.cabal | 3 +-- cardano-node/cardano-node.cabal | 11 ++++------- cardano-submit-api/cardano-submit-api.cabal | 2 +- cardano-testnet/cardano-testnet.cabal | 5 ++--- cardano-tracer/cardano-tracer.cabal | 16 +++++----------- trace-forward/trace-forward.cabal | 6 ++---- 8 files changed, 17 insertions(+), 33 deletions(-) diff --git a/bench/locli/locli.cabal b/bench/locli/locli.cabal index 21b5d941ee3..3e323b2fb34 100644 --- a/bench/locli/locli.cabal +++ b/bench/locli/locli.cabal @@ -127,7 +127,7 @@ library , hashable , optparse-applicative , ouroboros-consensus - , ouroboros-network-api ^>= 0.16 + , ouroboros-network:api ^>= 0.24 , 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 c14e224c186..177d2d4bedb 100644 --- a/bench/tx-generator/tx-generator.cabal +++ b/bench/tx-generator/tx-generator.cabal @@ -140,10 +140,7 @@ library , 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-network:{api, framework, 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 162e7495ecb..a4d1e4c9c08 100644 --- a/cardano-node-chairman/cardano-node-chairman.cabal +++ b/cardano-node-chairman/cardano-node-chairman.cabal @@ -53,8 +53,7 @@ executable cardano-node-chairman , optparse-applicative , ouroboros-consensus , ouroboros-consensus-cardano - , ouroboros-network-api - , ouroboros-network-protocols + , ouroboros-network:{api, protocols} , text , time diff --git a/cardano-node/cardano-node.cabal b/cardano-node/cardano-node.cabal index a2ccf28d074..331533274ea 100644 --- a/cardano-node/cardano-node.cabal +++ b/cardano-node/cardano-node.cabal @@ -187,12 +187,10 @@ library , optparse-applicative , ouroboros-consensus >=0.30.0.1 && <0.31 , ouroboros-consensus-cardano ^>= 0.26 - , ouroboros-consensus-diffusion ^>= 0.26 + , ouroboros-consensus-diffusion ^>= 0.24 , 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-network:{api, ouroboros-network, orphan-instances, framework, protocols} ^>= 0.24 + , cardano-diffusion:{api, cardano-diffusion} ^>=0.1 , prettyprinter , prettyprinter-ansi-terminal , psqueues @@ -266,8 +264,7 @@ test-suite cardano-node-test , ouroboros-consensus , ouroboros-consensus-cardano , ouroboros-consensus-diffusion - , ouroboros-network:{ouroboros-network, cardano-diffusion} - , ouroboros-network-api + , 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 95c24078767..fbb3c5e749c 100644 --- a/cardano-submit-api/cardano-submit-api.cabal +++ b/cardano-submit-api/cardano-submit-api.cabal @@ -50,7 +50,7 @@ library , network , optparse-applicative-fork , ouroboros-consensus-cardano - , ouroboros-network-protocols + , 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 dc79608cd3a..02e1991169e 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,7 @@ library , network , network-mux , optparse-applicative-fork - , ouroboros-network ^>= 0.22.6 - , ouroboros-network-api + , ouroboros-network:{api, ouroboros-network} ^>= 0.24 , prettyprinter , process , resourcet diff --git a/cardano-tracer/cardano-tracer.cabal b/cardano-tracer/cardano-tracer.cabal index 33f5cd51571..432b32d966a 100644 --- a/cardano-tracer/cardano-tracer.cabal +++ b/cardano-tracer/cardano-tracer.cabal @@ -186,9 +186,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} ^>= 0.24 , signal , slugify , smtp-mail ^>= 0.5 @@ -254,8 +252,7 @@ library demo-forwarder-lib , network , network-mux , optparse-applicative - , ouroboros-network-api - , ouroboros-network-framework + , ouroboros-network:{api, framework, ouroboros-network} , tasty-quickcheck , text , time @@ -299,7 +296,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 +357,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 +416,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} ^>= 0.24 , process , QuickCheck , tasty diff --git a/trace-forward/trace-forward.cabal b/trace-forward/trace-forward.cabal index d185f08ff19..cd1309aad84 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} ^>= 0.24 , 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 30608d40cdb3135478eefdf859310d06f2cee9b5 Mon Sep 17 00:00:00 2001 From: Georgy Lukyanov Date: Fri, 6 Feb 2026 11:01:54 +0100 Subject: [PATCH 07/27] 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 331533274ea..7dc0541ccaf 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 4455432ca4e0593791d29764996c6c8f661526c1 Mon Sep 17 00:00:00 2001 From: Georgy Lukyanov Date: Tue, 6 Jan 2026 10:04:21 +0100 Subject: [PATCH 08/27] 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 fb40f72dc8e285098791c7069ff42c7aaebe048d Mon Sep 17 00:00:00 2001 From: Georgy Lukyanov Date: Tue, 10 Feb 2026 09:53:57 +0100 Subject: [PATCH 09/27] nix: remove haddock override for ouroboros-network-framework This packages does not exist anymore --- nix/haskell.nix | 6 ------ 1 file changed, 6 deletions(-) diff --git a/nix/haskell.nix b/nix/haskell.nix index ef51039c78b..a7d02500d89 100644 --- a/nix/haskell.nix +++ b/nix/haskell.nix @@ -358,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"; From bf613b23fc06a3e04c0fbb5ad1505656cedf90be Mon Sep 17 00:00:00 2001 From: Georgy Lukyanov Date: Tue, 10 Feb 2026 11:57:21 +0100 Subject: [PATCH 10/27] 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 cd1309aad84..4e26875dd60 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 9ea1dadc621623307f8026b56895bc11e5d719b9 Mon Sep 17 00:00:00 2001 From: Georgy Lukyanov Date: Tue, 10 Feb 2026 12:34:22 +0100 Subject: [PATCH 11/27] 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 | 2 +- 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, 38 insertions(+), 41 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..8a9322ed74f 100644 --- a/cardano-node/test/Test/Cardano/Node/POM.hs +++ b/cardano-node/test/Test/Cardano/Node/POM.hs @@ -23,7 +23,7 @@ import Ouroboros.Consensus.Storage.LedgerDB.Snapshots (NumOfDiskSnapsh SnapshotInterval (..)) import Ouroboros.Network.Block (SlotNo (..)) import Ouroboros.Network.Diffusion.Configuration (ConsensusMode (..)) -import Ouroboros.Network.NodeToNode (AcceptedConnectionsLimit (..), +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 dc85773a809d7986169989f39b07469c02259cb5 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 12/27] 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 f9df5682a8e5f165f0193a43aca918d293d53a74 Mon Sep 17 00:00:00 2001 From: Federico Mastellone Date: Thu, 12 Feb 2026 22:01:24 +0000 Subject: [PATCH 13/27] [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 --- cardano-node/cardano-node.cabal | 8 +- .../Cardano/Node/Configuration/LedgerDB.hs | 76 +- .../src/Cardano/Node/Configuration/POM.hs | 6 +- .../Cardano/Node/Configuration/TopologyP2P.hs | 17 +- cardano-node/src/Cardano/Node/Run.hs | 5 +- .../src/Cardano/Node/TraceConstraints.hs | 12 +- .../src/Cardano/Node/Tracing/Consistency.hs | 30 +- .../src/Cardano/Node/Tracing/Documentation.hs | 22 +- .../src/Cardano/Node/Tracing/Era/HardFork.hs | 12 +- .../src/Cardano/Node/Tracing/Era/Shelley.hs | 117 +- .../src/Cardano/Node/Tracing/Render.hs | 7 +- .../src/Cardano/Node/Tracing/StateRep.hs | 2 +- .../src/Cardano/Node/Tracing/Tracers.hs | 55 +- .../Cardano/Node/Tracing/Tracers/ChainDB.hs | 668 ++++-- .../Cardano/Node/Tracing/Tracers/Consensus.hs | 31 +- .../Cardano/Node/Tracing/Tracers/Diffusion.hs | 979 +------- .../Node/Tracing/Tracers/LedgerMetrics.hs | 6 +- .../Node/Tracing/Tracers/NodeToClient.hs | 137 +- .../src/Cardano/Node/Tracing/Tracers/P2P.hs | 2055 +---------------- .../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 | 213 +- .../Tracing/OrphanInstances/Shelley.hs | 114 +- cardano-node/src/Cardano/Tracing/Tracers.hs | 109 +- 27 files changed, 1083 insertions(+), 3731 deletions(-) diff --git a/cardano-node/cardano-node.cabal b/cardano-node/cardano-node.cabal index 7dc0541ccaf..d4b50bce1cf 100644 --- a/cardano-node/cardano-node.cabal +++ b/cardano-node/cardano-node.cabal @@ -139,6 +139,7 @@ library , base16-bytestring , bytestring , cardano-api ^>= 10.24 + , cardano-data , cardano-crypto-class ^>=2.3 , cardano-crypto-wrapper , cardano-git-rev ^>=0.2.2 @@ -165,7 +166,6 @@ library , ekg-wai , ekg-core , filepath - , formatting , generic-data , hashable , hostname @@ -185,12 +185,12 @@ library , network-mux >= 0.8 , nothunks , optparse-applicative - , ouroboros-consensus >=0.30.0.1 && <0.31 + , ouroboros-consensus:{ouroboros-consensus, ouroboros-consensus-lmdb, ouroboros-consensus-lsm} ^>= 0.28 , ouroboros-consensus-cardano ^>= 0.26 , ouroboros-consensus-diffusion ^>= 0.24 , ouroboros-consensus-protocol - , ouroboros-network:{api, ouroboros-network, orphan-instances, framework, protocols} ^>= 0.24 - , cardano-diffusion:{api, cardano-diffusion} ^>=0.1 + , ouroboros-network:{api, ouroboros-network, orphan-instances, framework, protocols, framework-tracing, tracing} ^>= 0.24 + , cardano-diffusion:{api, cardano-diffusion, orphan-instances} ^>=0.1 , prettyprinter , prettyprinter-ansi-terminal , psqueues 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..4ceaa78d657 100644 --- a/cardano-node/src/Cardano/Node/Configuration/POM.hs +++ b/cardano-node/src/Cardano/Node/Configuration/POM.hs @@ -500,9 +500,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 +507,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 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/Run.hs b/cardano-node/src/Cardano/Node/Run.hs index 4921e7733cd..8cc431ec2bf 100644 --- a/cardano-node/src/Cardano/Node/Run.hs +++ b/cardano-node/src/Cardano/Node/Run.hs @@ -68,7 +68,7 @@ import Cardano.Tracing.Tracers 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 +79,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 () @@ -569,7 +568,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 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/Consistency.hs b/cardano-node/src/Cardano/Node/Tracing/Consistency.hs index a3213ff21b1..d860452dbbf 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 @@ -34,9 +39,6 @@ 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 +70,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 +91,13 @@ 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 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 +284,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 @@ -309,7 +311,7 @@ getAllNamespaces = peerSelectionNS = map (nsGetTuple . nsReplacePrefix ["Net", "PeerSelection", "Selection"]) (allNamespaces :: [Namespace - (TracePeerSelection Cardano.DebugPeerSelectionState PeerTrustable (Cardano.PublicRootPeers.ExtraPeers Socket.SockAddr) Socket.SockAddr)]) + (TracePeerSelection Cardano.DebugPeerSelectionState PeerTrustable (Cardano.PublicRootPeers.ExtraPeers Socket.SockAddr) Cardano.ExtraTrace Socket.SockAddr)]) debugPeerSelectionNS = map (nsGetTuple . nsReplacePrefix ["Net", "PeerSelection", "Initiator"]) (allNamespaces :: [Namespace @@ -322,9 +324,6 @@ getAllNamespaces = ["Net", "PeerSelection", "Counters"]) (allNamespaces :: [Namespace (PeerSelectionCounters (Cardano.ExtraPeerSelectionSetsWithSizes Socket.SockAddr))]) - churnCountersNS = map (nsGetTuple . nsReplacePrefix - ["Net", "Churn"]) - (allNamespaces :: [Namespace ChurnCounters]) peerSelectionActionsNS = map (nsGetTuple . nsReplacePrefix ["Net", "PeerSelection", "Actions"]) (allNamespaces :: [Namespace @@ -439,7 +438,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..9a408100629 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Documentation.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Documentation.hs @@ -84,9 +84,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 +103,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 +116,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 +161,6 @@ parseTraceDocumentationCmd = ] ) -deriving instance Generic UnversionedProtocol -deriving instance Generic UnversionedProtocolData - instance ToJSON UnversionedProtocol instance ToJSON UnversionedProtocolData @@ -585,7 +582,7 @@ docTracersFirstPhase condConfigFileName = do ["Net", "PeerSelection", "Selection"] configureTracers configReflection trConfig [peerSelectionTr] peerSelectionTrDoc <- documentTracer (peerSelectionTr :: - Logging.Trace IO (TracePeerSelection Cardano.DebugPeerSelectionState PeerTrustable (Cardano.PublicRootPeers.ExtraPeers Socket.SockAddr) Socket.SockAddr)) + Logging.Trace IO (TracePeerSelection Cardano.DebugPeerSelectionState PeerTrustable (Cardano.PublicRootPeers.ExtraPeers Socket.SockAddr) Cardano.ExtraTrace Socket.SockAddr)) debugPeerSelectionTr <- mkCardanoTracer trBase trForward mbTrEKG @@ -608,12 +605,6 @@ docTracersFirstPhase condConfigFileName = do 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) - peerSelectionActionsTr <- mkCardanoTracer trBase trForward mbTrEKG ["Net", "PeerSelection", "Actions"] @@ -756,7 +747,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..8d13659ec7d 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Era/Shelley.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Era/Shelley.hs @@ -36,6 +36,7 @@ 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 @@ -76,6 +77,7 @@ import Data.Set (Set) import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text.Encoding as Text +import qualified Data.Set.NonEmpty as NonEmptySet {- HLINT ignore "Use :" -} @@ -93,13 +95,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 +178,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 +217,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 @@ -347,6 +353,8 @@ instance forMachine dtal = \case UtxowFailure f -> forMachine dtal f DelegsFailure f -> forMachine dtal f + (ShelleyWithdrawalsMissingAccounts _withdrawals) -> undefined -- TODO(geo2a) + (ShelleyIncompleteWithdrawals _payload) -> undefined -- TODO(geo2a) instance ( Api.ShelleyLedgerEra era ~ ledgerera @@ -364,7 +372,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 +383,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 +396,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 +418,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 +456,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 +466,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 +528,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 +614,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 +697,7 @@ instance LogFormatting (ShelleyDelegPredFailure era) where TreasuryMIR -> "Treasury") , "coin" .= coin ] + forMachine _dtal (DelegateeNotRegisteredDELEG _) = undefined -- TODO(10.7) instance LogFormatting (ShelleyPoolPredFailure era) where forMachine _dtal (StakePoolNotRegisteredOnKeyPOOL (KeyHash unregStakePool)) = @@ -877,8 +878,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 +1074,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" .= unWithdrawals incompleteWithdrawals -- TODO(geo2a) + ] forMachine _ (Conway.ConwayTxRefScriptsSizeTooBig Mismatch {mismatchSupplied, mismatchExpected}) = mconcat [ "kind" .= String "ConwayTxRefScriptsSizeTooBig" , "actual" .= mismatchSupplied @@ -1147,11 +1156,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 +1181,14 @@ instance mconcat [ "kind" .= String "UnelectedCommitteeVoters" , "unelectedCommitteeVoters" .= voters ] + forMachine _ (Conway.InvalidGuardrailsScriptHash _ _) = undefined -- TODO(10.7) + -- TODO(10.7): incorporate into the above + -- forMachine _ (Conway.InvalidPolicyHash actualPolicyHash expectedPolicyHash) = + -- mconcat [ "kind" .= String "InvalidPolicyHash" + -- , "actualPolicyHash" .= actualPolicyHash + -- , "expectedPolicyHash" .= expectedPolicyHash + -- ] + instance ( Consensus.ShelleyBasedEra era @@ -1189,6 +1201,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 _ = undefined -- TODO(geo2a) + +instance + (LogFormatting (PredicateFailure (Ledger.EraRule "CERTS" ledgerera)) + ) => LogFormatting (Dijkstra.DijkstraGovCertPredFailure ledgerera) where + forMachine _ = undefined -- TODO(geo2a) + +instance + (LogFormatting (PredicateFailure (Ledger.EraRule "CERTS" ledgerera)) + ) => LogFormatting (Dijkstra.DijkstraGovPredFailure ledgerera) where + forMachine _ = undefined -- TODO(geo2a) + +instance + (LogFormatting (PredicateFailure (Ledger.EraRule "UTXOW" ledgerera)) + ) => LogFormatting (Dijkstra.DijkstraUtxowPredFailure ledgerera) where + forMachine _ = undefined -- TODO(geo2a) + +instance + (LogFormatting (PredicateFailure (Ledger.EraRule "CERTS" ledgerera)) + ) => LogFormatting (Dijkstra.DijkstraBbodyPredFailure ledgerera) where + forMachine _ = undefined -- TODO(geo2a) + +instance + (LogFormatting (PredicateFailure (Ledger.EraRule "CERTS" ledgerera)) + ) => LogFormatting (Dijkstra.DijkstraUtxoPredFailure ledgerera) where + forMachine _ = undefined -- TODO(geo2a) instance ( Ledger.Crypto crypto @@ -1312,8 +1355,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 +1469,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 +1501,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 +1510,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 +1526,7 @@ instance ] Conway.UnspendableUTxONoDatumHash ins -> mconcat [ "kind" .= String "MissingRequiredSigners" - , "txins" .= Set.toList ins + , "txins" .= NonEmptySet.toList ins ] Conway.ExtraRedeemers rs -> Api.caseShelleyToMaryOrAlonzoEraOnwards @@ -1491,7 +1534,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..c8c2cfd150a 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Render.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Render.hs @@ -60,6 +60,9 @@ 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) + condenseT :: Condense a => a -> Text condenseT = Text.pack . condense @@ -184,9 +187,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) 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..9db8e8319dd 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 @@ -57,8 +59,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 +77,7 @@ mkDispatchTracers (ConnectionId RemoteAddress) (TraceChainSyncClientEvent blk)) , LogFormatting (TraceGsmEvent (Tip blk)) , MetaTrace (TraceGsmEvent (Tip blk)) + , ToJSON (HeaderHash blk) ) => NodeKernelData blk -> Trace IO FormattedMessage @@ -190,6 +196,7 @@ mkConsensusTracers :: forall blk. (ConnectionId RemoteAddress) (TraceChainSyncClientEvent blk)) , LogFormatting (TraceGsmEvent (Tip blk)) , MetaTrace (TraceGsmEvent (Tip blk)) + , ToJSON (HeaderHash blk) ) => ConfigReflection -> Trace IO FormattedMessage @@ -379,6 +386,8 @@ mkConsensusTracers configReflection trBase trForward mbTrEKG _trDataPoint trConf traceWith consensusDbfTr , Consensus.kesAgentTracer = Tracer $ traceWith consensusKesAgentTr + , Consensus.txLogicTracer = undefined -- TODO(10.7) + , Consensus.txCountersTracer = undefined -- TODO(10.7) } mkNodeToClientTracers :: forall blk. @@ -473,6 +482,12 @@ mkNodeToNodeTracers configReflection trBase trForward mbTrEKG _trDataPoint trCon ["PeerSharing", "Remote"] configureTracers configReflection trConfig [peerSharingTracer] + txLogicTracer <- undefined -- TODO(10.7) once TxLogic instance are available + -- !txLogicTracer <- mkCardanoTracer + -- trBase trForward mbTrEKG + -- ["txLogic", "Remote"] + -- configureTracers configReflection trConfig [txLogicTracer] + pure $ NtN.Tracers { NtN.tChainSyncTracer = Tracer $ traceWith chainSyncTracer @@ -488,16 +503,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 +588,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 +673,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..1fe71412f50 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/Consensus.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/Consensus.hs @@ -69,9 +69,9 @@ 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.Tracing () +import Ouroboros.Network.TxSubmission.Inbound.V2 hiding (txId) import Ouroboros.Network.TxSubmission.Outbound import Control.Monad (guard) @@ -87,15 +87,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 +660,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 @@ -1070,10 +1061,10 @@ instance LogFormatting SanityCheckIssue where -------------------------------------------------------------------------------- instance LogFormatting (TraceTxSubmissionInbound txid tx) where - forMachine _dtal (TraceTxSubmissionCollected count) = + forMachine _dtal (TraceTxSubmissionCollected txids) = mconcat [ "kind" .= String "TraceTxSubmissionCollected" - , "count" .= toJSON count + , "count" .= toJSON (length txids) ] forMachine _dtal (TraceTxSubmissionProcessed processed) = mconcat @@ -1095,9 +1086,13 @@ instance LogFormatting (TraceTxSubmissionInbound txid tx) where [ "kind" .= String "TraceTxInboundCannotRequestMoreTxs" , "count" .= toJSON count ] + forMachine _dtal (TraceTxInboundAddedToMempool _ _) = undefined -- TODO(10.7) + forMachine _dtal (TraceTxInboundRejectedFromMempool _ _) = undefined -- TODO(10.7) + forMachine _dtal (TraceTxInboundError _) = undefined -- TODO(10.7) + forMachine _dtal (TraceTxInboundDecision _) = undefined -- TODO(10.7) - asMetrics (TraceTxSubmissionCollected count)= - [CounterM "submissions.submitted" (Just count)] + asMetrics (TraceTxSubmissionCollected txids)= + [CounterM "submissions.submitted" (Just (length txids))] asMetrics (TraceTxSubmissionProcessed processed) = [ CounterM "submissions.accepted" (Just (ptxcAccepted processed)) @@ -1112,6 +1107,10 @@ instance MetaTrace (TraceTxSubmissionInbound txid tx) where namespaceFor TraceTxInboundTerminated {} = Namespace [] ["Terminated"] namespaceFor TraceTxInboundCanRequestMoreTxs {} = Namespace [] ["CanRequestMoreTxs"] namespaceFor TraceTxInboundCannotRequestMoreTxs {} = Namespace [] ["CannotRequestMoreTxs"] + namespaceFor TraceTxInboundAddedToMempool {} = undefined -- TODO(10.7) + namespaceFor TraceTxInboundRejectedFromMempool {} = undefined -- TODO(10.7) + namespaceFor TraceTxInboundError {} = undefined -- TODO(10.7) + namespaceFor TraceTxInboundDecision {} = undefined -- TODO(10.7) severityFor (Namespace _ ["Collected"]) _ = Just Debug severityFor (Namespace _ ["Processed"]) _ = Just Debug 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/P2P.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/P2P.hs index 7142b3c07f6..f1ea0db82ac 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/P2P.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/P2P.hs @@ -14,2066 +14,15 @@ module Cardano.Node.Tracing.Tracers.P2P 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 Ouroboros.Network.Tracing () -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.Aeson (Value (..), (.=)) 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 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..d656839e6b9 100644 --- a/cardano-node/src/Cardano/Tracing/OrphanInstances/Network.hs +++ b/cardano-node/src/Cardano/Tracing/OrphanInstances/Network.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -21,12 +22,13 @@ module Cardano.Tracing.OrphanInstances.Network , FetchDecisionToJSON (..) ) where + +import qualified Cardano.Network.PeerSelection 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(..)) 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 extraTrace ntnAddr) where +instance HasSeverityAnnotation (TracePeerSelection extraDebugState extraFlags extraPeers extraTrace 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) Cardano.ExtraTrace addr) where trTransformer = trStructuredText -instance HasTextFormatter CardanoTracePeerSelection where +instance (Ord addr, Show addr) => HasTextFormatter (TracePeerSelection Cardano.DebugPeerSelectionState Cardano.PeerTrustable (Cardano.ExtraPeers addr) Cardano.ExtraTrace 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) Cardano.ExtraTrace 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 @@ -2068,6 +2113,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 +2168,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 +2341,23 @@ 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 ToObject (TxDecision txid tx) where + toObject _ _ = undefined -- TODO(10.7) diff --git a/cardano-node/src/Cardano/Tracing/OrphanInstances/Shelley.hs b/cardano-node/src/Cardano/Tracing/OrphanInstances/Shelley.hs index d8645b49170..ebbcebc883e 100644 --- a/cardano-node/src/Cardano/Tracing/OrphanInstances/Shelley.hs +++ b/cardano-node/src/Cardano/Tracing/OrphanInstances/Shelley.hs @@ -38,6 +38,7 @@ 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 @@ -82,6 +83,7 @@ import qualified Data.Set as Set 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 :" -} @@ -110,8 +112,8 @@ instance ShelleyCompatible protocol era => ToObject (Header (ShelleyBlock protoc instance ( ToObject (PredicateFailure (Core.EraRule "LEDGER" ledgerera)) ) => ToObject (ApplyTxError ledgerera) where - toObject verb (ApplyTxError predicateFailures) = - mconcat $ NonEmpty.toList $ fmap (toObject verb) predicateFailures + toObject _verb _err = undefined -- TODO(10.7) + -- mconcat $ NonEmpty.toList $ fmap (toObject verb) predicateFailures instance Core.Crypto crypto => ToObject (TPraosCannotForge crypto) where toObject _verb (TPraosCannotForgeKeyNotUsableYet wallClockPeriod keyStartPeriod) = @@ -214,7 +216,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 +239,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 @@ -327,6 +329,9 @@ instance ) => ToObject (ShelleyLedgerPredFailure ledgerera) where toObject verb (UtxowFailure f) = toObject verb f toObject verb (DelegsFailure f) = toObject verb f + toObject _verb (ShelleyWithdrawalsMissingAccounts _withdrawals) = undefined -- TODO(geo2a) + toObject _verb (ShelleyIncompleteWithdrawals _payload) = undefined -- TODO(geo2a) + instance ( ToObject (PredicateFailure (Core.EraRule "CERTS" ledgerera)) @@ -334,6 +339,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" .= undefined -- TODO(geo2a) + ] toObject _ (Conway.ConwayTxRefScriptsSizeTooBig Mismatch {mismatchSupplied, mismatchExpected}) = mconcat [ "kind" .= String "ConwayTxRefScriptsSizeTooBig" , "actual" .= mismatchSupplied @@ -407,11 +420,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 +448,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 +462,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 = undefined -- TODO(geo2a) + +instance + (ToObject (PredicateFailure (Core.EraRule "CERTS" ledgerera)) + ) => ToObject (Dijkstra.DijkstraGovCertPredFailure ledgerera) where + toObject _verb = undefined -- TODO(geo2a) + +instance + (ToObject (PredicateFailure (Core.EraRule "CERTS" ledgerera)) + ) => ToObject (Dijkstra.DijkstraGovPredFailure ledgerera) where + toObject _verb = undefined -- TODO(geo2a) + +instance + (ToObject (PredicateFailure (Core.EraRule "UTXOW" ledgerera)) + ) => ToObject (Dijkstra.DijkstraUtxowPredFailure ledgerera) where + toObject _verb = undefined -- TODO(geo2a) + +instance + (ToObject (PredicateFailure (Core.EraRule "CERTS" ledgerera)) + ) => ToObject (Dijkstra.DijkstraBbodyPredFailure ledgerera) where + toObject _verb = undefined -- TODO(geo2a) + +instance + (ToObject (PredicateFailure (Core.EraRule "CERTS" ledgerera)) + ) => ToObject (Dijkstra.DijkstraUtxoPredFailure ledgerera) where + toObject _verb = undefined -- TODO(geo2a) instance ( Api.ShelleyLedgerEra era ~ ledgerera @@ -469,7 +512,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 +523,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 +536,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 +552,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 +603,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 +665,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 +749,10 @@ 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 (DelegateeNotRegisteredDELEG targetPool) = + -- mconcat [ "kind" .= String "DelegateeNotRegisteredDELEG" + -- , "targetPool" .= targetPool + -- ] toObject verb (DelplFailure f) = toObject verb f @@ -798,6 +837,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 +1072,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 +1359,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 +1404,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 +1520,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 +1552,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 +1561,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 +1577,7 @@ instance ] Conway.UnspendableUTxONoDatumHash ins -> mconcat [ "kind" .= String "MissingRequiredSigners" - , "txins" .= Set.toList ins + , "txins" .= NonEmptySet.toList ins ] Conway.ExtraRedeemers rs -> Api.caseShelleyToMaryOrAlonzoEraOnwards @@ -1541,7 +1585,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..0c17b9c4d70 100644 --- a/cardano-node/src/Cardano/Tracing/Tracers.hs +++ b/cardano-node/src/Cardano/Tracing/Tracers.hs @@ -29,6 +29,8 @@ module Cardano.Tracing.Tracers , traceCounter ) where +import qualified Ouroboros.Network.PeerSelection.Governor 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 +46,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 +59,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 +77,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 @@ -103,14 +104,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 +138,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 +245,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 +413,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 +456,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 +504,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 +521,7 @@ mkTracers _ _ _ _ _ = , NodeToNode.tTxSubmission2Tracer = nullTracer , NodeToNode.tKeepAliveTracer = nullTracer , NodeToNode.tPeerSharingTracer = nullTracer + , NodeToNode.tTxLogicTracer = nullTracer } , diffusionTracers = Diffusion.nullTracers , churnModeTracer = nullTracer @@ -547,8 +543,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 +589,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 +614,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 +647,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 +765,7 @@ mkConsensusTracers , ToJSON peer , LedgerQueries blk , ToJSON (GenTxId blk) + , ToJSON (HeaderHash blk) , ToObject (ApplyTxErr blk) , ToObject (CannotForge blk) , ToObject (GenTx blk) @@ -778,7 +794,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 +825,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 +837,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 +860,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 +1088,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 +1106,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 +1343,7 @@ mempoolTracer :: ( ToJSON (GenTxId blk) , ToObject (ApplyTxErr blk) , ToObject (GenTx blk) + , ToJSON (HeaderHash blk) , LedgerSupportsMempool blk , ConvertRawHash blk ) @@ -1341,6 +1364,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 +1528,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 +1538,7 @@ teeTraceBlockFetchDecision :: ( Eq peer , Show peer , ToJSON peer + , ToJSON (HeaderHash blk) , HasHeader blk , ConvertRawHash blk ) @@ -1542,6 +1570,7 @@ teeTraceBlockFetchDecisionElide :: ( Eq peer , Show peer , ToJSON peer + , ToJSON (HeaderHash blk) , HasHeader blk , ConvertRawHash blk ) @@ -1590,17 +1619,16 @@ traceConnectionManagerTraceMetrics (OnOff True) (Just ekgDirect) = cmtTracer outboundConns _ -> return () - tracePeerSelectionTracerMetrics - :: forall extraDebugState extraFlags extraPeers peeraddr. + :: forall extraDebugState extraFlags extraPeers extraTrace peeraddr. OnOff TracePeerSelection -> Maybe EKGDirect - -> Tracer IO (Governor.TracePeerSelection extraDebugState extraFlags extraPeers peeraddr) + -> Tracer IO (Governor.TracePeerSelection extraDebugState extraFlags extraPeers extraTrace peeraddr) tracePeerSelectionTracerMetrics _ Nothing = nullTracer tracePeerSelectionTracerMetrics (OnOff False) _ = nullTracer tracePeerSelectionTracerMetrics (OnOff True) (Just ekgDirect) = pstTracer where - pstTracer :: Tracer IO (Governor.TracePeerSelection extraDebugState extraFlags extraPeers peeraddr) + pstTracer :: Tracer IO (Governor.TracePeerSelection extraDebugState extraFlags extraPeers extraTrace peeraddr) pstTracer = Tracer $ \a -> do case a of Governor.TraceChurnAction duration action _ -> @@ -1610,7 +1638,6 @@ tracePeerSelectionTracerMetrics (OnOff True) (Just ekgDirect) = pstTracer (realToFrac duration) _ -> pure () - tracePeerSelectionCountersMetrics :: OnOff TracePeerSelectionCounters -> Maybe EKGDirect @@ -1672,18 +1699,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 54a013cce98640cc15d7c4d47c333ec712f5a040 Mon Sep 17 00:00:00 2001 From: Georgy Lukyanov Date: Fri, 20 Feb 2026 12:13:28 +0100 Subject: [PATCH 14/27] [wip] make it build --- .../src/Cardano/Node/Configuration/POM.hs | 7 +++--- .../src/Cardano/Node/Protocol/Byron.hs | 6 +++-- .../src/Cardano/Node/Protocol/Cardano.hs | 2 ++ .../src/Cardano/Node/Protocol/Shelley.hs | 3 +++ .../src/Cardano/Node/Protocol/Types.hs | 4 ++++ cardano-node/src/Cardano/Node/Run.hs | 24 ++++++++++--------- 6 files changed, 30 insertions(+), 16 deletions(-) diff --git a/cardano-node/src/Cardano/Node/Configuration/POM.hs b/cardano-node/src/Cardano/Node/Configuration/POM.hs index 4ceaa78d657..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 @@ -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/Protocol/Byron.hs b/cardano-node/src/Cardano/Node/Protocol/Byron.hs index 7b53ff28e4c..1d7d0793087 100644 --- a/cardano-node/src/Cardano/Node/Protocol/Byron.hs +++ b/cardano-node/src/Cardano/Node/Protocol/Byron.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} @@ -35,12 +37,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 +169,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..7100931e4e9 100644 --- a/cardano-node/src/Cardano/Node/Protocol/Cardano.hs +++ b/cardano-node/src/Cardano/Node/Protocol/Cardano.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -37,6 +38,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 8cc431ec2bf..94561466dc5 100644 --- a/cardano-node/src/Cardano/Node/Run.hs +++ b/cardano-node/src/Cardano/Node/Run.hs @@ -99,8 +99,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 @@ -112,7 +113,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) @@ -487,8 +488,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 @@ -517,7 +518,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, @@ -651,7 +652,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 () @@ -764,8 +765,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 @@ -780,7 +781,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) @@ -876,7 +877,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 @@ -953,7 +954,8 @@ producerAddresses RealNodeTopology { ntLocalRootPeersGroups , LocalRootConfig { diffusionMode = rootDiffusionMode lrp, peerAdvertise, - extraFlags = trustable lrp + extraLocalRootFlags = trustable lrp, + localProvenance = undefined -- TODO(10.7) -- ask Network } ) ) From 497684ed2903e196b40656d1991c8372044e4dd5 Mon Sep 17 00:00:00 2001 From: Georgy Lukyanov Date: Tue, 24 Feb 2026 18:22:01 +0100 Subject: [PATCH 15/27] cardano-tracer: add cardano-diffusion dependency --- cardano-tracer/cardano-tracer.cabal | 1 + 1 file changed, 1 insertion(+) diff --git a/cardano-tracer/cardano-tracer.cabal b/cardano-tracer/cardano-tracer.cabal index 432b32d966a..eed2e1354bf 100644 --- a/cardano-tracer/cardano-tracer.cabal +++ b/cardano-tracer/cardano-tracer.cabal @@ -172,6 +172,7 @@ library , bimap , blaze-html , bytestring + , cardano-diffusion ^>= 0.1 , cborg ^>= 0.2.4 , containers , contra-tracer From 4bfd074cc5f416856167bc8d8b636235442c76ac Mon Sep 17 00:00:00 2001 From: Georgy Lukyanov Date: Wed, 25 Feb 2026 09:21:31 +0100 Subject: [PATCH 16/27] [wip] tx-generator: update to latest Ledger and Network --- .../src/Cardano/Benchmarking/Tracer.hs | 30 +++++++------------ .../Cardano/TxGenerator/ProtocolParameters.hs | 25 ++++++++-------- .../src/Cardano/TxGenerator/Utils.hs | 3 +- bench/tx-generator/tx-generator.cabal | 5 +++- 4 files changed, 30 insertions(+), 33 deletions(-) diff --git a/bench/tx-generator/src/Cardano/Benchmarking/Tracer.hs b/bench/tx-generator/src/Cardano/Benchmarking/Tracer.hs index 453a01217d3..a0a13262ea4 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,18 @@ instance MetaTrace NodeToNodeSubmissionTrace where , Namespace [] ["TxList"] ] -instance LogFormatting SendRecvConnect where +-- TODO(10.7): tracing team, check this makes sense +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"] +-- TODO(10.7): tracing team, check this makes sense +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..95306e07f87 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 177d2d4bedb..3aec09a4d6a 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 ^>= 0.1 , cardano-git-rev ^>= 0.2.2 , cardano-ledger-alonzo , cardano-ledger-api @@ -121,6 +122,7 @@ library , cardano-ledger-core , cardano-node , cardano-prelude + , cardano-strict-containers >=0.1 , contra-tracer , cborg >= 0.2.2 && < 0.3 , containers @@ -140,10 +142,11 @@ library , ouroboros-consensus >= 0.6 , ouroboros-consensus-cardano >= 0.5 , ouroboros-consensus-diffusion >= 0.7.0 - , ouroboros-network:{api, framework, ouroboros-network, protocols} + , ouroboros-network:{api, framework, framework-tracing, ouroboros-network, protocols} , plutus-ledger-api , plutus-tx , random + , typed-protocols ^>= 1.2 , serialise , streaming , cardano-ledger-shelley From c01d11a4c04031a99ff9a3691d58f5213edaaa40 Mon Sep 17 00:00:00 2001 From: Georgy Lukyanov Date: Thu, 26 Feb 2026 11:50:13 +0100 Subject: [PATCH 17/27] Legacy tracing: use ToJSON to get ToObject for ApplyTxError --- cardano-node/src/Cardano/Tracing/OrphanInstances/Shelley.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/cardano-node/src/Cardano/Tracing/OrphanInstances/Shelley.hs b/cardano-node/src/Cardano/Tracing/OrphanInstances/Shelley.hs index ebbcebc883e..9fc85cde9d1 100644 --- a/cardano-node/src/Cardano/Tracing/OrphanInstances/Shelley.hs +++ b/cardano-node/src/Cardano/Tracing/OrphanInstances/Shelley.hs @@ -111,9 +111,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 _err = undefined -- TODO(10.7) - -- mconcat $ NonEmpty.toList $ fmap (toObject verb) predicateFailures instance Core.Crypto crypto => ToObject (TPraosCannotForge crypto) where toObject _verb (TPraosCannotForgeKeyNotUsableYet wallClockPeriod keyStartPeriod) = From e6bbd469a8f7fe2f73677f2774a4a633729a5494 Mon Sep 17 00:00:00 2001 From: Javier Sagredo Date: Thu, 26 Feb 2026 14:47:51 +0100 Subject: [PATCH 18/27] 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 080ace219ecf2db988d2f62ff4c7293b0131d22a Mon Sep 17 00:00:00 2001 From: Georgy Lukyanov Date: Thu, 26 Feb 2026 17:30:36 +0100 Subject: [PATCH 19/27] cardano-tracer: adapt Server.with --- 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 9e246a13a950e1c2a71fe699932161a4d320a75f Mon Sep 17 00:00:00 2001 From: Georgy Lukyanov Date: Thu, 26 Feb 2026 17:57:47 +0100 Subject: [PATCH 20/27] cardano-testnet: adapt to latest ledger --- cardano-testnet/cardano-testnet.cabal | 1 + cardano-testnet/src/Testnet/Blockfrost.hs | 19 +++++++++---------- .../src/Testnet/Components/Query.hs | 10 +++++----- .../src/Testnet/Process/Cli/SPO.hs | 2 +- 4 files changed, 16 insertions(+), 16 deletions(-) diff --git a/cardano-testnet/cardano-testnet.cabal b/cardano-testnet/cardano-testnet.cabal index 02e1991169e..0efb2e5901d 100644 --- a/cardano-testnet/cardano-testnet.cabal +++ b/cardano-testnet/cardano-testnet.cabal @@ -85,6 +85,7 @@ library , network-mux , optparse-applicative-fork , ouroboros-network:{api, ouroboros-network} ^>= 0.24 + , cardano-diffusion:{api, cardano-diffusion} ^>= 0.1 , prettyprinter , process , resourcet diff --git a/cardano-testnet/src/Testnet/Blockfrost.hs b/cardano-testnet/src/Testnet/Blockfrost.hs index be8093d13f6..d30e6ab98df 100644 --- a/cardano-testnet/src/Testnet/Blockfrost.hs +++ b/cardano-testnet/src/Testnet/Blockfrost.hs @@ -14,8 +14,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 (..)) @@ -207,7 +206,8 @@ blockfrostToGenesis (shelleyGenesis', alonzoGenesis', conwayGenesis', dijkstraGe { prMem = bfgPriceMem , prSteps = bfgPriceSteps } - , agCostModels = CostModels.mkCostModels . Map.mapWithKey trimCostModelToInitial $ CostModels.costModelsValid bfgAlonzoCostModels + , agPlutusV1CostModel = undefined -- TODO(10.7) + -- CostModels.mkCostModels . Map.mapWithKey trimCostModelToInitial $ CostModels.costModelsValid bfgAlonzoCostModels } -- Conway Params @@ -244,13 +244,13 @@ blockfrostToGenesis (shelleyGenesis', alonzoGenesis', conwayGenesis', dijkstraGe -- 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,8 +262,8 @@ blockfrostToGenesis (shelleyGenesis', alonzoGenesis', conwayGenesis', dijkstraGe { pvMajor = bfgProtocolMajorVer , pvMinor = bfgProtocolMinorVer } - , sppMinUTxOValue = bfgMinUTxO - , sppMinPoolCost = bfgMinPoolCost + , sppMinUTxOValue = compactCoinOrError $ bfgMinUTxO + , sppMinPoolCost = compactCoinOrError $ bfgMinPoolCost } shelleyGenesis = shelleyGenesis'{sgProtocolParams=shelleyParams} @@ -279,4 +279,3 @@ trimCostModelToInitial lang cm = do . CostModels.mkCostModel lang . take paramsCount $ CostModels.getCostModelParams cm - 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 From d54099e91c7bd515cafd5d3b01385a1fc6269c00 Mon Sep 17 00:00:00 2001 From: Georgy Lukyanov Date: Thu, 26 Feb 2026 19:05:51 +0100 Subject: [PATCH 21/27] [wip] update SRP on ./ledger --- cabal.project | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/cabal.project b/cabal.project index 766e47eda0e..c12bd58b90d 100644 --- a/cabal.project +++ b/cabal.project @@ -84,8 +84,8 @@ if impl (ghc >= 9.12) source-repository-package type: git location: https://github.com/IntersectMBO/cardano-ledger - tag: bd2c3fc558c8b053b03f25a84fc02e26dd17d927 - --sha256: sha256-JCzOtN0/eQob9IneXjihwxDgWZlSZ2ZdIkz2qBPhtU8= + tag: 532def7117121fc38184b20917acc250c9c8eb73 + --sha256: sha256-IaxfKhCVMrvx6p6QMAcVRq9ZhOkwa3ss5KgsmLfo8As= subdir: eras/allegra/impl eras/alonzo/impl From 530dbd1894972e89bf9a179e4d4cdac5c1cc28b9 Mon Sep 17 00:00:00 2001 From: Georgy Lukyanov Date: Thu, 26 Feb 2026 19:05:53 +0100 Subject: [PATCH 22/27] [wip] update SRP on ./consensus --- cabal.project | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/cabal.project b/cabal.project index c12bd58b90d..c463d4ee0b0 100644 --- a/cabal.project +++ b/cabal.project @@ -114,8 +114,8 @@ source-repository-package source-repository-package type: git location: https://github.com/IntersectMBO/ouroboros-consensus - tag: 3508bb44011c501099b5b1692dd1ebe7c5e9c1cc - --sha256: sha256-Xg+s7ZR00HIdSPCuBH1NUp0GbuSfa7QM4bXOZDfUoeg= + tag: a1a86ebabf54b286f9c4b1652e7e99aa0364d9bf + --sha256: sha256-8tP1IiwmM+hIbE7zk/LsO9BbyP1lD/wXOIGgKIJYmuU= subdir: ouroboros-consensus ouroboros-consensus-cardano From e0c2e2b4b72c4f98a208ff425d85d39e06097e30 Mon Sep 17 00:00:00 2001 From: Georgy Lukyanov Date: Thu, 26 Feb 2026 19:05:53 +0100 Subject: [PATCH 23/27] [wip] update SRP on ./api --- cabal.project | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/cabal.project b/cabal.project index c463d4ee0b0..9335ea4360d 100644 --- a/cabal.project +++ b/cabal.project @@ -158,8 +158,8 @@ source-repository-package source-repository-package type: git location: https://github.com/IntersectMBO/cardano-api - tag: 52fefc49d1fa369708ebf3563cd7141a69fd4be6 - --sha256: sha256-/sodH3WqJzf5oCASbuUY5wC6tsMgjJVTzhryqHu6oGM= + tag: 7706c444408e83911aaff7e2de9b2db4a670f32c + --sha256: sha256-mpPV9evtKqvTVJL9B469qTeu1xEVrNXLoMfMyQnkfHg= subdir: cardano-api From ee80660a0af3a2c42dcc6ea2e2311b34f9273f19 Mon Sep 17 00:00:00 2001 From: Georgy Lukyanov Date: Thu, 26 Feb 2026 19:05:53 +0100 Subject: [PATCH 24/27] [wip] update SRP on ./cli --- cabal.project | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/cabal.project b/cabal.project index 9335ea4360d..58046e52e2e 100644 --- a/cabal.project +++ b/cabal.project @@ -166,8 +166,8 @@ source-repository-package source-repository-package type: git location: https://github.com/IntersectMBO/cardano-cli - tag: a8f913f99bd11c3eead3e5a924610167883a5e64 - --sha256: sha256-QxcDa45F6W/DXq0epm7+Oc6Y+oLnkG5ibeHL2nE5hPA= + tag: 57515196c90cac55ffffd5fd5c825635bfcdd718 + --sha256: sha256-smTAn8Szj5Jvau7caS24t1ji8ZZEyCEnwjvZjj/yAGg= subdir: cardano-cli From ada6041dadda76d9686f0b49f1ff8c30c6a2a877 Mon Sep 17 00:00:00 2001 From: Georgy Lukyanov Date: Thu, 26 Feb 2026 19:31:14 +0100 Subject: [PATCH 25/27] [wip] update SRP on ./cli --- cabal.project | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/cabal.project b/cabal.project index 58046e52e2e..6d156132a0c 100644 --- a/cabal.project +++ b/cabal.project @@ -166,8 +166,8 @@ source-repository-package source-repository-package type: git location: https://github.com/IntersectMBO/cardano-cli - tag: 57515196c90cac55ffffd5fd5c825635bfcdd718 - --sha256: sha256-smTAn8Szj5Jvau7caS24t1ji8ZZEyCEnwjvZjj/yAGg= + tag: 13f82947f6b10f432071cc4b22b39b2d967f4308 + --sha256: sha256-/TByDMLXu4RycaevWHpmz3rgmtwKUTZacZI1ihR0n0Y= subdir: cardano-cli From d553f24914ac75c871b3f733cd67ec48d5d97960 Mon Sep 17 00:00:00 2001 From: Georgy Lukyanov Date: Fri, 27 Feb 2026 10:07:36 +0100 Subject: [PATCH 26/27] [wip] update SRP on ./cli --- cabal.project | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/cabal.project b/cabal.project index 6d156132a0c..1a4c3d36fc7 100644 --- a/cabal.project +++ b/cabal.project @@ -166,8 +166,8 @@ source-repository-package source-repository-package type: git location: https://github.com/IntersectMBO/cardano-cli - tag: 13f82947f6b10f432071cc4b22b39b2d967f4308 - --sha256: sha256-/TByDMLXu4RycaevWHpmz3rgmtwKUTZacZI1ihR0n0Y= + tag: 58636e63bbb192cdda39dacd47362d76490361d0 + --sha256: sha256-AdYPtFVZQQjwP6rdtmMvxKTSL69D0X6fCL6Byqad/N0= subdir: cardano-cli From 4841b4831b82b5708f5707e76f6f630c33377dfb Mon Sep 17 00:00:00 2001 From: Mateusz Galazyn Date: Fri, 27 Feb 2026 21:54:28 +0100 Subject: [PATCH 27/27] cardano-testnet: fix blockfrost response types to match alonzo genesis ones --- cardano-testnet/src/Testnet/Blockfrost.hs | 148 ++++++++++-------- .../src/Testnet/Components/Configuration.hs | 4 +- 2 files changed, 83 insertions(+), 69 deletions(-) diff --git a/cardano-testnet/src/Testnet/Blockfrost.hs b/cardano-testnet/src/Testnet/Blockfrost.hs index d30e6ab98df..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,7 +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, CoinPerByte(..), compactCoinOrError) +import Cardano.Ledger.Coin (Coin, CoinPerByte (..), compactCoinOrError) import Cardano.Ledger.Conway.Genesis (ConwayGenesis (..)) import Cardano.Ledger.Conway.PParams (DRepVotingThresholds (..), PoolVotingThresholds (..), UpgradeConwayPParams (..)) @@ -27,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 @@ -181,76 +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 - } - , agPlutusV1CostModel = undefined -- TODO(10.7) - -- 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 - { sppTxFeePerByte = CoinPerByte . compactCoinOrError $ bfgMinFeeA - , sppTxFeeFixed = compactCoinOrError $ bfgMinFeeB + { sppTxFeePerByte = CoinPerByte $ compactCoinOrError bfgMinFeeA + , sppTxFeeFixed = compactCoinOrError bfgMinFeeB , sppMaxBBSize = bfgMaxBlockSize , sppMaxTxSize = bfgMaxTxSize , sppMaxBHSize = bfgMaxBlockHeaderSize - , sppKeyDeposit = compactCoinOrError $ bfgKeyDeposit - , sppPoolDeposit = compactCoinOrError $ bfgPoolDeposit + , sppKeyDeposit = compactCoinOrError bfgKeyDeposit + , sppPoolDeposit = compactCoinOrError bfgPoolDeposit , sppEMax = bfgEMax , sppNOpt = bfgNOpt , sppA0 = bfgA0 @@ -262,20 +276,20 @@ blockfrostToGenesis (shelleyGenesis', alonzoGenesis', conwayGenesis', dijkstraGe { pvMajor = bfgProtocolMajorVer , pvMinor = bfgProtocolMinorVer } - , sppMinUTxOValue = compactCoinOrError $ bfgMinUTxO - , sppMinPoolCost = compactCoinOrError $ 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