From dea5b307d5cd75b13fbfe5da4912584ea7a2f17b Mon Sep 17 00:00:00 2001 From: paolino Date: Wed, 15 Nov 2023 11:35:47 +0000 Subject: [PATCH 1/3] Add cardano-wallet-network-layer lib skeleton --- cabal.project | 1 + lib/network-layer/CHANGELOG.md | 5 + lib/network-layer/LICENSE | 202 ++++++++++++++++++ .../cardano-wallet-network-layer.cabal | 39 ++++ lib/network-layer/src/MyLib.hs | 4 + lib/network-layer/test/Main.hs | 4 + 6 files changed, 255 insertions(+) create mode 100644 lib/network-layer/CHANGELOG.md create mode 100644 lib/network-layer/LICENSE create mode 100644 lib/network-layer/cardano-wallet-network-layer.cabal create mode 100644 lib/network-layer/src/MyLib.hs create mode 100644 lib/network-layer/test/Main.hs diff --git a/cabal.project b/cabal.project index 6342607bb95..95d13206d16 100644 --- a/cabal.project +++ b/cabal.project @@ -70,6 +70,7 @@ packages: , lib/iohk-monitoring-extra/ , lib/launcher/ , lib/local-cluster/ + , lib/network-layer/ , lib/numeric/ , lib/primitive/ , lib/read diff --git a/lib/network-layer/CHANGELOG.md b/lib/network-layer/CHANGELOG.md new file mode 100644 index 00000000000..5703491da63 --- /dev/null +++ b/lib/network-layer/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for node-communication + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/lib/network-layer/LICENSE b/lib/network-layer/LICENSE new file mode 100644 index 00000000000..d6456956733 --- /dev/null +++ b/lib/network-layer/LICENSE @@ -0,0 +1,202 @@ + + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright [yyyy] [name of copyright owner] + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/lib/network-layer/cardano-wallet-network-layer.cabal b/lib/network-layer/cardano-wallet-network-layer.cabal new file mode 100644 index 00000000000..6a0059f581c --- /dev/null +++ b/lib/network-layer/cardano-wallet-network-layer.cabal @@ -0,0 +1,39 @@ +cabal-version: 3.4 +name: cardano-wallet-network-layer +version: 0.1.0.0 +synopsis: Node communication layer functionality. +-- description: +homepage: https://github.com/cardano-foundation/cardano-wallet +license: Apache-2.0 +license-file: LICENSE +author: Cardano Foundation (High Assurance Lab) +maintainer: hal@cardanofoundation.org +-- copyright: +category: Network +build-type: Simple +extra-doc-files: CHANGELOG.md +-- extra-source-files: + +common warnings + ghc-options: -Wall + +library + import: warnings + exposed-modules: MyLib + -- other-modules: + -- other-extensions: + build-depends: base ^>=4.14.3.0 + hs-source-dirs: src + default-language: Haskell2010 + +test-suite cardano-wallet-network-layer-test + import: warnings + default-language: Haskell2010 + -- other-modules: + -- other-extensions: + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + build-depends: + base ^>=4.14.3.0, + cardano-wallet-network-layer diff --git a/lib/network-layer/src/MyLib.hs b/lib/network-layer/src/MyLib.hs new file mode 100644 index 00000000000..e657c4403f6 --- /dev/null +++ b/lib/network-layer/src/MyLib.hs @@ -0,0 +1,4 @@ +module MyLib (someFunc) where + +someFunc :: IO () +someFunc = putStrLn "someFunc" diff --git a/lib/network-layer/test/Main.hs b/lib/network-layer/test/Main.hs new file mode 100644 index 00000000000..3e2059e31f5 --- /dev/null +++ b/lib/network-layer/test/Main.hs @@ -0,0 +1,4 @@ +module Main (main) where + +main :: IO () +main = putStrLn "Test suite not yet implemented." From e91d6681ff5db5887c71f0588ea8c5017471e849 Mon Sep 17 00:00:00 2001 From: paolino Date: Wed, 22 Nov 2023 11:22:24 +0000 Subject: [PATCH 2/3] Move NetworkLayer to network layer lib --- lib/network-layer/CHANGELOG.md | 6 +- .../cardano-wallet-network-layer.cabal | 88 ++++++++++++------- .../src/Cardano/Wallet/Network.hs | 22 +++-- lib/network-layer/src/MyLib.hs | 4 - lib/wallet/cardano-wallet.cabal | 7 +- lib/wallet/src/Cardano/Pool/Types.hs | 29 +----- 6 files changed, 84 insertions(+), 72 deletions(-) rename lib/{wallet => network-layer}/src/Cardano/Wallet/Network.hs (98%) delete mode 100644 lib/network-layer/src/MyLib.hs diff --git a/lib/network-layer/CHANGELOG.md b/lib/network-layer/CHANGELOG.md index 5703491da63..be17c87c4bd 100644 --- a/lib/network-layer/CHANGELOG.md +++ b/lib/network-layer/CHANGELOG.md @@ -1,5 +1,5 @@ -# Revision history for node-communication +# Revision history for cardano-wallet-network-layer -## 0.1.0.0 -- YYYY-mm-dd +## 0.1.0.0 -- 2023-11-23 -* First version. Released on an unsuspecting world. +* First version. Extracted from wallet lib diff --git a/lib/network-layer/cardano-wallet-network-layer.cabal b/lib/network-layer/cardano-wallet-network-layer.cabal index 6a0059f581c..740e72cd413 100644 --- a/lib/network-layer/cardano-wallet-network-layer.cabal +++ b/lib/network-layer/cardano-wallet-network-layer.cabal @@ -1,39 +1,65 @@ -cabal-version: 3.4 -name: cardano-wallet-network-layer -version: 0.1.0.0 -synopsis: Node communication layer functionality. +cabal-version: 3.4 +name: cardano-wallet-network-layer +version: 0.1.0.0 +synopsis: Node communication layer functionality. + -- description: -homepage: https://github.com/cardano-foundation/cardano-wallet -license: Apache-2.0 -license-file: LICENSE -author: Cardano Foundation (High Assurance Lab) -maintainer: hal@cardanofoundation.org +homepage: https://github.com/cardano-foundation/cardano-wallet +license: Apache-2.0 +license-file: LICENSE +author: Cardano Foundation (High Assurance Lab) +maintainer: hal@cardanofoundation.org + -- copyright: -category: Network -build-type: Simple -extra-doc-files: CHANGELOG.md +category: Network +build-type: Simple +extra-doc-files: CHANGELOG.md + -- extra-source-files: common warnings - ghc-options: -Wall + ghc-options: -Wall library - import: warnings - exposed-modules: MyLib - -- other-modules: - -- other-extensions: - build-depends: base ^>=4.14.3.0 - hs-source-dirs: src - default-language: Haskell2010 + import: warnings + exposed-modules: Cardano.Wallet.Network + + -- other-modules: + -- other-extensions: + build-depends: + , base ^>=4.14.3.0 + , bytestring + , cardano-api + , cardano-balance-tx:internal + , cardano-ledger-core + , cardano-slotting + , cardano-wallet-launcher + , cardano-wallet-primitive + , cardano-wallet-read + , cborg + , containers + , contra-tracer + , fmt + , generics-sop + , io-classes + , iohk-monitoring + , iohk-monitoring-extra + , memory + , network-mux + , nothunks + , ouroboros-consensus + , ouroboros-consensus-cardano + , ouroboros-network-api + , ouroboros-network-framework + , ouroboros-network-protocols + , safe + , strict-stm + , text + , text-class + , time + , transformers + , typed-protocols + , unliftio -test-suite cardano-wallet-network-layer-test - import: warnings - default-language: Haskell2010 - -- other-modules: - -- other-extensions: - type: exitcode-stdio-1.0 - hs-source-dirs: test - main-is: Main.hs - build-depends: - base ^>=4.14.3.0, - cardano-wallet-network-layer + hs-source-dirs: src + default-language: Haskell2010 diff --git a/lib/wallet/src/Cardano/Wallet/Network.hs b/lib/network-layer/src/Cardano/Wallet/Network.hs similarity index 98% rename from lib/wallet/src/Cardano/Wallet/Network.hs rename to lib/network-layer/src/Cardano/Wallet/Network.hs index 194d0cb5ab2..adb7588532b 100644 --- a/lib/wallet/src/Cardano/Wallet/Network.hs +++ b/lib/network-layer/src/Cardano/Wallet/Network.hs @@ -7,6 +7,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} @@ -47,8 +48,8 @@ import Cardano.BM.Data.Tracer ( HasPrivacyAnnotation (..) , HasSeverityAnnotation (..) ) -import Cardano.Pool.Types - ( StakePoolsSummary +import Cardano.Slotting.Slot + ( SlotNo (..) ) import Cardano.Wallet.Primitive.Slotting ( PastHorizonException @@ -57,13 +58,11 @@ import Cardano.Wallet.Primitive.Slotting import Cardano.Wallet.Primitive.SyncProgress ( SyncProgress (..) ) -import Cardano.Wallet.Primitive.Types +import Cardano.Wallet.Primitive.Types.Block ( Block - , BlockHeader (..) + , BlockHeader , ChainPoint (..) - , ProtocolParameters - , SlotNo (..) - , SlottingParameters (..) + , slotNo ) import Cardano.Wallet.Primitive.Types.BlockSummary ( LightSummary @@ -74,9 +73,18 @@ import Cardano.Wallet.Primitive.Types.Checkpoints.Policy import Cardano.Wallet.Primitive.Types.Coin ( Coin ) +import Cardano.Wallet.Primitive.Types.ProtocolParameters + ( ProtocolParameters + ) import Cardano.Wallet.Primitive.Types.RewardAccount ( RewardAccount (..) ) +import Cardano.Wallet.Primitive.Types.SlottingParameters + ( SlottingParameters + ) +import Cardano.Wallet.Primitive.Types.StakePoolSummary + ( StakePoolsSummary + ) import Cardano.Wallet.Primitive.Types.Tx.SealedTx ( SealedTx ) diff --git a/lib/network-layer/src/MyLib.hs b/lib/network-layer/src/MyLib.hs deleted file mode 100644 index e657c4403f6..00000000000 --- a/lib/network-layer/src/MyLib.hs +++ /dev/null @@ -1,4 +0,0 @@ -module MyLib (someFunc) where - -someFunc :: IO () -someFunc = putStrLn "someFunc" diff --git a/lib/wallet/cardano-wallet.cabal b/lib/wallet/cardano-wallet.cabal index a1ce0395259..40473078381 100644 --- a/lib/wallet/cardano-wallet.cabal +++ b/lib/wallet/cardano-wallet.cabal @@ -96,6 +96,7 @@ library , cardano-strict-containers , cardano-wallet-application-extras , cardano-wallet-launcher + , cardano-wallet-network-layer , cardano-wallet-primitive , cardano-wallet-read , cardano-wallet-test-utils @@ -293,7 +294,6 @@ library Cardano.Wallet.Delegation.Properties Cardano.Wallet.Flavor Cardano.Wallet.Gen - Cardano.Wallet.Network Cardano.Wallet.Network.Config Cardano.Wallet.Network.Light Cardano.Wallet.Pools @@ -401,6 +401,7 @@ library cardano-wallet-api-http , cardano-wallet , cardano-wallet-application-extras , cardano-wallet-launcher + , cardano-wallet-network-layer , cardano-wallet-primitive , cardano-wallet-read , cardano-wallet-test-utils @@ -734,6 +735,7 @@ test-suite unit , cardano-wallet-api-http , cardano-wallet-application-extras , cardano-wallet-launcher + , cardano-wallet-network-layer , cardano-wallet-primitive , cardano-wallet-read , cardano-wallet-test-utils @@ -990,6 +992,7 @@ benchmark restore , cardano-wallet-bench , cardano-wallet-integration , cardano-wallet-launcher + , cardano-wallet-network-layer , cardano-wallet-primitive , containers , contra-tracer @@ -1061,6 +1064,7 @@ benchmark db , cardano-wallet , cardano-wallet-application-extras , cardano-wallet-bench + , cardano-wallet-network-layer , cardano-wallet-primitive , cardano-wallet-read , cardano-wallet-test-utils @@ -1100,6 +1104,7 @@ benchmark api , cardano-wallet , cardano-wallet-application-extras , cardano-wallet-bench + , cardano-wallet-network-layer , cardano-wallet-primitive , cardano-wallet-read , containers diff --git a/lib/wallet/src/Cardano/Pool/Types.hs b/lib/wallet/src/Cardano/Pool/Types.hs index 7c5974e2e7e..de5e09fabd4 100644 --- a/lib/wallet/src/Cardano/Pool/Types.hs +++ b/lib/wallet/src/Cardano/Pool/Types.hs @@ -18,15 +18,15 @@ module Cardano.Pool.Types import Prelude -import Cardano.Wallet.Primitive.Types.Coin - ( Coin (..) - ) import Cardano.Wallet.Primitive.Types.PoolId ( PoolId (..) , decodePoolIdBech32 , encodePoolIdBech32 , poolIdBytesLength ) +import Cardano.Wallet.Primitive.Types.StakePoolSummary + ( StakePoolsSummary (..) + ) import Cardano.Wallet.Util ( ShowFmt (..) ) @@ -43,15 +43,9 @@ import Data.Aeson import Data.ByteString ( ByteString ) -import Data.Map - ( Map - ) import Data.Proxy ( Proxy (..) ) -import Data.Quantity - ( Percentage - ) import Data.Text ( Text ) @@ -71,9 +65,6 @@ import Database.Persist.Sqlite ) import Fmt ( Buildable (..) - , listF' - , mapF - , pretty ) import GHC.Generics ( Generic @@ -81,7 +72,6 @@ import GHC.Generics import qualified Codec.Binary.Bech32 as Bech32 import qualified Codec.Binary.Bech32.TH as Bech32 -import qualified Data.Map as Map import qualified Data.Text as T -- | Very short name for a stake pool. @@ -173,16 +163,3 @@ instance PersistField [PoolOwner] where instance PersistFieldSql [PoolOwner] where sqlType _ = sqlType (Proxy @Text) - -data StakePoolsSummary = StakePoolsSummary - { nOpt :: Int - , rewards :: Map PoolId Coin - , stake :: Map PoolId Percentage - } deriving (Show, Eq) - -instance Buildable StakePoolsSummary where - build StakePoolsSummary{nOpt,rewards,stake} = listF' id - [ "Stake: " <> mapF (Map.toList stake) - , "Non-myopic member rewards: " <> mapF (Map.toList rewards) - , "Optimum number of pools: " <> pretty nOpt - ] From dc6f1852758c7b285dbe51e75fb4a35c4d026f16 Mon Sep 17 00:00:00 2001 From: paolino Date: Wed, 22 Nov 2023 10:50:30 +0000 Subject: [PATCH 3/3] Factor out logging part from Network module --- .../customer-deposit-wallet.cabal | 1 + .../cardano-wallet-network-layer.cabal | 5 +- .../src/Cardano/Wallet/Network.hs | 575 ++++-------------- .../src/Cardano/Wallet/Network/Logging.hs | 243 ++++++++ .../Wallet/Network/Logging/Aggregation.hs | 239 ++++++++ 5 files changed, 601 insertions(+), 462 deletions(-) create mode 100644 lib/network-layer/src/Cardano/Wallet/Network/Logging.hs create mode 100644 lib/network-layer/src/Cardano/Wallet/Network/Logging/Aggregation.hs diff --git a/lib/customer-deposit-wallet/customer-deposit-wallet.cabal b/lib/customer-deposit-wallet/customer-deposit-wallet.cabal index a3ab9ae32cc..0d5951db1c7 100644 --- a/lib/customer-deposit-wallet/customer-deposit-wallet.cabal +++ b/lib/customer-deposit-wallet/customer-deposit-wallet.cabal @@ -50,6 +50,7 @@ library , bytestring , cardano-addresses , cardano-wallet + , cardano-wallet-network-layer , cardano-wallet-primitive , cardano-ledger-byron , containers diff --git a/lib/network-layer/cardano-wallet-network-layer.cabal b/lib/network-layer/cardano-wallet-network-layer.cabal index 740e72cd413..7e1d6750cc1 100644 --- a/lib/network-layer/cardano-wallet-network-layer.cabal +++ b/lib/network-layer/cardano-wallet-network-layer.cabal @@ -22,7 +22,10 @@ common warnings library import: warnings - exposed-modules: Cardano.Wallet.Network + exposed-modules: + Cardano.Wallet.Network.Logging.Aggregation + Cardano.Wallet.Network.Logging + Cardano.Wallet.Network -- other-modules: -- other-extensions: diff --git a/lib/network-layer/src/Cardano/Wallet/Network.hs b/lib/network-layer/src/Cardano/Wallet/Network.hs index adb7588532b..2e4b376c406 100644 --- a/lib/network-layer/src/Cardano/Wallet/Network.hs +++ b/lib/network-layer/src/Cardano/Wallet/Network.hs @@ -1,27 +1,15 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeFamilies #-} module Cardano.Wallet.Network - ( - -- * Interface + ( -- * Interface NetworkLayer (..) - -- * Errors + -- * Errors , ErrPostTx (..) - -- * Chain following + -- * Chain following , ChainFollower (..) , mapChainFollower , ChainFollowLog (..) @@ -29,7 +17,7 @@ module Cardano.Wallet.Network , mapChainSyncLog , withFollowStatsMonitoring - -- * Logging (for testing) + -- * Logging (for testing) , FollowStats (..) , Rearview (..) , emptyStats @@ -41,16 +29,19 @@ import Prelude import Cardano.Api ( AnyCardanoEra ) -import Cardano.BM.Data.Severity - ( Severity (..) - ) -import Cardano.BM.Data.Tracer - ( HasPrivacyAnnotation (..) - , HasSeverityAnnotation (..) - ) import Cardano.Slotting.Slot ( SlotNo (..) ) +import Cardano.Wallet.Network.Logging + ( ChainFollowLog (..) + , ChainSyncLog (..) + , FollowStats (..) + , Rearview (..) + , emptyStats + , mapChainSyncLog + , updateStats + , withFollowStatsMonitoring + ) import Cardano.Wallet.Primitive.Slotting ( PastHorizonException , TimeInterpreter @@ -62,7 +53,6 @@ import Cardano.Wallet.Primitive.Types.Block ( Block , BlockHeader , ChainPoint (..) - , slotNo ) import Cardano.Wallet.Primitive.Types.BlockSummary ( LightSummary @@ -88,22 +78,11 @@ import Cardano.Wallet.Primitive.Types.StakePoolSummary import Cardano.Wallet.Primitive.Types.Tx.SealedTx ( SealedTx ) -import Control.Concurrent.Class.MonadSTM - ( atomically - ) -import Control.Concurrent.Class.MonadSTM.Strict - ( StrictTMVar - , newTMVarIO - , putTMVar - , takeTMVar - ) import Control.Monad.Trans.Except ( ExceptT (..) ) import Control.Tracer ( Tracer - , contramapM - , traceWith ) import Data.List.NonEmpty ( NonEmpty (..) @@ -120,127 +99,89 @@ import Data.Text import Data.Text.Class ( ToText (..) ) -import Data.Time.Clock - ( UTCTime - , diffUTCTime - , getCurrentTime - ) -import Fmt - ( pretty - ) import GHC.Generics ( Generic ) import Internal.Cardano.Write.Tx ( MaybeInRecentEra ) -import NoThunks.Class - ( AllowThunksIn (..) - , NoThunks (..) - ) -import Numeric.Natural - ( Natural - ) -import Safe - ( headMay - ) -import UnliftIO.Async - ( race_ - ) -import UnliftIO.Concurrent - ( threadDelay - ) -import qualified Data.List.NonEmpty as NE import qualified Internal.Cardano.Write.Tx as Write -{------------------------------------------------------------------------------- - ChainSync --------------------------------------------------------------------------------} -- | Interface for network capabilities. data NetworkLayer m block = NetworkLayer { chainSync :: Tracer IO ChainFollowLog -> ChainFollower m ChainPoint BlockHeader (NonEmpty block) -> m () - -- ^ Connect to the node and run the ChainSync protocol. - -- The callbacks provided in the 'ChainFollower' argument - -- are used to handle intersection finding, - -- the arrival of new blocks, and rollbacks. - + -- ^ Connect to the node and run the ChainSync protocol. + -- The callbacks provided in the 'ChainFollower' argument + -- are used to handle intersection finding, + -- the arrival of new blocks, and rollbacks. , lightSync - :: Maybe ( - ChainFollower m ChainPoint BlockHeader (LightBlocks m Block) - -> m () - ) - -- ^ Connect to a data source that offers an efficient - -- query @Address -> Transactions@. - + :: Maybe + ( ChainFollower m ChainPoint BlockHeader (LightBlocks m Block) + -> m () + ) + -- ^ Connect to a data source that offers an efficient + -- query @Address -> Transactions@. , currentNodeTip :: m BlockHeader - -- ^ Get the current tip from the chain producer - + -- ^ Get the current tip from the chain producer , currentNodeEra :: m AnyCardanoEra - -- ^ Get the era the node is currently in. - + -- ^ Get the era the node is currently in. , currentProtocolParameters :: m ProtocolParameters - -- ^ Get the last known protocol parameters. In principle, these can - -- only change once per epoch. - + -- ^ Get the last known protocol parameters. In principle, these can + -- only change once per epoch. , currentProtocolParametersInRecentEras :: m (MaybeInRecentEra Write.PParams) -- ^ Get the last known protocol parameters for recent eras. , currentSlottingParameters :: m SlottingParameters - -- ^ Get the last known slotting parameters. In principle, these can - -- only change once per era. - + -- ^ Get the last known slotting parameters. In principle, these can + -- only change once per era. , watchNodeTip :: (BlockHeader -> m ()) -> m () - -- ^ Register a callback for when the node tip changes. - -- This function should never finish, unless the callback throws an - -- exception, which will be rethrown by this function. - + -- ^ Register a callback for when the node tip changes. + -- This function should never finish, unless the callback throws an + -- exception, which will be rethrown by this function. , postTx - :: SealedTx -> ExceptT ErrPostTx m () - -- ^ Broadcast a transaction to the chain producer - + :: SealedTx + -> ExceptT ErrPostTx m () + -- ^ Broadcast a transaction to the chain producer , stakeDistribution :: Coin -- Stake to consider for rewards -> m StakePoolsSummary - , getCachedRewardAccountBalance :: RewardAccount -- Either reward account from key hash or script hash -> m Coin - -- ^ Return the cached reward balance of an account. - -- - -- If there is no cached value, it will return `Coin 0`, and add the - -- account to the internal set of observed account, such that it will be - -- fetched later. - + -- ^ Return the cached reward balance of an account. + -- + -- If there is no cached value, it will return `Coin 0`, and add the + -- account to the internal set of observed account, such that it will be + -- fetched later. , fetchRewardAccountBalances :: Set RewardAccount -> m (Map RewardAccount Coin) - -- ^ Fetch the reward account balance of a set of accounts without - -- any caching. - + -- ^ Fetch the reward account balance of a set of accounts without + -- any caching. , timeInterpreter :: TimeInterpreter (ExceptT PastHorizonException m) - , syncProgress - :: SlotNo -> m (SyncProgress) - -- ^ Compute the ratio between the provided 'SlotNo' and the slot - -- corresponding to the current wall-clock time. - -- - -- Unlike using 'Cardano.Wallet.Primitive.SyncProgress.syncProgress' - -- after retrieving a 'timeInterpreter', this function will return - -- 'NotResponding' rather than block in the edge case when the era - -- history has not yet been fetched from the node on startup. + :: SlotNo + -> m (SyncProgress) + -- ^ Compute the ratio between the provided 'SlotNo' and the slot + -- corresponding to the current wall-clock time. + -- + -- Unlike using 'Cardano.Wallet.Primitive.SyncProgress.syncProgress' + -- after retrieving a 'timeInterpreter', this function will return + -- 'NotResponding' rather than block in the edge case when the era + -- history has not yet been fetched from the node on startup. } -- | In light-mode, we receive either a list of blocks as usual, @@ -248,78 +189,79 @@ data NetworkLayer m block = NetworkLayer type LightBlocks m block = Either (NonEmpty block) (LightSummary m) instance Functor m => Functor (NetworkLayer m) where - fmap f nl = nl - { chainSync = \tr follower -> - chainSync nl tr $ mapChainFollower id id id (fmap f) follower - } + fmap f nl = + nl + { chainSync = \tr follower -> + chainSync nl tr $ mapChainFollower id id id (fmap f) follower + } -- | A collection of callbacks to use with the 'chainSync' function. data ChainFollower m point tip blocks = ChainFollower { checkpointPolicy :: Integer -> CheckpointPolicy - -- ^ The policy for creating and pruning checkpoints that - -- is used by the 'ChainFollower'. - -- The argument of this field is the @epochStability@. - -- - -- Exposing this policy here enables any chain synchronizer - -- which does not retrieve full blocks, such as 'lightSync', - -- to specifically target those block heights at which - -- the 'ChainFollower' intends to create checkpoints. - + -- ^ The policy for creating and pruning checkpoints that + -- is used by the 'ChainFollower'. + -- The argument of this field is the @epochStability@. + -- + -- Exposing this policy here enables any chain synchronizer + -- which does not retrieve full blocks, such as 'lightSync', + -- to specifically target those block heights at which + -- the 'ChainFollower' intends to create checkpoints. , readChainPoints :: m [point] - -- ^ Callback for reading the local tip. Used to negotiate the - -- intersection with the node. - -- - -- A response of [] is interpreted as `Origin` -- i.e. the chain will be - -- served from genesis. - + -- ^ Callback for reading the local tip. Used to negotiate the + -- intersection with the node. + -- + -- A response of [] is interpreted as `Origin` -- i.e. the chain will be + -- served from genesis. , rollForward :: blocks -> tip -> m () - -- ^ Callback for rolling forward. - -- - -- Implementors _may_ delete old checkpoints while rolling forward. - + -- ^ Callback for rolling forward. + -- + -- Implementors _may_ delete old checkpoints while rolling forward. , rollBackward :: point -> m point - -- ^ Roll back to the requested slot, or further, and return the point - -- actually rolled back to. - -- - -- __Example 1:__ - -- - -- If the follower stores checkpoints for all blocks, we can always roll - -- back to the requested point exactly. - -- - -- @ - -- -- If - -- knownSlots follower `shouldReturn` [0,1,2,3] - -- let requested = SlotNo 2 - -- -- Then - -- actual <- rollBackward follower requested - -- knownSlots follower shouldReturn` [0,1,2] - -- actual `shouldBe` SlotNo 2 - -- @ - -- - -- Note that the slotNos are unlikely to be consecutive in real life, - -- but this doesn't matter, as ouroboros-network asks us to rollback to - -- points, corresponding to blocks. - -- - -- __Example 2:__ - -- - -- @ - -- -- If - -- knownSlots follower `shouldReturn` [0,9,10] - -- let requested = SlotNo 2 - -- -- Then - -- actual <- rollBackward follower requested - -- knownSlots follower shouldReturn` [0] - -- actual `shouldBe` SlotNo 0 - -- @ - -- + -- ^ Roll back to the requested slot, or further, and return the point + -- actually rolled back to. + -- + -- __Example 1:__ + -- + -- If the follower stores checkpoints for all blocks, we can always roll + -- back to the requested point exactly. + -- + -- @ + -- -- If + -- knownSlots follower `shouldReturn` [0,1,2,3] + -- let requested = SlotNo 2 + -- -- Then + -- actual <- rollBackward follower requested + -- knownSlots follower shouldReturn` [0,1,2] + -- actual `shouldBe` SlotNo 2 + -- @ + -- + -- Note that the slotNos are unlikely to be consecutive in real life, + -- but this doesn't matter, as ouroboros-network asks us to rollback to + -- points, corresponding to blocks. + -- + -- __Example 2:__ + -- + -- @ + -- -- If + -- knownSlots follower `shouldReturn` [0,9,10] + -- let requested = SlotNo 2 + -- -- Then + -- actual <- rollBackward follower requested + -- knownSlots follower shouldReturn` [0] + -- actual `shouldBe` SlotNo 0 + -- @ } mapChainFollower :: Functor m - => (point1 -> point2) -- ^ Covariant - -> (point2 -> point1) -- ^ Contravariant - -> (tip2 -> tip1) -- ^ Contravariant - -> (blocks2 -> blocks1) -- ^ Contravariant + => (point1 -> point2) + -- ^ Covariant + -> (point2 -> point1) + -- ^ Contravariant + -> (tip2 -> tip1) + -- ^ Contravariant + -> (blocks2 -> blocks1) + -- ^ Contravariant -> ChainFollower m point1 tip1 blocks1 -> ChainFollower m point2 tip2 blocks2 mapChainFollower fpoint12 fpoint21 ftip fblocks cf = @@ -343,292 +285,3 @@ instance ToText ErrPostTx where ErrPostTxValidationError msg -> msg ErrPostTxMempoolFull -> "mempool was full and refused posted transaction" - -{------------------------------------------------------------------------------- - Logging --------------------------------------------------------------------------------} - --- | Low-level logs of the ChainSync mini-protocol -data ChainSyncLog block point - = MsgChainFindIntersect [point] - | MsgChainRollForward (NonEmpty block) point - | MsgChainRollBackward point Int - | MsgChainTip point - | MsgLocalTip point - | MsgTipDistance Natural - deriving (Show, Eq, Generic) - -mapChainSyncLog - :: (b1 -> b2) - -> (p1 -> p2) - -> ChainSyncLog b1 p1 - -> ChainSyncLog b2 p2 -mapChainSyncLog f g = \case - MsgChainFindIntersect points -> MsgChainFindIntersect (g <$> points) - MsgChainRollForward blocks tip -> - MsgChainRollForward (f <$> blocks) (g tip) - MsgChainRollBackward point n -> MsgChainRollBackward (g point) n - MsgChainTip point -> MsgChainTip (g point) - MsgLocalTip point -> MsgLocalTip (g point) - MsgTipDistance d -> MsgTipDistance d - -instance ToText (ChainSyncLog BlockHeader ChainPoint) where - toText = \case - MsgChainFindIntersect cps -> mconcat - [ "Requesting intersection using " - , toText (length cps) - , " points" - , maybe "" ((", the latest being " <>) . pretty) (headMay cps) - ] - MsgChainRollForward headers tip -> - let buildRange (x :| []) = x - buildRange xs = NE.head xs <> ".." <> NE.last xs - slots = pretty . slotNo <$> headers - in mconcat - [ "ChainSync roll forward: " - , "applying blocks at slots [", buildRange slots, "]" - , ", tip is " - , pretty tip - ] - MsgChainRollBackward b 0 -> - "ChainSync roll backward: " <> pretty b - MsgChainRollBackward b bufferSize -> mconcat - [ "ChainSync roll backward: " - , pretty b - , ", handled inside pipeline buffer with remaining length " - , toText bufferSize - ] - MsgChainTip tip -> - "Node tip is " <> pretty tip - MsgLocalTip point -> - "Synchronized with point: " <> pretty point - MsgTipDistance d -> "Distance to chain tip: " <> toText d <> " blocks" - -instance HasPrivacyAnnotation (ChainSyncLog block point) - -instance HasSeverityAnnotation (ChainSyncLog block point) where - getSeverityAnnotation = \case - MsgChainFindIntersect{} -> Debug - MsgChainRollForward{} -> Debug - MsgChainRollBackward{} -> Debug - MsgChainTip{} -> Debug - MsgLocalTip{} -> Debug - MsgTipDistance{} -> Debug - --- | Higher level log of a chain follower. --- Includes computed statistics about synchronization progress. -data ChainFollowLog - = MsgChainSync (ChainSyncLog BlockHeader ChainPoint) - | MsgFollowStats (FollowStats Rearview) - | MsgStartFollowing - deriving (Show, Eq, Generic) - -instance ToText ChainFollowLog where - toText = \case - MsgChainSync msg -> toText msg - MsgFollowStats s -> toText s - MsgStartFollowing -> "Chain following starting." - -instance HasPrivacyAnnotation ChainFollowLog -instance HasSeverityAnnotation ChainFollowLog where - getSeverityAnnotation = \case - MsgChainSync msg -> getSeverityAnnotation msg - MsgFollowStats s -> getSeverityAnnotation s - MsgStartFollowing -> Info - -{------------------------------------------------------------------------------- - Log aggregation --------------------------------------------------------------------------------} --- | Statistics of interest from the follow-function. --- --- The @f@ allows us to use 'Rearview' to keep track of both current and --- previously logged stats, and perform operations over it in a nice way. -data FollowStats f = FollowStats - { blocksApplied :: !(f Int) - , rollbacks :: !(f Int) - , localTip :: !(f ChainPoint) - , time :: !(f UTCTime) - -- ^ NOTE: Current time is not updated until @flush@ is called. - , prog :: !(f SyncProgress) - -- ^ NOTE: prog is not updated until @flush@ is called. - } deriving (Generic) - --- It seems UTCTime contains thunks internally. This shouldn't matter as we --- 1. Change it seldom - from @flush@, not from @updateStats@ --- 2. Set to a completely new value when we do change it. -deriving via (AllowThunksIn '["time"] (FollowStats Rearview)) - instance (NoThunks (FollowStats Rearview)) - -deriving instance Show (FollowStats Rearview) -deriving instance Eq (FollowStats Rearview) - --- | Change the @f@ wrapping each record field. -hoistStats - :: (forall a. f a -> g a) - -> FollowStats f - -> FollowStats g -hoistStats f (FollowStats a b c d e) = - FollowStats (f a) (f b) (f c) (f d) (f e) - --- | A 'Rearview' consists of a past value and a present value. --- Useful for keeping track of past logs. --- --- The idea is to --- 1. Reconstruct a model of the @current@ @state@ using a @Trace@ --- 2. Sometimes log the difference between the @current@ state and the most --- recently logged one. -data Rearview a = Rearview - { past :: !a -- ^ Most previously logged state - , current :: !a -- ^ Not-yet logged state - } deriving (Eq, Show, Functor, Generic) - -instance NoThunks a => NoThunks (Rearview a) - -initRearview :: a -> Rearview a -initRearview a = Rearview a a - --- | Modify the present state of a @Rearview state@ -overCurrent :: (a -> a) -> Rearview a -> Rearview a -overCurrent f (Rearview pas cur) = Rearview pas (f cur) - -emptyStats :: UTCTime -> FollowStats Rearview -emptyStats t = FollowStats (f 0) (f 0) (f ChainPointAtGenesis) (f t) (f p) - where - f = initRearview - p = NotResponding -- Hijacked as an initial value for simplicity. - --- | Update the current statistics based on a new log message. -updateStats - :: ChainSyncLog block ChainPoint - -> FollowStats Rearview -> FollowStats Rearview -updateStats msg s = case msg of - MsgChainRollForward blocks _tip -> - s { blocksApplied = overCurrent (+ NE.length blocks) (blocksApplied s) } - MsgChainRollBackward _ 0 -> - -- rolled back in a way that could not be handled by the pipeline buffer - s { rollbacks = overCurrent (1 +) (rollbacks s) } - MsgLocalTip point -> - s { localTip = overCurrent (const point) (localTip s) } - _ -> s - -instance ToText (FollowStats Rearview) where - toText st@(FollowStats b r tip t progress) = - syncStatus <> " " <> stats <> sevExpl - where - syncStatus = case progress of - Rearview NotResponding Ready -> - "In sync." - Rearview Ready Ready -> - "Still in sync." - Rearview NotResponding NotResponding -> - "Still not syncing." - Rearview (Syncing _p) Ready -> - "In sync!" - Rearview Ready (Syncing p) -> - "Fell out of sync (" <> (pretty p) <> ")" - Rearview _ (Syncing p) -> - "Syncing (" <> (pretty p) <> ")" - Rearview past_ NotResponding -> - "Not responding. Previously " <> (pretty past_) <> "." - stats = mconcat - [ "Applied " <> pretty (using (-) b) <> " blocks, " - , pretty (using (-) r) <> " rollbacks " - , "in the last " <> pretty (using diffUTCTime t) <> ". " - , "Current tip is " <> pretty (current tip) <> "." - ] - where - using f x = f (current x) (past x) - - sevExpl = maybe - "" - (\x -> " (" <> x <> ")") - (snd $ explainedSeverityAnnotation st) - --- NOTE: Here we check if the sync progress is going backwards, which --- would be a sign the wallet is overloaded (or rollbacks) --- --- But this check might be in the wrong place. Might be better to --- produce new logs from inside the updateStats function and immeditely --- warn there. -explainedSeverityAnnotation :: FollowStats Rearview -> (Severity, Maybe Text) -explainedSeverityAnnotation s - | progressMovedBackwards = (Warning, Just "progress decreased") - | noBlocks && notRestored = (Warning, Just "not applying blocks") - | nowInSync = (Notice, Nothing) - | otherwise = (Info, Nothing) - where - progressMovedBackwards = current (prog s) < past (prog s) - nowInSync = current (prog s) == Ready && past (prog s) < Ready - notRestored = current (prog s) /= Ready - noBlocks = (current (blocksApplied s) - past (blocksApplied s)) <= 0 - -instance HasSeverityAnnotation (FollowStats Rearview) where - getSeverityAnnotation = fst . explainedSeverityAnnotation - --- | Update the 'TMVar' holding the 'FollowStats'@ @'Rearview' --- to forget the 'past' values and replace them with the 'current' ones. --- Also update the time and sync process. -flushStats - :: UTCTime - -> (SlotNo -> IO SyncProgress) - -> StrictTMVar IO (FollowStats Rearview) - -> IO (FollowStats Rearview) -flushStats t calcSyncProgress var = do - s <- atomically $ takeTMVar var - p <- calcSyncProgress $ pseudoSlotNo $ current $ localTip s - let s' = s { time = overCurrent (const t) (time s) } - { prog = overCurrent (const p) (prog s) } - atomically $ putTMVar var $ hoistStats forgetPast s' - return s' - where - forgetPast (Rearview _past curr) = initRearview curr - --- See NOTE [PointSlotNo] -pseudoSlotNo :: ChainPoint -> SlotNo -pseudoSlotNo ChainPointAtGenesis = SlotNo 0 -pseudoSlotNo (ChainPoint slot _) = slot - --- | Monitors health and statistics by inspecting the messages --- submitted to a 'ChainSyncLog' tracer. --- --- Statistics are computed in regular time intervals. --- In order to do that, the monitor runs in separate thread. --- The results are submitted to the outer 'ChainFollowLog' tracer. -withFollowStatsMonitoring - :: Tracer IO ChainFollowLog - -> (SlotNo -> IO SyncProgress) - -> (Tracer IO (ChainSyncLog BlockHeader ChainPoint) -> IO ()) - -> IO () -withFollowStatsMonitoring tr calcSyncProgress act = do - t0 <- getCurrentTime - var <- newTMVarIO $ emptyStats t0 - let trChainSyncLog = flip contramapM tr $ \msg -> do - atomically $ do - s <- takeTMVar var - putTMVar var $! updateStats msg s - pure $ MsgChainSync msg - traceWith trChainSyncLog $ MsgLocalTip ChainPointAtGenesis - race_ - (act trChainSyncLog) - (loop var startupDelay) - where - loop var delay = do - threadDelay delay - t <- getCurrentTime - s <- flushStats t calcSyncProgress var - traceWith tr $ MsgFollowStats s - let delay' = - if (current (prog s)) == Ready - then restoredDelay - else syncingDelay - loop var delay' - - -- | Delay from launch to the first status update - startupDelay = 5 * second - -- | Delay between status updates when restored - restoredDelay = 5 * minute - -- | Delay between status updates when not restored - syncingDelay = 30 * second - - second = 1000*1000 - minute = 60 * second diff --git a/lib/network-layer/src/Cardano/Wallet/Network/Logging.hs b/lib/network-layer/src/Cardano/Wallet/Network/Logging.hs new file mode 100644 index 00000000000..c1d90371cf8 --- /dev/null +++ b/lib/network-layer/src/Cardano/Wallet/Network/Logging.hs @@ -0,0 +1,243 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Rank2Types #-} + +module Cardano.Wallet.Network.Logging + ( -- * Chain following + ChainFollowLog (..) + , ChainSyncLog (..) + , mapChainSyncLog + , withFollowStatsMonitoring + + -- * Logging (for testing) + , FollowStats (..) + , Rearview (..) + , emptyStats + , updateStats + ) where + +import Prelude + +import Cardano.BM.Data.Severity + ( Severity (..) + ) +import Cardano.BM.Data.Tracer + ( HasPrivacyAnnotation (..) + , HasSeverityAnnotation (..) + ) +import Cardano.Slotting.Slot + ( SlotNo (..) + ) +import Cardano.Wallet.Network.Logging.Aggregation + ( FollowStats (..) + , Rearview (..) + , emptyStats + , flushStats + , overCurrent + ) +import Cardano.Wallet.Primitive.SyncProgress + ( SyncProgress (..) + ) +import Cardano.Wallet.Primitive.Types.Block + ( BlockHeader + , ChainPoint (..) + , slotNo + ) +import Control.Concurrent.Class.MonadSTM + ( atomically + ) +import Control.Concurrent.Class.MonadSTM.Strict + ( newTMVarIO + , putTMVar + , takeTMVar + ) +import Control.Tracer + ( Tracer + , contramapM + , traceWith + ) +import Data.List.NonEmpty + ( NonEmpty (..) + ) +import Data.Text.Class + ( ToText (..) + ) +import Data.Time.Clock + ( getCurrentTime + ) +import Fmt + ( pretty + ) +import GHC.Generics + ( Generic + ) +import Numeric.Natural + ( Natural + ) +import Safe + ( headMay + ) +import UnliftIO.Async + ( race_ + ) +import UnliftIO.Concurrent + ( threadDelay + ) + +import qualified Data.List.NonEmpty as NE + +-- | Low-level logs of the ChainSync mini-protocol +data ChainSyncLog block point + = MsgChainFindIntersect [point] + | MsgChainRollForward (NonEmpty block) point + | MsgChainRollBackward point Int + | MsgChainTip point + | MsgLocalTip point + | MsgTipDistance Natural + deriving (Show, Eq, Generic) + +mapChainSyncLog + :: (b1 -> b2) + -> (p1 -> p2) + -> ChainSyncLog b1 p1 + -> ChainSyncLog b2 p2 +mapChainSyncLog f g = \case + MsgChainFindIntersect points -> MsgChainFindIntersect (g <$> points) + MsgChainRollForward blocks tip -> + MsgChainRollForward (f <$> blocks) (g tip) + MsgChainRollBackward point n -> MsgChainRollBackward (g point) n + MsgChainTip point -> MsgChainTip (g point) + MsgLocalTip point -> MsgLocalTip (g point) + MsgTipDistance d -> MsgTipDistance d + +instance ToText (ChainSyncLog BlockHeader ChainPoint) where + toText = \case + MsgChainFindIntersect cps -> + mconcat + [ "Requesting intersection using " + , toText (length cps) + , " points" + , maybe "" ((", the latest being " <>) . pretty) (headMay cps) + ] + MsgChainRollForward headers tip -> + let buildRange (x :| []) = x + buildRange xs = NE.head xs <> ".." <> NE.last xs + slots = pretty . slotNo <$> headers + in mconcat + [ "ChainSync roll forward: " + , "applying blocks at slots [" + , buildRange slots + , "]" + , ", tip is " + , pretty tip + ] + MsgChainRollBackward b 0 -> + "ChainSync roll backward: " <> pretty b + MsgChainRollBackward b bufferSize -> + mconcat + [ "ChainSync roll backward: " + , pretty b + , ", handled inside pipeline buffer with remaining length " + , toText bufferSize + ] + MsgChainTip tip -> + "Node tip is " <> pretty tip + MsgLocalTip point -> + "Synchronized with point: " <> pretty point + MsgTipDistance d -> "Distance to chain tip: " <> toText d <> " blocks" + +instance HasPrivacyAnnotation (ChainSyncLog block point) + +instance HasSeverityAnnotation (ChainSyncLog block point) where + getSeverityAnnotation = \case + MsgChainFindIntersect{} -> Debug + MsgChainRollForward{} -> Debug + MsgChainRollBackward{} -> Debug + MsgChainTip{} -> Debug + MsgLocalTip{} -> Debug + MsgTipDistance{} -> Debug + +-- | Higher level log of a chain follower. +-- Includes computed statistics about synchronization progress. +data ChainFollowLog + = MsgChainSync (ChainSyncLog BlockHeader ChainPoint) + | MsgFollowStats (FollowStats Rearview) + | MsgStartFollowing + deriving (Show, Eq, Generic) + +instance ToText ChainFollowLog where + toText = \case + MsgChainSync msg -> toText msg + MsgFollowStats s -> toText s + MsgStartFollowing -> "Chain following starting." + +instance HasPrivacyAnnotation ChainFollowLog +instance HasSeverityAnnotation ChainFollowLog where + getSeverityAnnotation = \case + MsgChainSync msg -> getSeverityAnnotation msg + MsgFollowStats s -> getSeverityAnnotation s + MsgStartFollowing -> Info + +-- | Update the current statistics based on a new log message. +updateStats + :: ChainSyncLog block ChainPoint + -> FollowStats Rearview + -> FollowStats Rearview +updateStats msg s = case msg of + MsgChainRollForward blocks _tip -> + s{blocksApplied = overCurrent (+ NE.length blocks) (blocksApplied s)} + MsgChainRollBackward _ 0 -> + -- rolled back in a way that could not be handled by the pipeline buffer + s{rollbacks = overCurrent (1 +) (rollbacks s)} + MsgLocalTip point -> + s{localTip = overCurrent (const point) (localTip s)} + _ -> s + +-- | Monitors health and statistics by inspecting the messages +-- submitted to a 'ChainSyncLog' tracer. +-- +-- Statistics are computed in regular time intervals. +-- In order to do that, the monitor runs in separate thread. +-- The results are submitted to the outer 'ChainFollowLog' tracer. +withFollowStatsMonitoring + :: Tracer IO ChainFollowLog + -> (SlotNo -> IO SyncProgress) + -> (Tracer IO (ChainSyncLog BlockHeader ChainPoint) -> IO ()) + -> IO () +withFollowStatsMonitoring tr calcSyncProgress act = do + t0 <- getCurrentTime + var <- newTMVarIO $ emptyStats t0 + let trChainSyncLog = flip contramapM tr $ \msg -> do + atomically $ do + s <- takeTMVar var + putTMVar var $! updateStats msg s + pure $ MsgChainSync msg + traceWith trChainSyncLog $ MsgLocalTip ChainPointAtGenesis + race_ + (act trChainSyncLog) + (loop var startupDelay) + where + loop var delay = do + threadDelay delay + t <- getCurrentTime + s <- flushStats t calcSyncProgress var + traceWith tr $ MsgFollowStats s + let delay' = + if (current (prog s)) == Ready + then restoredDelay + else syncingDelay + loop var delay' + + -- \| Delay from launch to the first status update + startupDelay = 5 * second + -- \| Delay between status updates when restored + restoredDelay = 5 * minute + -- \| Delay between status updates when not restored + syncingDelay = 30 * second + + second = 1000 * 1000 + minute = 60 * second diff --git a/lib/network-layer/src/Cardano/Wallet/Network/Logging/Aggregation.hs b/lib/network-layer/src/Cardano/Wallet/Network/Logging/Aggregation.hs new file mode 100644 index 00000000000..a42e00af648 --- /dev/null +++ b/lib/network-layer/src/Cardano/Wallet/Network/Logging/Aggregation.hs @@ -0,0 +1,239 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE StandaloneDeriving #-} + +module Cardano.Wallet.Network.Logging.Aggregation + ( FollowStats (..) + , Rearview (..) + , emptyStats + , flushStats + , overCurrent + ) where + +import Prelude + +import Cardano.BM.Data.Severity + ( Severity (..) + ) +import Cardano.BM.Data.Tracer + ( HasSeverityAnnotation (..) + ) +import Cardano.Slotting.Slot + ( SlotNo (..) + ) +import Cardano.Wallet.Primitive.SyncProgress + ( SyncProgress (..) + ) +import Cardano.Wallet.Primitive.Types.Block + ( ChainPoint (..) + ) +import Control.Concurrent.Class.MonadSTM + ( atomically + ) +import Control.Concurrent.Class.MonadSTM.Strict + ( StrictTMVar + , putTMVar + , takeTMVar + ) +import Data.Text + ( Text + ) +import Data.Text.Class + ( ToText (..) + ) +import Data.Time.Clock + ( UTCTime + , diffUTCTime + ) +import Fmt + ( pretty + ) +import GHC.Generics + ( Generic + ) +import NoThunks.Class + ( AllowThunksIn (..) + , NoThunks (..) + ) + +-- | Statistics of interest from the follow-function. +-- +-- The @f@ allows us to use 'Rearview' to keep track of both current and +-- previously logged stats, and perform operations over it in a nice way. +data FollowStats f = FollowStats + { blocksApplied :: !(f Int) + , rollbacks :: !(f Int) + , localTip :: !(f ChainPoint) + , time :: !(f UTCTime) + -- ^ NOTE: Current time is not updated until @flush@ is called. + , prog :: !(f SyncProgress) + -- ^ NOTE: prog is not updated until @flush@ is called. + } + deriving (Generic) + +-- It seems UTCTime contains thunks internally. This shouldn't matter as we +-- 1. Change it seldom - from @flush@, not from @updateStats@ +-- 2. Set to a completely new value when we do change it. +deriving via + (AllowThunksIn '["time"] (FollowStats Rearview)) + instance + (NoThunks (FollowStats Rearview)) + +deriving instance Show (FollowStats Rearview) +deriving instance Eq (FollowStats Rearview) + +-- | Change the @f@ wrapping each record field. +hoistStats + :: (forall a. f a -> g a) + -> FollowStats f + -> FollowStats g +hoistStats f (FollowStats a b c d e) = + FollowStats (f a) (f b) (f c) (f d) (f e) + +-- | A 'Rearview' consists of a past value and a present value. +-- Useful for keeping track of past logs. +-- +-- The idea is to +-- 1. Reconstruct a model of the @current@ @state@ using a @Trace@ +-- 2. Sometimes log the difference between the @current@ state and the most +-- recently logged one. +data Rearview a = Rearview + { past :: !a + -- ^ Most previously logged state + , current :: !a + -- ^ Not-yet logged state + } + deriving (Eq, Show, Functor, Generic) + +instance NoThunks a => NoThunks (Rearview a) + +initRearview :: a -> Rearview a +initRearview a = Rearview a a + +-- | Modify the present state of a @Rearview state@ +overCurrent :: (a -> a) -> Rearview a -> Rearview a +overCurrent f (Rearview pas cur) = Rearview pas (f cur) + +emptyStats :: UTCTime -> FollowStats Rearview +emptyStats t = FollowStats (f 0) (f 0) (f ChainPointAtGenesis) (f t) (f p) + where + f = initRearview + p = NotResponding -- Hijacked as an initial value for simplicity. + +instance ToText (FollowStats Rearview) where + toText st@(FollowStats b r tip t progress) = + syncStatus <> " " <> stats <> sevExpl + where + syncStatus = case progress of + Rearview NotResponding Ready -> + "In sync." + Rearview Ready Ready -> + "Still in sync." + Rearview NotResponding NotResponding -> + "Still not syncing." + Rearview (Syncing _p) Ready -> + "In sync!" + Rearview Ready (Syncing p) -> + "Fell out of sync (" <> (pretty p) <> ")" + Rearview _ (Syncing p) -> + "Syncing (" <> (pretty p) <> ")" + Rearview past_ NotResponding -> + "Not responding. Previously " <> (pretty past_) <> "." + stats = + mconcat + [ "Applied " <> pretty (using (-) b) <> " blocks, " + , pretty (using (-) r) <> " rollbacks " + , "in the last " <> pretty (using diffUTCTime t) <> ". " + , "Current tip is " <> pretty (current tip) <> "." + ] + where + using f x = f (current x) (past x) + + sevExpl = + maybe + "" + (\x -> " (" <> x <> ")") + (snd $ explainedSeverityAnnotation st) + +-- NOTE: Here we check if the sync progress is going backwards, which +-- would be a sign the wallet is overloaded (or rollbacks) +-- +-- But this check might be in the wrong place. Might be better to +-- produce new logs from inside the updateStats function and immeditely +-- warn there. +explainedSeverityAnnotation :: FollowStats Rearview -> (Severity, Maybe Text) +explainedSeverityAnnotation s + | progressMovedBackwards = (Warning, Just "progress decreased") + | noBlocks && notRestored = (Warning, Just "not applying blocks") + | nowInSync = (Notice, Nothing) + | otherwise = (Info, Nothing) + where + progressMovedBackwards = current (prog s) < past (prog s) + nowInSync = current (prog s) == Ready && past (prog s) < Ready + notRestored = current (prog s) /= Ready + noBlocks = (current (blocksApplied s) - past (blocksApplied s)) <= 0 + +instance HasSeverityAnnotation (FollowStats Rearview) where + getSeverityAnnotation = fst . explainedSeverityAnnotation + +-- | Update the 'TMVar' holding the 'FollowStats'@ @'Rearview' +-- to forget the 'past' values and replace them with the 'current' ones. +-- Also update the time and sync process. +flushStats + :: UTCTime + -> (SlotNo -> IO SyncProgress) + -> StrictTMVar IO (FollowStats Rearview) + -> IO (FollowStats Rearview) +flushStats t calcSyncProgress var = do + s <- atomically $ takeTMVar var + p <- calcSyncProgress $ pseudoSlotNo $ current $ localTip s + let s' = + s{time = overCurrent (const t) (time s)} + { prog = overCurrent (const p) (prog s) + } + atomically $ putTMVar var $ hoistStats forgetPast s' + return s' + where + forgetPast (Rearview _past curr) = initRearview curr + +-- See NOTE [PointSlotNo] +pseudoSlotNo :: ChainPoint -> SlotNo +pseudoSlotNo ChainPointAtGenesis = SlotNo 0 +pseudoSlotNo (ChainPoint slot _) = slot + +{- NOTE [PointSlotNo] + +'SlotNo' cannot represent the genesis point. + +Historical hack. The DB layer can't represent 'Origin' in the database, +instead we have mapped it to 'SlotNo 0', which is wrong. + +Rolling back to SlotNo 0 instead of Origin is fine for followers starting +from genesis (which should be the majority of cases). Other, non-trivial +rollbacks to genesis cannot occur on mainnet (genesis is years within +stable part, and there were no rollbacks in byron). + +Could possibly be problematic in the beginning of a testnet without a +byron era. /Perhaps/ this is what is happening in the +>>> [cardano-wallet.pools-engine:Error:1293] [2020-11-24 10:02:04.00 UTC] +>>> Couldn't store production for given block before it conflicts with +>>> another block. Conflicting block header is: +>>> 5bde7e7b<-[f1b35b98-4290#2008] +errors observed in the integration tests. + +The issue has been partially fixed in that 'rollbackTo' now takes +a 'Slot' as argument, which can represent the 'Origin'. +However, the database itself mostly stores slot numbers. + +FIXME LATER during ADP-1043: As we move towards in-memory data, +all slot numbers in the DB file will either be replaced by +the 'Slot' type, or handled slightly differently when it +is clear that the data cannot exist at the genesis point +(e.g. for TxHistory). + +-}