From e1ad0f145cd79c9fecb5edc0853d8a5c1cb64d50 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Mon, 29 Sep 2025 16:56:54 +0200 Subject: [PATCH 01/11] Moved `cardano-ping` to `cardano-diffusion:ping` Even though it's not implemented using `cardano-diffusion`, we often need to release it together with `cardano-diffusion`. --- cabal.project | 3 +- cardano-diffusion/cardano-diffusion.cabal | 20 ++ .../ping}/Cardano/Network/Ping.hs | 0 cardano-ping/CHANGELOG.md | 184 ------------------ cardano-ping/LICENSE | 177 ----------------- cardano-ping/NOTICE | 14 -- cardano-ping/README.md | 3 - cardano-ping/cardano-ping.cabal | 56 ------ cardano-ping/changelog.d/scriv.ini | 15 -- 9 files changed, 21 insertions(+), 451 deletions(-) rename {cardano-ping/src => cardano-diffusion/ping}/Cardano/Network/Ping.hs (100%) delete mode 100644 cardano-ping/CHANGELOG.md delete mode 100644 cardano-ping/LICENSE delete mode 100644 cardano-ping/NOTICE delete mode 100644 cardano-ping/README.md delete mode 100644 cardano-ping/cardano-ping.cabal delete mode 100644 cardano-ping/changelog.d/scriv.ini diff --git a/cabal.project b/cabal.project index d89ffe33196..9499a65a997 100644 --- a/cabal.project +++ b/cabal.project @@ -20,8 +20,7 @@ index-state: -- Bump this if you need newer packages from CHaP , cardano-haskell-packages 2025-03-18T17:41:11Z -packages: ./cardano-ping - ./monoidal-synchronisation +packages: ./monoidal-synchronisation ./network-mux ./ouroboros-network ./cardano-diffusion diff --git a/cardano-diffusion/cardano-diffusion.cabal b/cardano-diffusion/cardano-diffusion.cabal index 7b1eb44914b..5e5490a7689 100644 --- a/cardano-diffusion/cardano-diffusion.cabal +++ b/cardano-diffusion/cardano-diffusion.cabal @@ -513,3 +513,23 @@ library subscription io-classes:si-timers ^>=1.8.0.1, network-mux ^>=0.9, ouroboros-network:{api, framework} ^>=0.23, + +library ping + import: ghc-options + visibility: public + hs-source-dirs: ping + exposed-modules: Cardano.Network.Ping + build-depends: + aeson >=2.1.1.0 && <3, + base >=4.14 && <4.22, + bytestring >=0.10 && <0.13, + cborg >=0.2.8 && <0.3, + contra-tracer >=0.1 && <0.3, + io-classes:{si-timers, strict-stm} ^>=1.8.0.1, + iproute ^>=1.7.15, + network ^>=3.2.7, + network-mux ^>=0.9, + tdigest ^>=0.3, + text >=1.2.4 && <2.2, + time >=1.9.1 && <1.14, + transformers >=0.5 && <0.7, diff --git a/cardano-ping/src/Cardano/Network/Ping.hs b/cardano-diffusion/ping/Cardano/Network/Ping.hs similarity index 100% rename from cardano-ping/src/Cardano/Network/Ping.hs rename to cardano-diffusion/ping/Cardano/Network/Ping.hs diff --git a/cardano-ping/CHANGELOG.md b/cardano-ping/CHANGELOG.md deleted file mode 100644 index 2f1d0bfddea..00000000000 --- a/cardano-ping/CHANGELOG.md +++ /dev/null @@ -1,184 +0,0 @@ -# cardano-ping changelog - - - - -## 0.9.0.0 -- 2026-06-28 - -### Breaking changes - -* Added support of `NodeToClientV_21`. - -### Non-breaking changes - -* Updated to `network-mux-0.9` - -## 0.8.0.1 -- 2025-05-13 - -### Breaking changes - -### Non-breaking changes - -* Adapt to buffered socket bearers from network-mux 0.8 - -## 0.8.0.0 -- 2025-02-25 - -### Breaking changes - -* Added `NodeToClientVersionV20` - -## 0.7.0.0 -- 2024-10-17 - -### Breaking changes - -* Updated dependencies. - -## 0.6.0.0 -- 2024-10-17 - -### Breaking changes - -* Support `NodeToClientV_19` - -### Non-breaking changes - -* Use `network-mux-0.5`. - -### Non-breaking changes - -## 0.5.0.0 -- 2024-10-11 - -### Breaking changes - -* Added `NodeToClientVersionV18` -* Added `NodeToNodeVersion14` - -## 0.4.0.1 -- 2024-08-27 - -### Breaking changes - -### Non-breaking changes - -* bump for bad ref in chap for 0.4.0.0 - -## 0.4.0.0 - 2024-08-22 - -### Breaking changes - -* Log remote address and port in tip message -* Added `NodeToClientVersionV17` - -### Non-breaking changes - -* Make it error whenever there's a decoding error or similar - -## 0.3.0.0 -- 2024-08-07 - -### Breaking changes - -* Add support for requesting tip from remote peer. - -### Non-breaking changes - -* Make it build with ghc-9.10 - -## 0.2.0.14 -- 2024-06-07 - -### Breaking changes - -* Addapted to `network-mux` changes in https://github.com/IntersectMBO/ouroboros-network/pull/4997 - -### Non-breaking changes - -* Bump io-sim and io-classes - -## 0.2.0.13 - -### Non-breaking changes - -* Add support for decoding peersharing support -* Add support for NodeToNodeVersionV13 - -## 0.2.0.12 - -### Non-breaking changes - -* Use `io-sim-1.4.1` - -## 0.2.0.11 - -### Non-breaking changes - -* ghc-9.8 support. - -## 0.2.0.10 -- 2023-12-08 - -### Non-breaking changes - -* Expose more `InitiatorOnly`, `handshakeDec`, `handshakeReq` and `isSameVersionAndMagic` from `Cardano.Network.Ping`. - -## 0.2.0.9 -- 2023-11-16 - -### Non-breaking changes - -* Use `io-sim-1.3.0.0`. -* ghc-9.8 support. - -## 0.2.0.8 -- 2023-11-02 - -### Breaking changes - -### Non-breaking changes - -* Use `NonEmpty` for `handshakeReqEnc`'s parameter to eliminate an impossible - `error`. - -## 0.2.0.7 -- 2023-10-20 - -* In presence of flag `-j`, output json when printing - `network_rtt`, `handshake_rtt`, `negotiated_version` and `queried_versions`. - -## 0.2.0.6 -- 2023-08-09 - -* Use `io-classes-1.2` - -## 0.2.0.5 -- 2023-06-15 - -* Fixed support of `node-to-client` protocol on Unix sockets. -* Fixed encoding of `NodeToClientVersionV16` version data. -* Fixed decoding of `NodeToClientVersionV16` and `NodeToNodeVersionV12`. - -## 0.2.0.4 -- 2023-06-12 - -* Using `ISO8601` time format. -* Only print negotiated version, if negotiation took place on the remote side. -* Fixed formatting of ping messages. - -## 0.2.0.3 -- 2023-06-09 - -* For versions strictly lower than `NodeToNodeV_11`, send - `InitiatorAndResponder` flag when quering. For these versions querying is - not recognised by the remote side, and thus it will do handshake negotiation. -* Only print the query result if querying is supported by the remote side. - -## 0.2.0.2 -- 2023-06-08 - -* Support `NodeToNodeV_11`, `NodeToNodeV_12` and `NodeToClientV_16`. -* Fix delay/timeout bugs (miliseconds were used instead of seconds). -* Print query even if --quiet flag is given. -* Instead of a boolean flag print `InitiatorOnly` or `InitiatorAndResponder`. -* Fixed encoding of `NodeToNodeV_11`. - - -## 0.2.0.1 -- 2023-05-26 - -* Support `ghc-9.6`. - -## 0.2.0.0 -- 2023-05-08 - -* Support for `NodeToNodeV_12` and `NodeToClientV_16`, e.g. support for - querying `NodeToNodeVersionData` / `NodeToClientVersionData`. -* Support `NodeToNodeV_11` and `NodeToClientV_15` (peer sharing). - -## 0.1.0.0 -- 2022-12-14 - -* This code was originally from the cardano-ping executable component of the `network-mux` package. diff --git a/cardano-ping/LICENSE b/cardano-ping/LICENSE deleted file mode 100644 index f433b1a53f5..00000000000 --- a/cardano-ping/LICENSE +++ /dev/null @@ -1,177 +0,0 @@ - - Apache License - Version 2.0, January 2004 - http://www.apache.org/licenses/ - - TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION - - 1. Definitions. - - "License" shall mean the terms and conditions for use, reproduction, - and distribution as defined by Sections 1 through 9 of this document. - - "Licensor" shall mean the copyright owner or entity authorized by - the copyright owner that is granting the License. - - "Legal Entity" shall mean the union of the acting entity and all - other entities that control, are controlled by, or are under common - control with that entity. For the purposes of this definition, - "control" means (i) the power, direct or indirect, to cause the - direction or management of such entity, whether by contract or - otherwise, or (ii) ownership of fifty percent (50%) or more of the - outstanding shares, or (iii) beneficial ownership of such entity. - - "You" (or "Your") shall mean an individual or Legal Entity - exercising permissions granted by this License. - - "Source" form shall mean the preferred form for making modifications, - including but not limited to software source code, documentation - source, and configuration files. - - "Object" form shall mean any form resulting from mechanical - transformation or translation of a Source form, including but - not limited to compiled object code, generated documentation, - and conversions to other media types. - - "Work" shall mean the work of authorship, whether in Source or - Object form, made available under the License, as indicated by a - copyright notice that is included in or attached to the work - (an example is provided in the Appendix below). - - "Derivative Works" shall mean any work, whether in Source or Object - form, that is based on (or derived from) the Work and for which the - editorial revisions, annotations, elaborations, or other modifications - represent, as a whole, an original work of authorship. For the purposes - of this License, Derivative Works shall not include works that remain - separable from, or merely link (or bind by name) to the interfaces of, - the Work and Derivative Works thereof. - - "Contribution" shall mean any work of authorship, including - the original version of the Work and any modifications or additions - to that Work or Derivative Works thereof, that is intentionally - submitted to Licensor for inclusion in the Work by the copyright owner - or by an individual or Legal Entity authorized to submit on behalf of - the copyright owner. For the purposes of this definition, "submitted" - means any form of electronic, verbal, or written communication sent - to the Licensor or its representatives, including but not limited to - communication on electronic mailing lists, source code control systems, - and issue tracking systems that are managed by, or on behalf of, the - Licensor for the purpose of discussing and improving the Work, but - excluding communication that is conspicuously marked or otherwise - designated in writing by the copyright owner as "Not a Contribution." - - "Contributor" shall mean Licensor and any individual or Legal Entity - on behalf of whom a Contribution has been received by Licensor and - subsequently incorporated within the Work. - - 2. Grant of Copyright License. Subject to the terms and conditions of - this License, each Contributor hereby grants to You a perpetual, - worldwide, non-exclusive, no-charge, royalty-free, irrevocable - copyright license to reproduce, prepare Derivative Works of, - publicly display, publicly perform, sublicense, and distribute the - Work and such Derivative Works in Source or Object form. - - 3. Grant of Patent License. Subject to the terms and conditions of - this License, each Contributor hereby grants to You a perpetual, - worldwide, non-exclusive, no-charge, royalty-free, irrevocable - (except as stated in this section) patent license to make, have made, - use, offer to sell, sell, import, and otherwise transfer the Work, - where such license applies only to those patent claims licensable - by such Contributor that are necessarily infringed by their - Contribution(s) alone or by combination of their Contribution(s) - with the Work to which such Contribution(s) was submitted. If You - institute patent litigation against any entity (including a - cross-claim or counterclaim in a lawsuit) alleging that the Work - or a Contribution incorporated within the Work constitutes direct - or contributory patent infringement, then any patent licenses - granted to You under this License for that Work shall terminate - as of the date such litigation is filed. - - 4. Redistribution. You may reproduce and distribute copies of the - Work or Derivative Works thereof in any medium, with or without - modifications, and in Source or Object form, provided that You - meet the following conditions: - - (a) You must give any other recipients of the Work or - Derivative Works a copy of this License; and - - (b) You must cause any modified files to carry prominent notices - stating that You changed the files; and - - (c) You must retain, in the Source form of any Derivative Works - that You distribute, all copyright, patent, trademark, and - attribution notices from the Source form of the Work, - excluding those notices that do not pertain to any part of - the Derivative Works; and - - (d) If the Work includes a "NOTICE" text file as part of its - distribution, then any Derivative Works that You distribute must - include a readable copy of the attribution notices contained - within such NOTICE file, excluding those notices that do not - pertain to any part of the Derivative Works, in at least one - of the following places: within a NOTICE text file distributed - as part of the Derivative Works; within the Source form or - documentation, if provided along with the Derivative Works; or, - within a display generated by the Derivative Works, if and - wherever such third-party notices normally appear. The contents - of the NOTICE file are for informational purposes only and - do not modify the License. You may add Your own attribution - notices within Derivative Works that You distribute, alongside - or as an addendum to the NOTICE text from the Work, provided - that such additional attribution notices cannot be construed - as modifying the License. - - You may add Your own copyright statement to Your modifications and - may provide additional or different license terms and conditions - for use, reproduction, or distribution of Your modifications, or - for any such Derivative Works as a whole, provided Your use, - reproduction, and distribution of the Work otherwise complies with - the conditions stated in this License. - - 5. Submission of Contributions. Unless You explicitly state otherwise, - any Contribution intentionally submitted for inclusion in the Work - by You to the Licensor shall be under the terms and conditions of - this License, without any additional terms or conditions. - Notwithstanding the above, nothing herein shall supersede or modify - the terms of any separate license agreement you may have executed - with Licensor regarding such Contributions. - - 6. Trademarks. This License does not grant permission to use the trade - names, trademarks, service marks, or product names of the Licensor, - except as required for reasonable and customary use in describing the - origin of the Work and reproducing the content of the NOTICE file. - - 7. Disclaimer of Warranty. Unless required by applicable law or - agreed to in writing, Licensor provides the Work (and each - Contributor provides its Contributions) on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or - implied, including, without limitation, any warranties or conditions - of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A - PARTICULAR PURPOSE. You are solely responsible for determining the - appropriateness of using or redistributing the Work and assume any - risks associated with Your exercise of permissions under this License. - - 8. Limitation of Liability. In no event and under no legal theory, - whether in tort (including negligence), contract, or otherwise, - unless required by applicable law (such as deliberate and grossly - negligent acts) or agreed to in writing, shall any Contributor be - liable to You for damages, including any direct, indirect, special, - incidental, or consequential damages of any character arising as a - result of this License or out of the use or inability to use the - Work (including but not limited to damages for loss of goodwill, - work stoppage, computer failure or malfunction, or any and all - other commercial damages or losses), even if such Contributor - has been advised of the possibility of such damages. - - 9. Accepting Warranty or Additional Liability. While redistributing - the Work or Derivative Works thereof, You may choose to offer, - and charge a fee for, acceptance of support, warranty, indemnity, - or other liability obligations and/or rights consistent with this - License. However, in accepting such obligations, You may act only - on Your own behalf and on Your sole responsibility, not on behalf - of any other Contributor, and only if You agree to indemnify, - defend, and hold each Contributor harmless for any liability - incurred by, or claims asserted against, such Contributor by reason - of your accepting any such warranty or additional liability. - - END OF TERMS AND CONDITIONS diff --git a/cardano-ping/NOTICE b/cardano-ping/NOTICE deleted file mode 100644 index b966fe9597a..00000000000 --- a/cardano-ping/NOTICE +++ /dev/null @@ -1,14 +0,0 @@ -Copyright 2019-2023 Input Output Global Inc (IOG), Intersect 2025 - - 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/cardano-ping/README.md b/cardano-ping/README.md deleted file mode 100644 index ce3683460f3..00000000000 --- a/cardano-ping/README.md +++ /dev/null @@ -1,3 +0,0 @@ -# cardano-ping - -Utility for pinging cardano nodes. diff --git a/cardano-ping/cardano-ping.cabal b/cardano-ping/cardano-ping.cabal deleted file mode 100644 index 250bd9698e5..00000000000 --- a/cardano-ping/cardano-ping.cabal +++ /dev/null @@ -1,56 +0,0 @@ -cabal-version: 3.0 -name: cardano-ping -version: 0.9.0.0 -synopsis: Utility for pinging cardano nodes -description: Utility for pinging cardano nodes. -license: Apache-2.0 -license-files: - LICENSE - NOTICE - -copyright: 2019-2024 Input Output Global Inc (IOG), 2023-2025 Intersect -author: Karl Knutsson -maintainer: karl.knutsson-ext@cardanofoundation.org marcin.szamotulski@iohk.io -category: Network -build-type: Simple -extra-doc-files: - CHANGELOG.md - README.md - -flag asserts - description: Enable assertions - manual: False - default: False - -library - hs-source-dirs: src - exposed-modules: Cardano.Network.Ping - build-depends: - aeson >=2.1.1.0 && <3, - base >=4.14 && <4.22, - bytestring >=0.10 && <0.13, - cborg >=0.2.8 && <0.3, - contra-tracer >=0.1 && <0.3, - io-classes:{si-timers, strict-stm} ^>=1.8.0.1, - iproute ^>=1.7.15, - network ^>=3.2.7, - network-mux ^>=0.9, - tdigest ^>=0.3, - text >=1.2.4 && <2.2, - time >=1.9.1 && <1.14, - transformers >=0.5 && <0.7, - - if flag(asserts) - ghc-options: -fno-ignore-asserts - default-language: Haskell2010 - default-extensions: ImportQualifiedPost - ghc-options: - -Wall - -Wcompat - -Widentities - -Wincomplete-record-updates - -Wincomplete-uni-patterns - -Wno-unticked-promoted-constructors - -Wpartial-fields - -Wredundant-constraints - -Wunused-packages diff --git a/cardano-ping/changelog.d/scriv.ini b/cardano-ping/changelog.d/scriv.ini deleted file mode 100644 index 3406d5e47e4..00000000000 --- a/cardano-ping/changelog.d/scriv.ini +++ /dev/null @@ -1,15 +0,0 @@ -[scriv] -format = md -insert_marker = Changelog entries -md_header_level = 2 -version = literal: cardano-ping.cabal: version -categories = Breaking, Non-Breaking -start_marker = scriv-insert-here -end_marker = scriv-end-here -fragment_directory = changelog.d -ghrel_template = {{body}} -main_branches = main -new_fragment_template = file: new_fragment.${config:format}.j2 -output_file = CHANGELOG.${config:format} -skip_fragments = README.* -entry_title_template = {%% if version %%}{{ version }} -- {%% endif %%}{{ date.strftime('%%Y-%%m-%%d') }} From 86d7302bedec1248e832aeb62b0ee558723e2395 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Tue, 30 Sep 2025 10:01:38 +0200 Subject: [PATCH 02/11] cardano-diffusion:ping - using ouroboros-network and cardano-diffusion --- .../Cardano/Network/NodeToClient/Version.hs | 1 + .../lib/Cardano/Network/NodeToNode/Version.hs | 1 + .../Cardano/Network/NodeToClient/Version.hs | 1 - .../Cardano/Network/NodeToNode/Version.hs | 1 - cardano-diffusion/cardano-diffusion.cabal | 8 +- .../ping/Cardano/Network/Ping.hs | 1211 +++++++---------- .../Network/Protocol/Handshake/Test.hs | 1 - .../Ouroboros/Network/Handshake/Acceptable.hs | 8 +- .../Ouroboros/Network/Handshake/Queryable.hs | 4 +- .../Network/PeerSelection/PeerSharing.hs | 2 +- .../Ouroboros/Network/Protocol/Handshake.hs | 112 +- .../Network/Protocol/Handshake/Client.hs | 177 ++- 12 files changed, 728 insertions(+), 799 deletions(-) diff --git a/cardano-diffusion/api/lib/Cardano/Network/NodeToClient/Version.hs b/cardano-diffusion/api/lib/Cardano/Network/NodeToClient/Version.hs index fd6fd1d1ae0..bbbb88d5801 100644 --- a/cardano-diffusion/api/lib/Cardano/Network/NodeToClient/Version.hs +++ b/cardano-diffusion/api/lib/Cardano/Network/NodeToClient/Version.hs @@ -8,6 +8,7 @@ module Cardano.Network.NodeToClient.Version , NodeToClientVersionData (..) , nodeToClientCodecCBORTerm , nodeToClientVersionCodec + , NetworkMagic (..) ) where import Codec.CBOR.Term qualified as CBOR diff --git a/cardano-diffusion/api/lib/Cardano/Network/NodeToNode/Version.hs b/cardano-diffusion/api/lib/Cardano/Network/NodeToNode/Version.hs index 7aa2ba51f0b..1bc515e0688 100644 --- a/cardano-diffusion/api/lib/Cardano/Network/NodeToNode/Version.hs +++ b/cardano-diffusion/api/lib/Cardano/Network/NodeToNode/Version.hs @@ -10,6 +10,7 @@ module Cardano.Network.NodeToNode.Version , ConnectionMode (..) , nodeToNodeVersionCodec , nodeToNodeCodecCBORTerm + , NetworkMagic (..) ) where import Data.Text (Text) diff --git a/cardano-diffusion/api/tests/Test/Cardano/Network/NodeToClient/Version.hs b/cardano-diffusion/api/tests/Test/Cardano/Network/NodeToClient/Version.hs index 0b9dc61259a..2354ff57ae0 100644 --- a/cardano-diffusion/api/tests/Test/Cardano/Network/NodeToClient/Version.hs +++ b/cardano-diffusion/api/tests/Test/Cardano/Network/NodeToClient/Version.hs @@ -6,7 +6,6 @@ module Test.Cardano.Network.NodeToClient.Version (tests) where import Cardano.Network.NodeToClient.Version import Ouroboros.Network.CodecCBORTerm -import Ouroboros.Network.Magic import Test.QuickCheck import Test.Tasty (TestTree, testGroup) diff --git a/cardano-diffusion/api/tests/Test/Cardano/Network/NodeToNode/Version.hs b/cardano-diffusion/api/tests/Test/Cardano/Network/NodeToNode/Version.hs index a5475fb44c5..e63dc699e39 100644 --- a/cardano-diffusion/api/tests/Test/Cardano/Network/NodeToNode/Version.hs +++ b/cardano-diffusion/api/tests/Test/Cardano/Network/NodeToNode/Version.hs @@ -6,7 +6,6 @@ module Test.Cardano.Network.NodeToNode.Version (tests) where import Cardano.Network.NodeToNode.Version import Ouroboros.Network.CodecCBORTerm -import Ouroboros.Network.Magic import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing (..)) import Test.QuickCheck diff --git a/cardano-diffusion/cardano-diffusion.cabal b/cardano-diffusion/cardano-diffusion.cabal index 5e5490a7689..1d27ba94e5e 100644 --- a/cardano-diffusion/cardano-diffusion.cabal +++ b/cardano-diffusion/cardano-diffusion.cabal @@ -523,13 +523,17 @@ library ping aeson >=2.1.1.0 && <3, base >=4.14 && <4.22, bytestring >=0.10 && <0.13, + cardano-diffusion:{api, cardano-diffusion, orphan-instances, protocols}, cborg >=0.2.8 && <0.3, + containers, contra-tracer >=0.1 && <0.3, - io-classes:{si-timers, strict-stm} ^>=1.8.0.1, + io-classes:{io-classes, si-timers, strict-stm} ^>=1.8.0.1, iproute ^>=1.7.15, network ^>=3.2.7, network-mux ^>=0.9, + ouroboros-network:{api, framework} ^>=0.23, + random, + serialise, tdigest ^>=0.3, text >=1.2.4 && <2.2, time >=1.9.1 && <1.14, - transformers >=0.5 && <0.7, diff --git a/cardano-diffusion/ping/Cardano/Network/Ping.hs b/cardano-diffusion/ping/Cardano/Network/Ping.hs index ae723af712b..a52763a2b3d 100644 --- a/cardano-diffusion/ping/Cardano/Network/Ping.hs +++ b/cardano-diffusion/ping/Cardano/Network/Ping.hs @@ -1,71 +1,86 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +{-# OPTIONS_GHC -Wno-orphans #-} module Cardano.Network.Ping ( PingOpts(..) + , LogFormat(..) , LogMsg(..) - , NodeVersion(..) - , HandshakeFailure(..) , StatPoint(..) - , InitiatorOnly(..) + , ProtocolFlavour(..) + , pingClients , mainnetMagic - , pingClient - , logger - , supportedNodeToNodeVersions - , supportedNodeToClientVersions - , handshakeDec - , handshakeReq - , isSameVersionAndMagic ) where -import Control.Exception (bracket, Exception (..), throwIO) -import Control.Monad (replicateM, unless, when) -import Control.Concurrent.Class.MonadSTM.Strict ( MonadSTM(atomically), takeTMVar, StrictTMVar ) -import Control.Monad.Class.MonadTime.SI (UTCTime, diffTime, MonadMonotonicTime(getMonotonicTime), MonadTime(getCurrentTime), Time) -import Control.Monad.Trans.Except +import Control.Monad (unless, when) +import Control.Concurrent.Class.MonadSTM.Strict +import Control.Monad.Class.MonadAsync +import Control.Monad.Class.MonadThrow +import Control.Monad.Class.MonadTime.SI import Control.Tracer (Tracer (..), nullTracer, traceWith) -import Data.Aeson (Value, ToJSON(toJSON, toJSONList), object, encode, KeyValue((.=))) +import Data.Aeson (Value, ToJSON(toJSON), object, encode, KeyValue((.=))) import Data.Aeson.Text (encodeToLazyText) -import Data.Bits (clearBit, setBit, testBit) -import Data.ByteString.Lazy (ByteString) -import Data.Foldable (toList) +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Lazy.Char8 as LBS.Char import Data.IP -import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.Map.Strict as Map import Data.Maybe (fromMaybe,) import Data.TDigest (insert, maximumValue, minimumValue, tdigest, mean, quantile, stddev, TDigest) -import Data.Text (unpack) -import Data.Time (DiffTime) import Data.Time.Format.ISO8601 (iso8601Show) -import Data.Word (Word16, Word32, Word64) -import GHC.Generics +import Data.Word (Word16, Word32) +import Network.Mux (MiniProtocolInfo (..)) import qualified Network.Mux as Mx import Network.Mux.Bearer (MakeBearer (..), makeSocketBearer) -import Network.Mux.Timeout (TimeoutFn, withTimeoutSerial) -import Network.Mux.Types (MiniProtocolNum(..), MiniProtocolDir(InitiatorDir), Bearer(read, write), RemoteClockModel(RemoteClockModel)) -import qualified Network.Mux.Types as Mx import Network.Socket (AddrInfo, StructLinger (..)) +import System.Random (initStdGen) import Text.Printf (printf) -import qualified Codec.CBOR.Decoding as CBOR -import qualified Codec.CBOR.Encoding as CBOR -import qualified Codec.CBOR.Read as CBOR -import qualified Codec.CBOR.Write as CBOR +import Cardano.Network.Diffusion.Configuration (defaultChainSyncIdleTimeout) +import Cardano.Network.NodeToNode.Version +import Cardano.Network.NodeToNode qualified as NodeToNode +import Cardano.Network.NodeToClient.Version +import Cardano.Network.OrphanInstances () +import Cardano.Network.Protocol.ChainSync.Client (ChainSyncClient) +import Cardano.Network.Protocol.ChainSync.Client qualified as ChainSync +import Cardano.Network.Protocol.ChainSync.Codec qualified as ChainSync +import Cardano.Network.Protocol.Handshake.Codec (nodeToClientHandshakeCodec, nodeToNodeHandshakeCodec) +import Cardano.Network.Protocol.KeepAlive.Type qualified as KeepAlive +import Cardano.Network.Protocol.KeepAlive.Client (KeepAliveClient (..)) +import Cardano.Network.Protocol.KeepAlive.Client qualified as KeepAlive +import Cardano.Network.Protocol.KeepAlive.Codec qualified as KeepAlive + +import Ouroboros.Network.Block hiding (blockNo) +import Ouroboros.Network.ConnectionId +import Ouroboros.Network.Driver.Limits +import Ouroboros.Network.Protocol.Handshake hiding (Accept (..), RefuseReason (..)) +import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing (..)) +import Ouroboros.Network.Util.ShowProxy + +import qualified Codec.CBOR.Term as CBOR +import qualified Codec.Serialise as Serialise import qualified Control.Monad.Class.MonadTimer.SI as MT -import qualified Data.ByteString.Lazy as LBS -import qualified Data.ByteString.Lazy.Char8 as LBS.Char -import qualified Data.List as L import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.IO as TL import qualified Network.Socket as Socket import qualified System.IO as IO -import Codec.CBOR.Read (DeserialiseFailure) + +data LogFormat = AsJSON | AsText + deriving (Eq, Show) data PingOpts = PingOpts { pingOptsCount :: Word32 @@ -80,7 +95,7 @@ data PingOpts = PingOpts -- ^ The port to connect to , pingOptsMagic :: Word32 -- ^ The network magic to use for the connection - , pingOptsJson :: Bool + , pingOptsJson :: LogFormat -- ^ Print output in JSON , pingOptsQuiet :: Bool -- ^ Less verbose output @@ -91,500 +106,100 @@ data PingOpts = PingOpts mainnetMagic :: Word32 mainnetMagic = 764824073 -handshakeNum :: MiniProtocolNum -handshakeNum = MiniProtocolNum 0 - -chainSyncNum :: MiniProtocolNum -chainSyncNum = MiniProtocolNum 2 - -keepaliveNum :: MiniProtocolNum -keepaliveNum = MiniProtocolNum 8 - -nodeToClientVersionBit :: Int -nodeToClientVersionBit = 15 - -data LogMsg = LogMsg ByteString +data LogMsg = LogMsg BL.ByteString | LogEnd deriving Show -logger :: StrictTMVar IO LogMsg -> Bool -> Bool -> Bool -> IO () -logger msgQueue json query tip = go True + +-- | Logging is done concurrently from multiple ping clients. +-- +loggerThread :: PingOpts -> StrictTMVar IO LogMsg -> IO () +loggerThread + PingOpts { pingOptsJson, + pingOptsGetTip, + pingOptsHandshakeQuery + } + msgQueue + = + go True where go first = do - msg <- atomically $ takeTMVar msgQueue + msg <- atomically $ takeTMVar msgQueue case msg of LogMsg bs -> do - let bs' = case (json, first, tip) of - (True, False, _) -> LBS.Char.pack ",\n" <> bs - (True, True, False) -> LBS.Char.pack "{ \"pongs\": [ " <> bs - (True, True, True) -> LBS.Char.pack "{ \"tip\": [ " <> bs - (False, True, False) -> LBS.Char.pack "timestamp, host, cookie, sample, median, p90, mean, min, max, std\n" <> bs - (False, True, True) -> bs - (False, False, _) -> bs + let bs' = case (pingOptsJson, first, pingOptsGetTip) of + (AsJSON, False, _) -> + LBS.Char.pack ",\n" <> bs + (AsJSON, True, False) -> + LBS.Char.pack "{ \"pongs\": [ " <> bs + (AsJSON, True, True) -> + LBS.Char.pack "{ \"tip\": [ " <> bs + (AsText, True, False) -> + LBS.Char.pack "timestamp, host, cookie, sample, median, p90, mean, min, max, std\n" <> bs + (AsText, True, True) -> bs + (AsText, False, _) -> bs LBS.Char.putStr bs' go False - LogEnd -> when (json && not query) $ IO.putStrLn "] }" - -supportedNodeToNodeVersions :: Word32 -> [NodeVersion] -supportedNodeToNodeVersions magic = - [ NodeToNodeVersionV7 magic InitiatorOnly - , NodeToNodeVersionV8 magic InitiatorOnly - , NodeToNodeVersionV9 magic InitiatorOnly - , NodeToNodeVersionV10 magic InitiatorOnly - , NodeToNodeVersionV11 magic InitiatorOnly - , NodeToNodeVersionV12 magic InitiatorOnly - , NodeToNodeVersionV13 magic InitiatorOnly PeerSharingDisabled - , NodeToNodeVersionV14 magic InitiatorOnly PeerSharingDisabled - ] - -supportedNodeToClientVersions :: Word32 -> [NodeVersion] -supportedNodeToClientVersions magic = - [ NodeToClientVersionV9 magic - , NodeToClientVersionV10 magic - , NodeToClientVersionV11 magic - , NodeToClientVersionV12 magic - , NodeToClientVersionV13 magic - , NodeToClientVersionV14 magic - , NodeToClientVersionV15 magic - , NodeToClientVersionV16 magic - , NodeToClientVersionV17 magic - , NodeToClientVersionV18 magic - , NodeToClientVersionV19 magic - , NodeToClientVersionV20 magic - , NodeToClientVersionV21 magic - , NodeToClientVersionV22 magic - ] - -data InitiatorOnly = InitiatorOnly | InitiatorAndResponder - deriving (Eq, Ord, Show, Bounded, Generic) - -instance ToJSON InitiatorOnly - -modeToBool :: InitiatorOnly -> Bool -modeToBool InitiatorOnly = True -modeToBool InitiatorAndResponder = False - -modeFromBool :: Bool -> InitiatorOnly -modeFromBool True = InitiatorOnly -modeFromBool False = InitiatorAndResponder - -data PeerSharing = PeerSharingEnabled | PeerSharingDisabled - deriving (Eq, Ord, Show, Bounded, Generic) - -instance ToJSON PeerSharing - -peerSharingFromWord32 :: Word32 -> PeerSharing -peerSharingFromWord32 1 = PeerSharingEnabled -peerSharingFromWord32 _ = PeerSharingDisabled - -data NodeVersion - = NodeToClientVersionV9 Word32 - | NodeToClientVersionV10 Word32 - | NodeToClientVersionV11 Word32 - | NodeToClientVersionV12 Word32 - | NodeToClientVersionV13 Word32 - | NodeToClientVersionV14 Word32 - | NodeToClientVersionV15 Word32 - | NodeToClientVersionV16 Word32 - | NodeToClientVersionV17 Word32 - | NodeToClientVersionV18 Word32 - | NodeToClientVersionV19 Word32 - | NodeToClientVersionV20 Word32 - | NodeToClientVersionV21 Word32 - | NodeToClientVersionV22 Word32 - | NodeToNodeVersionV1 Word32 - | NodeToNodeVersionV2 Word32 - | NodeToNodeVersionV3 Word32 - | NodeToNodeVersionV4 Word32 InitiatorOnly - | NodeToNodeVersionV5 Word32 InitiatorOnly - | NodeToNodeVersionV6 Word32 InitiatorOnly - | NodeToNodeVersionV7 Word32 InitiatorOnly - | NodeToNodeVersionV8 Word32 InitiatorOnly - | NodeToNodeVersionV9 Word32 InitiatorOnly - | NodeToNodeVersionV10 Word32 InitiatorOnly - | NodeToNodeVersionV11 Word32 InitiatorOnly - | NodeToNodeVersionV12 Word32 InitiatorOnly - | NodeToNodeVersionV13 Word32 InitiatorOnly PeerSharing - | NodeToNodeVersionV14 Word32 InitiatorOnly PeerSharing - deriving (Eq, Ord, Show) - -instance ToJSON NodeVersion where - toJSON nv = - object $ case nv of - NodeToClientVersionV9 m -> go2 "NodeToClientVersionV9" m - NodeToClientVersionV10 m -> go2 "NodeToClientVersionV10" m - NodeToClientVersionV11 m -> go2 "NodeToClientVersionV11" m - NodeToClientVersionV12 m -> go2 "NodeToClientVersionV12" m - NodeToClientVersionV13 m -> go2 "NodeToClientVersionV13" m - NodeToClientVersionV14 m -> go2 "NodeToClientVersionV14" m - NodeToClientVersionV15 m -> go2 "NodeToClientVersionV15" m - NodeToClientVersionV16 m -> go2 "NodeToClientVersionV16" m - NodeToClientVersionV17 m -> go2 "NodeToClientVersionV17" m - NodeToClientVersionV18 m -> go2 "NodeToClientVersionV18" m - NodeToClientVersionV19 m -> go2 "NodeToClientVersionV19" m - NodeToClientVersionV20 m -> go2 "NodeToClientVersionV20" m - NodeToClientVersionV21 m -> go2 "NodeToClientVersionV21" m - NodeToClientVersionV22 m -> go2 "NodeToClientVersionV22" m - NodeToNodeVersionV1 m -> go2 "NodeToNodeVersionV1" m - NodeToNodeVersionV2 m -> go2 "NodeToNodeVersionV2" m - NodeToNodeVersionV3 m -> go2 "NodeToNodeVersionV3" m - NodeToNodeVersionV4 m i -> go3 "NodeToNodeVersionV4" m i - NodeToNodeVersionV5 m i -> go3 "NodeToNodeVersionV5" m i - NodeToNodeVersionV6 m i -> go3 "NodeToNodeVersionV6" m i - NodeToNodeVersionV7 m i -> go3 "NodeToNodeVersionV7" m i - NodeToNodeVersionV8 m i -> go3 "NodeToNodeVersionV8" m i - NodeToNodeVersionV9 m i -> go3 "NodeToNodeVersionV9" m i - NodeToNodeVersionV10 m i -> go3 "NodeToNodeVersionV10" m i - NodeToNodeVersionV11 m i -> go3 "NodeToNodeVersionV11" m i - NodeToNodeVersionV12 m i -> go3 "NodeToNodeVersionV12" m i - NodeToNodeVersionV13 m i ps -> go4 "NodeToNodeVersionV13" m i ps - NodeToNodeVersionV14 m i ps -> go4 "NodeToNodeVersionV14" m i ps - where - go2 (version :: String) magic = ["version" .= version, "magic" .= magic] - go3 version magic initiator = go2 version magic <> ["initiator" .= toJSON initiator] - go4 version magic initiator peersharing = go3 version magic initiator <> - ["peersharing" .= toJSON peersharing] + LogEnd -> when (pingOptsJson == AsJSON && not pingOptsHandshakeQuery) $ IO.putStrLn "] }" + +sduTimeout :: MT.DiffTime +sduTimeout = 30 data PingTip = PingTip { - ptHost :: !(IP, Socket.PortNumber) + ptHost :: !(Either FilePath (IP, Socket.PortNumber)) , ptRtt :: !Double , ptHash :: !ByteString - , ptBlockNo :: !Word64 - , ptSlotNo :: !Word64 + , ptBlockNo :: !BlockNo + , ptSlotNo :: !SlotNo } hexStr :: ByteString -> String -hexStr = LBS.foldr (\b -> (<>) (printf "%02x" b)) "" +hexStr = BS.foldr (\b -> (<>) (printf "%02x" b)) "" instance Show PingTip where show PingTip{..} = - printf "host: %s:%d, rtt: %f, hash %s, blockNo: %d slotNo: %d" (show $ fst ptHost) - (fromIntegral $ snd ptHost :: Word16) ptRtt (hexStr ptHash) ptBlockNo ptSlotNo + case ptHost of + Right (ip, port) -> + printf "host: %s:%d, rtt: %f, hash %s, blockNo: %d slotNo: %d" + (show ip) + (fromIntegral port :: Word16) + ptRtt + (hexStr ptHash) + (unBlockNo ptBlockNo) + (unSlotNo ptSlotNo) + Left path -> + printf "host: %s, rtt: %f, hash %s, blockNo: %d slotNo: %d" + path + ptRtt + (hexStr ptHash) + (unBlockNo ptBlockNo) + (unSlotNo ptSlotNo) instance ToJSON PingTip where toJSON PingTip{..} = - object [ - "rtt" .= ptRtt - , "hash" .= hexStr ptHash - , "blockNo" .= ptBlockNo - , "slotNo" .= ptSlotNo - , "addr" .= (show $ fst $ ptHost :: String) - , "port" .= (fromIntegral $ snd $ ptHost :: Word16) - ] - -keepAliveReqEnc :: NodeVersion -> Word16 -> CBOR.Encoding -keepAliveReqEnc v cookie | v >= NodeToNodeVersionV7 minBound minBound = - CBOR.encodeListLen 2 - <> CBOR.encodeWord 0 - <> CBOR.encodeWord16 cookie -keepAliveReqEnc _ cookie = - CBOR.encodeWord 0 - <> CBOR.encodeWord16 cookie - -keepAliveReq :: NodeVersion -> Word16 -> ByteString -keepAliveReq v c = CBOR.toLazyByteString $ keepAliveReqEnc v c - -keepAliveDone :: NodeVersion -> ByteString -keepAliveDone v | v >= NodeToNodeVersionV7 minBound minBound = - CBOR.toLazyByteString $ - CBOR.encodeListLen 1 - <> CBOR.encodeWord 2 -keepAliveDone _ = - CBOR.toLazyByteString $ - CBOR.encodeWord 2 - -chainSyncFindIntersect :: ByteString -chainSyncFindIntersect = CBOR.toLazyByteString findIntersectEnc - where - findIntersectEnc :: CBOR.Encoding - findIntersectEnc = - CBOR.encodeListLen 2 - <> CBOR.encodeWord 4 - <> CBOR.encodeListLenIndef - <> CBOR.encodeBreak - -handshakeReqEnc :: NonEmpty NodeVersion -> Bool -> CBOR.Encoding -handshakeReqEnc versions query = - CBOR.encodeListLen 2 - <> CBOR.encodeWord 0 - <> CBOR.encodeMapLen (fromIntegral $ L.length versions) - <> mconcat [ encodeVersion (fixupVersion v) - | v <- toList versions - ] - where - -- Query is only available for NodeToNodeVersionV11 and higher, for smaller - -- versions we send `InitiatorAndResponder`, in which case the remote side - -- will do the handshake negotiation but it will reply with the right data. - -- We shutdown the connection right after query, in most cases the remote - -- side will not even have a chance to start using this connection as - -- duplex (which could be possible if the node is using - -- `NodeToNodeVersionV10`). - fixupVersion :: NodeVersion -> NodeVersion - fixupVersion v | not query = v - fixupVersion (NodeToNodeVersionV4 a _) = NodeToNodeVersionV4 a InitiatorAndResponder - fixupVersion (NodeToNodeVersionV5 a _) = NodeToNodeVersionV5 a InitiatorAndResponder - fixupVersion (NodeToNodeVersionV6 a _) = NodeToNodeVersionV6 a InitiatorAndResponder - fixupVersion (NodeToNodeVersionV7 a _) = NodeToNodeVersionV7 a InitiatorAndResponder - fixupVersion (NodeToNodeVersionV8 a _) = NodeToNodeVersionV8 a InitiatorAndResponder - fixupVersion (NodeToNodeVersionV9 a _) = NodeToNodeVersionV9 a InitiatorAndResponder - fixupVersion (NodeToNodeVersionV10 a _) = NodeToNodeVersionV10 a InitiatorAndResponder - fixupVersion v = v - - - encodeVersion :: NodeVersion -> CBOR.Encoding - - -- node-to-client - encodeVersion (NodeToClientVersionV9 magic) = - CBOR.encodeWord (9 `setBit` nodeToClientVersionBit) - <> CBOR.encodeInt (fromIntegral magic) - encodeVersion (NodeToClientVersionV10 magic) = - CBOR.encodeWord (10 `setBit` nodeToClientVersionBit) - <> CBOR.encodeInt (fromIntegral magic) - encodeVersion (NodeToClientVersionV11 magic) = - CBOR.encodeWord (11 `setBit` nodeToClientVersionBit) - <> CBOR.encodeInt (fromIntegral magic) - encodeVersion (NodeToClientVersionV12 magic) = - CBOR.encodeWord (12 `setBit` nodeToClientVersionBit) - <> CBOR.encodeInt (fromIntegral magic) - encodeVersion (NodeToClientVersionV13 magic) = - CBOR.encodeWord (13 `setBit` nodeToClientVersionBit) - <> CBOR.encodeInt (fromIntegral magic) - encodeVersion (NodeToClientVersionV14 magic) = - CBOR.encodeWord (14 `setBit` nodeToClientVersionBit) - <> CBOR.encodeInt (fromIntegral magic) - encodeVersion (NodeToClientVersionV15 magic) = - CBOR.encodeWord (15 `setBit` nodeToClientVersionBit) - <> nodeToClientDataWithQuery magic - encodeVersion (NodeToClientVersionV16 magic) = - CBOR.encodeWord (16 `setBit` nodeToClientVersionBit) - <> nodeToClientDataWithQuery magic - encodeVersion (NodeToClientVersionV17 magic) = - CBOR.encodeWord (17 `setBit` nodeToClientVersionBit) - <> nodeToClientDataWithQuery magic - encodeVersion (NodeToClientVersionV18 magic) = - CBOR.encodeWord (18 `setBit` nodeToClientVersionBit) - <> nodeToClientDataWithQuery magic - encodeVersion (NodeToClientVersionV19 magic) = - CBOR.encodeWord (19 `setBit` nodeToClientVersionBit) - <> nodeToClientDataWithQuery magic - encodeVersion (NodeToClientVersionV20 magic) = - CBOR.encodeWord (20 `setBit` nodeToClientVersionBit) - <> nodeToClientDataWithQuery magic - encodeVersion (NodeToClientVersionV21 magic) = - CBOR.encodeWord (21 `setBit` nodeToClientVersionBit) - <> nodeToClientDataWithQuery magic - encodeVersion (NodeToClientVersionV22 magic) = - CBOR.encodeWord (22 `setBit` nodeToClientVersionBit) - <> nodeToClientDataWithQuery magic - - -- node-to-node - encodeVersion (NodeToNodeVersionV1 magic) = - CBOR.encodeWord 1 - <> CBOR.encodeInt (fromIntegral magic) - encodeVersion (NodeToNodeVersionV2 magic) = - CBOR.encodeWord 2 - <> CBOR.encodeInt (fromIntegral magic) - encodeVersion (NodeToNodeVersionV3 magic) = - CBOR.encodeWord 3 - <> CBOR.encodeInt (fromIntegral magic) - encodeVersion (NodeToNodeVersionV4 magic mode) = encodeWithMode 4 magic mode - encodeVersion (NodeToNodeVersionV5 magic mode) = encodeWithMode 5 magic mode - encodeVersion (NodeToNodeVersionV6 magic mode) = encodeWithMode 6 magic mode - encodeVersion (NodeToNodeVersionV7 magic mode) = encodeWithMode 7 magic mode - encodeVersion (NodeToNodeVersionV8 magic mode) = encodeWithMode 8 magic mode - encodeVersion (NodeToNodeVersionV9 magic mode) = encodeWithMode 9 magic mode - encodeVersion (NodeToNodeVersionV10 magic mode) = encodeWithMode 10 magic mode - encodeVersion (NodeToNodeVersionV11 magic mode) = encodeWithMode 11 magic mode - encodeVersion (NodeToNodeVersionV12 magic mode) = encodeWithMode 12 magic mode - encodeVersion (NodeToNodeVersionV13 magic mode _) = encodeWithMode 13 magic mode - encodeVersion (NodeToNodeVersionV14 magic mode _) = encodeWithMode 14 magic mode - - nodeToClientDataWithQuery :: Word32 -> CBOR.Encoding - nodeToClientDataWithQuery magic - = CBOR.encodeListLen 2 - <> CBOR.encodeInt (fromIntegral magic) - <> CBOR.encodeBool query - - encodeWithMode :: Word -> Word32 -> InitiatorOnly -> CBOR.Encoding - encodeWithMode vn magic mode - | vn >= 12 = - CBOR.encodeWord vn - <> CBOR.encodeListLen 4 - <> CBOR.encodeInt (fromIntegral magic) - <> CBOR.encodeBool (modeToBool mode) - <> CBOR.encodeInt 0 -- NoPeerSharing - <> CBOR.encodeBool query - | vn >= 11 = - CBOR.encodeWord vn - <> CBOR.encodeListLen 4 - <> CBOR.encodeInt (fromIntegral magic) - <> CBOR.encodeBool (modeToBool mode) - <> CBOR.encodeInt 0 -- NoPeerSharing - <> CBOR.encodeBool query - | otherwise = - CBOR.encodeWord vn - <> CBOR.encodeListLen 2 - <> CBOR.encodeInt (fromIntegral magic) - <> CBOR.encodeBool (modeToBool mode) - -handshakeReq :: [NodeVersion] -> Bool -> ByteString -handshakeReq [] _ = LBS.empty -handshakeReq (v:vs) query = CBOR.toLazyByteString $ handshakeReqEnc (v:|vs) query - -data HandshakeFailure - = UnknownVersionInRsp Word - | UnknownKey Word - | UnknownTag Word - | VersionMissmath [Word] - | DecodeError Word String - | Refused Word String - deriving Show - -newtype KeepAliveFailure = KeepAliveFailureKey Word deriving Show - -keepAliveRspDec :: NodeVersion - -> CBOR.Decoder s (Either KeepAliveFailure Word16) -keepAliveRspDec v | v >= NodeToNodeVersionV7 minBound minBound = do - len <- CBOR.decodeListLen - key <- CBOR.decodeWord - case (len, key) of - (2, 1) -> Right <$> CBOR.decodeWord16 - (_, k) -> return $ Left $ KeepAliveFailureKey k -keepAliveRspDec _ = do - key <- CBOR.decodeWord - case key of - 1 -> Right <$> CBOR.decodeWord16 - k -> return $ Left $ KeepAliveFailureKey k - -handshakeDec :: CBOR.Decoder s (Either HandshakeFailure [NodeVersion]) -handshakeDec = do - _ <- CBOR.decodeListLen - key <- CBOR.decodeWord - case key of - 0 -> do - decodeVersions - 1 -> do - fmap pure <$> decodeVersion - 2 -> do - _ <- CBOR.decodeListLen - tag <- CBOR.decodeWord - case tag of - 0 -> do -- VersionMismatch - len <- CBOR.decodeListLen - x <- replicateM len CBOR.decodeWord - return $ Left $ VersionMissmath x - 1 -> do -- HandshakeDecodeError - vn <- CBOR.decodeWord - msg <- unpack <$> CBOR.decodeString - return $ Left $ DecodeError vn msg - 2 -> do -- Refused - vn <- CBOR.decodeWord - msg <- unpack <$> CBOR.decodeString - return $ Left $ Refused vn msg - _ -> return $ Left $ UnknownTag tag - 3 -> do -- MsgQueryReply - decodeVersions - - k -> return $ Left $ UnknownKey k - where - decodeVersions :: CBOR.Decoder s (Either HandshakeFailure [NodeVersion]) - decodeVersions = do - len <- CBOR.decodeMapLen - runExceptT $ go len [] - where - go :: Int -> [NodeVersion] -> ExceptT HandshakeFailure (CBOR.Decoder s) [NodeVersion] - go 0 acc = return acc - go i acc = do - version <- ExceptT decodeVersion - go (pred i) $ version:acc - - decodeVersion :: CBOR.Decoder s (Either HandshakeFailure NodeVersion) - decodeVersion = do - version <- CBOR.decodeWord - let cb = version `clearBit` nodeToClientVersionBit - let tb = version `testBit` nodeToClientVersionBit - case (cb, tb) of - (7, False) -> decodeWithMode NodeToNodeVersionV7 - (8, False) -> decodeWithMode NodeToNodeVersionV8 - (9, False) -> decodeWithMode NodeToNodeVersionV9 - (10, False) -> decodeWithMode NodeToNodeVersionV10 - (11, False) -> decodeWithModeAndQuery NodeToNodeVersionV11 - (12, False) -> decodeWithModeAndQuery NodeToNodeVersionV12 - (13, False) -> decodeWithModeQueryAndPeerSharing NodeToNodeVersionV13 - (14, False) -> decodeWithModeQueryAndPeerSharing NodeToNodeVersionV14 - - (9, True) -> Right . NodeToClientVersionV9 <$> CBOR.decodeWord32 - (10, True) -> Right . NodeToClientVersionV10 <$> CBOR.decodeWord32 - (11, True) -> Right . NodeToClientVersionV11 <$> CBOR.decodeWord32 - (12, True) -> Right . NodeToClientVersionV12 <$> CBOR.decodeWord32 - (13, True) -> Right . NodeToClientVersionV13 <$> CBOR.decodeWord32 - (14, True) -> Right . NodeToClientVersionV14 <$> CBOR.decodeWord32 - (15, True) -> Right . NodeToClientVersionV15 <$> (CBOR.decodeListLen *> CBOR.decodeWord32 <* (modeFromBool <$> CBOR.decodeBool)) - (16, True) -> Right . NodeToClientVersionV16 <$> (CBOR.decodeListLen *> CBOR.decodeWord32 <* (modeFromBool <$> CBOR.decodeBool)) - (17, True) -> Right . NodeToClientVersionV17 <$> (CBOR.decodeListLen *> CBOR.decodeWord32 <* (modeFromBool <$> CBOR.decodeBool)) - (18, True) -> Right . NodeToClientVersionV18 <$> (CBOR.decodeListLen *> CBOR.decodeWord32 <* (modeFromBool <$> CBOR.decodeBool)) - (19, True) -> Right . NodeToClientVersionV19 <$> (CBOR.decodeListLen *> CBOR.decodeWord32 <* (modeFromBool <$> CBOR.decodeBool)) - (20, True) -> Right . NodeToClientVersionV20 <$> (CBOR.decodeListLen *> CBOR.decodeWord32 <* (modeFromBool <$> CBOR.decodeBool)) - (21, True) -> Right . NodeToClientVersionV21 <$> (CBOR.decodeListLen *> CBOR.decodeWord32 <* (modeFromBool <$> CBOR.decodeBool)) - (22, True) -> Right . NodeToClientVersionV22 <$> (CBOR.decodeListLen *> CBOR.decodeWord32 <* (modeFromBool <$> CBOR.decodeBool)) - _ -> return $ Left $ UnknownVersionInRsp version - - decodeWithMode :: (Word32 -> InitiatorOnly -> NodeVersion) -> CBOR.Decoder s (Either HandshakeFailure NodeVersion) - decodeWithMode vnFun = do - _ <- CBOR.decodeListLen - magic <- CBOR.decodeWord32 - Right . vnFun magic . modeFromBool <$> CBOR.decodeBool - - decodeWithModeAndQuery :: (Word32 -> InitiatorOnly -> NodeVersion) - -> CBOR.Decoder s (Either HandshakeFailure NodeVersion) - decodeWithModeAndQuery vnFun = do - _len <- CBOR.decodeListLen - magic <- CBOR.decodeWord32 - mode <- modeFromBool <$> CBOR.decodeBool - _peerSharing <- CBOR.decodeWord32 - _query <- CBOR.decodeBool - return $ Right $ vnFun magic mode - - decodeWithModeQueryAndPeerSharing :: (Word32 -> InitiatorOnly -> PeerSharing -> NodeVersion) - -> CBOR.Decoder s (Either HandshakeFailure NodeVersion) - decodeWithModeQueryAndPeerSharing vnFun = do - _len <- CBOR.decodeListLen - magic <- CBOR.decodeWord32 - mode <- modeFromBool <$> CBOR.decodeBool - peerSharing <- peerSharingFromWord32 <$> CBOR.decodeWord32 - _query <- CBOR.decodeBool - return $ Right $ vnFun magic mode peerSharing - -chainSyncIntersectNotFoundDec :: CBOR.Decoder s (Word64, Word64, ByteString) -chainSyncIntersectNotFoundDec = do - len <- CBOR.decodeListLen - key <- CBOR.decodeWord - case (len, key) of - (2, 6) -> do - _ <- CBOR.decodeListLen - _ <- CBOR.decodeListLen - slotNo <- CBOR.decodeWord64 - hash <- CBOR.decodeBytes - blockNo <- CBOR.decodeWord64 - return (slotNo, blockNo, LBS.fromStrict hash) - _ -> fail ("IntersectNotFound unexpected " ++ show key) - -wrap :: MiniProtocolNum -> MiniProtocolDir -> LBS.ByteString -> Mx.SDU -wrap ptclNum ptclDir blob = Mx.SDU - { Mx.msHeader = Mx.SDUHeader - { Mx.mhTimestamp = RemoteClockModel 0 - , Mx.mhNum = ptclNum - , Mx.mhDir = ptclDir - , Mx.mhLength = fromIntegral $ LBS.length blob - } - , Mx.msBlob = blob - } - + case ptHost of + Right (ip, port) -> + object [ + "rtt" .= ptRtt + , "hash" .= hexStr ptHash + , "blockNo" .= ptBlockNo + , "slotNo" .= ptSlotNo + , "addr" .= show ip + , "port" .= (fromIntegral port :: Word16) + ] + Left path -> + object [ + "rtt" .= ptRtt + , "hash" .= hexStr ptHash + , "blockNo" .= ptBlockNo + , "slotNo" .= ptSlotNo + , "path" .= path + ] data StatPoint = StatPoint { spTimestamp :: UTCTime - , spHost :: String + , spHost :: TL.Text , spCookie :: Word16 , spSample :: Double , spMedian :: Double @@ -599,7 +214,7 @@ instance Show StatPoint where show :: StatPoint -> String show StatPoint {..} = printf "%-31s %-28s %7d, %7.3f, %7.3f, %7.3f, %7.3f, %7.3f, %7.3f, %7.3f" - (iso8601Show spTimestamp ++ ",") (spHost ++ ",") spCookie spSample spMedian spP90 spMean spMin spMax spStd + (iso8601Show spTimestamp ++ ",") (show spHost ++ ",") spCookie spSample spMedian spP90 spMean spMin spMax spStd instance ToJSON StatPoint where toJSON :: StatPoint -> Value @@ -616,7 +231,7 @@ instance ToJSON StatPoint where , "max" .= spMax ] -toStatPoint :: UTCTime -> String -> Word16 -> Double -> TDigest 5 -> StatPoint +toStatPoint :: UTCTime -> TL.Text -> Word16 -> Double -> TDigest 5 -> StatPoint toStatPoint ts host cookie sample td = StatPoint { spTimestamp = ts @@ -647,223 +262,391 @@ keepAliveDelay = 1 idleTimeout :: MT.DiffTime idleTimeout = 5 -sduTimeout :: MT.DiffTime -sduTimeout = 30 -data PingClientError = PingClientDeserialiseFailure DeserialiseFailure String - | PingClientFindIntersectDeserialiseFailure DeserialiseFailure String - | PingClientKeepAliveDeserialiseFailure DeserialiseFailure String - | PingClientKeepAliveProtocolFailure KeepAliveFailure String - | PingClientHandshakeFailure HandshakeFailure String - | PingClientNegotiationError String [NodeVersion] String - | PingClientIPAddressFailure String - deriving Show +data PingClientError + = PingClientProtocolLimitFailure ProtocolLimitFailure + -- ^ protocol limit error + + | forall versionNumber. + Show versionNumber + => PingClientHandshakeProtocolError (HandshakeProtocolError versionNumber) TL.Text + -- ^ handshake protocol error + + | PingClientIPAddressFailure TL.Text + -- ^ failed to get IP address from SockAddr + +deriving instance Show PingClientError instance Exception PingClientError where - displayException (PingClientDeserialiseFailure err peerStr) = - printf "%s Decoding error: %s" peerStr (show err) - displayException (PingClientFindIntersectDeserialiseFailure err peerStr) = - printf "%s findIntersect decoding error %s" peerStr (show err) - displayException (PingClientKeepAliveDeserialiseFailure err peerStr) = - printf "%s keepalive decoding error %s" peerStr (show err) - displayException (PingClientKeepAliveProtocolFailure err peerStr) = - printf "%s keepalive protocol error %s" peerStr (show err) - displayException (PingClientHandshakeFailure err peerStr) = - printf "%s Protocol error: %s" peerStr (show err) - displayException (PingClientNegotiationError err recVersions peerStr) = - printf "%s Version negotiation error %s\nReceived versions: %s\n" peerStr err (show recVersions) displayException (PingClientIPAddressFailure peerStr) = printf "%s expected an IP address\n" peerStr - -pingClient :: Tracer IO LogMsg -> Tracer IO String -> PingOpts -> [NodeVersion] -> AddrInfo -> IO () -pingClient stdout stderr PingOpts{..} versions peer = bracket - (Socket.socket (Socket.addrFamily peer) Socket.Stream Socket.defaultProtocol) - Socket.close - (\sd -> withTimeoutSerial $ \timeoutfn -> do - when (Socket.addrFamily peer /= Socket.AF_UNIX) $ do - Socket.setSocketOption sd Socket.NoDelay 1 - Socket.setSockOpt sd Socket.Linger - StructLinger - { sl_onoff = 1 - , sl_linger = 0 - } - - !t0_s <- getMonotonicTime - Socket.connect sd (Socket.addrAddress peer) - !t0_e <- getMonotonicTime - peerStr <- peerString - let peerStr' = TL.pack peerStr - unless pingOptsQuiet $ TL.hPutStrLn IO.stdout $ peerStr' <> " " <> (showNetworkRtt $ toSample t0_e t0_s) - - bearer <- getBearer makeSocketBearer sduTimeout sd Nothing - - !t1_s <- write bearer nullTracer timeoutfn $ wrap handshakeNum InitiatorDir (handshakeReq versions pingOptsHandshakeQuery) - (msg, !t1_e) <- nextMsg bearer timeoutfn handshakeNum - unless pingOptsQuiet $ TL.hPutStrLn IO.stdout $ peerStr' <> " " <> (showHandshakeRtt $ diffTime t1_e t1_s) - - case CBOR.deserialiseFromBytes handshakeDec msg of - Left err -> throwIO (PingClientDeserialiseFailure err peerStr) - Right (_, Left err) -> throwIO (PingClientHandshakeFailure err peerStr) - Right (_, Right recVersions) -> do - case acceptVersions recVersions of - Left err -> throwIO (PingClientNegotiationError err recVersions peerStr) - Right version -> do - let isUnixSocket = case Socket.addrFamily peer of - Socket.AF_UNIX -> True - _ -> False - querySupported = not isUnixSocket && (version >= NodeToNodeVersionV11 minBound minBound) - || isUnixSocket && (version >= NodeToClientVersionV15 minBound) - - when ( (not pingOptsHandshakeQuery && not pingOptsQuiet) - || ( pingOptsHandshakeQuery && not querySupported)) $ - -- print the negotiated version iff not quiet or querying but, query - -- is not supported by the remote host. - TL.hPutStrLn IO.stdout $ peerStr' <> " " <> (showNegotiatedVersion version) - when (pingOptsHandshakeQuery && querySupported) $ - -- print query results if it was supported by the remote side - TL.hPutStrLn IO.stdout $ peerStr' <> " " <> (showQueriedVersions recVersions) - when (not pingOptsHandshakeQuery && not isUnixSocket) $ do - if pingOptsGetTip - then getTip bearer timeoutfn peerStr - else keepAlive bearer timeoutfn peerStr version (tdigest []) 0 - -- send terminating message - _ <- write bearer nullTracer timeoutfn $ wrap keepaliveNum InitiatorDir (keepAliveDone version) - return () - -- protocol idle timeout - MT.threadDelay idleTimeout - - ) + displayException (PingClientProtocolLimitFailure err) = + displayException err + displayException (PingClientHandshakeProtocolError err peerStr) = + printf "%s handshake error: %s" peerStr (show err) + +data ProtocolFlavour version versionData where + NodeToNode :: NetworkMagic + -> Bool + -> ProtocolFlavour NodeToNodeVersion + NodeToNodeVersionData + NodeToClient :: NetworkMagic + -> Bool + -> ProtocolFlavour NodeToClientVersion + NodeToClientVersionData + +-- +-- ChainSync Tip Sampling +-- + +-- We don't need blocks, headers or points, so we just go away with any valid CBOR +-- term: +type ChainSyncHeader = CBOR.Term +type ChainSyncPoint = CBOR.Term +data ChainSyncBlock +type instance HeaderHash ChainSyncBlock = ByteString +instance ShowProxy ChainSyncBlock where +type ChainSyncTip = Tip ChainSyncBlock + + +chainSyncClient + :: Tracer IO LogMsg + -> Either FilePath (IP, Socket.PortNumber) + -> LogFormat + -> ChainSyncClient ChainSyncHeader ChainSyncPoint ChainSyncTip IO () +chainSyncClient stdout host logFormat = + ChainSync.ChainSyncClient $ do + start <- getMonotonicTime + return (go start) where - - acceptVersions :: [NodeVersion] -> Either String NodeVersion - acceptVersions recVersions = - let intersects = L.intersectBy isSameVersionAndMagic recVersions versions in - case intersects of - [] -> Left $ "No overlapping versions with " <> show versions - vs -> Right $ foldr1 max vs - - showNetworkRtt :: Double -> TL.Text - showNetworkRtt rtt = - if pingOptsJson - then encodeToLazyText $ object ["network_rtt" .= toJSON rtt] - else TL.pack $ printf "network rtt: %.3f" rtt - - showHandshakeRtt :: DiffTime -> TL.Text - showHandshakeRtt diff = - if pingOptsJson - then encodeToLazyText $ object ["handshake_rtt" .= toJSON ((fromRational $ toRational diff) :: Double)] - else TL.pack $ printf "handshake rtt: %s" $ show diff - - showNegotiatedVersion :: NodeVersion -> TL.Text - showNegotiatedVersion version = - if pingOptsJson - then encodeToLazyText $ object ["negotiated_version" .= toJSON version] - else TL.pack $ printf "Negotiated version %s" (show version) - - showQueriedVersions :: [NodeVersion] -> TL.Text - showQueriedVersions recVersions = - if pingOptsJson - then encodeToLazyText $ object ["queried_versions" .= toJSONList recVersions] - else TL.pack $ printf "Queried versions %s" (show recVersions) - - peerString :: IO String - peerString = + go :: Time + -> ChainSync.ClientStIdle ChainSyncHeader ChainSyncPoint ChainSyncTip IO () + go start = ChainSync.SendMsgFindIntersect [] + ChainSync.ClientStIntersect { + ChainSync.recvMsgIntersectFound = \_ _tip -> + ChainSync.ChainSyncClient $ do + -- this should not happen, as we send an empty list of points + return $ ChainSync.SendMsgDone (), + ChainSync.recvMsgIntersectNotFound = \tip -> + ChainSync.ChainSyncClient $ do + end <- getMonotonicTime + let (ptSlotNo, ptHash, ptBlockNo) = case tip of + TipGenesis -> (0, mempty, 0) + Tip slotNo hash blockNo -> (slotNo, hash, blockNo) + pingTip = PingTip { + ptHost = host, + ptRtt = toSample end start, + ptHash, + ptBlockNo, + ptSlotNo + } + case logFormat of + AsJSON -> traceWith stdout $ LogMsg (encode pingTip) + AsText -> traceWith stdout $ LogMsg $ LBS.Char.pack $ show pingTip <> "\n" + return $ ChainSync.SendMsgDone () + } + + +-- +-- KeepAlive RTT sampling +-- + +keepAliveClient + :: Tracer IO LogMsg + -> TL.Text -- ^ peer + -> LogFormat -- ^ use JSON formatting + -> TDigest 5 + -> KeepAlive.Cookie + -> KeepAliveClient IO () +keepAliveClient stdout peerName logFormat td0 cookie0 = + KeepAliveClient $ loop td0 cookie0 + where + loop :: TDigest 5 + -> KeepAlive.Cookie + -> IO (KeepAlive.KeepAliveClientSt IO ()) + loop td cookie = do + start <- getMonotonicTime + return $ KeepAlive.SendMsgKeepAlive cookie $ do + end <- getMonotonicTime + now <- getCurrentTime + let rtt = toSample end start + td' = insert rtt td + point = toStatPoint now peerName (KeepAlive.unCookie cookie) rtt td' + case logFormat of + AsJSON -> traceWith stdout $ LogMsg (encode point) + AsText -> traceWith stdout $ LogMsg $ LBS.Char.pack $ show point <> "\n" + MT.threadDelay keepAliveDelay + loop td' (KeepAlive.Cookie (KeepAlive.unCookie cookie + 1)) + + +-- +-- Ping Client +-- + +pingClients + :: forall versionNumber versionData. + ( Acceptable versionData + , Queryable versionData + , Ord versionNumber + , Show versionNumber + , ToJSON versionNumber + ) + => ProtocolFlavour versionNumber versionData + -> Tracer IO String + -> PingOpts + -> [AddrInfo] + -> IO () +pingClients protocol stderr opts peers = do + + msgQueue <- newEmptyTMVarIO + let tracer :: Tracer IO LogMsg + tracer = Tracer $ \msg -> atomically $ putTMVar msgQueue msg + + mapConcurrently_ (pingClient protocol tracer opts) peers + `race_` + loggerThread opts msgQueue + `catch` + \(e :: SomeException) -> traceWith stderr (displayException e) + + +pingClient + :: forall versionNumber versionData. + ( Acceptable versionData + , Queryable versionData + , Ord versionNumber + , Show versionNumber + , ToJSON versionNumber + ) + => ProtocolFlavour versionNumber versionData + -> Tracer IO LogMsg + -> PingOpts + -> AddrInfo + -> IO () +pingClient protocol stdout opts@PingOpts{..} peer = + bracket + (Socket.socket (Socket.addrFamily peer) Socket.Stream Socket.defaultProtocol) + Socket.close + (\sd -> do + when (Socket.addrFamily peer /= Socket.AF_UNIX) $ do + Socket.setSocketOption sd Socket.NoDelay 1 + Socket.setSockOpt sd Socket.Linger + StructLinger + { sl_onoff = 1 + , sl_linger = 0 + } + runPingClient sd + ) + where + runPingClient :: Socket.Socket -> IO () + runPingClient sd = do + peerName <- getPeerName + let logMsg :: Format msg => msg -> IO () + logMsg = logMsgWithPeer opts peerName + + !t0_s <- getMonotonicTime + Socket.connect sd (Socket.addrAddress peer) + !t0_e <- getMonotonicTime + + logMsg $ NetworkRTT (toSample t0_e t0_s) + + connId <- ConnectionId <$> Socket.getSocketName sd + <*> Socket.getPeerName sd + bearer <- getBearer makeSocketBearer sduTimeout sd Nothing + + -- Run handshake with RTT measurements + -- NOTE: we pass all versions supported by `cardano-diffusion:api` + r <- runHandshakeClientWithRTT + @versionNumber @versionData @() + bearer connId + HandshakeArguments { + haHandshakeTracer = nullTracer, + haBearerTracer = nullTracer, + haHandshakeCodec = case protocol of + NodeToNode {} -> nodeToNodeHandshakeCodec + NodeToClient {} -> nodeToClientHandshakeCodec, + haVersionDataCodec = case protocol of + NodeToNode {} -> cborTermVersionDataCodec nodeToNodeCodecCBORTerm + NodeToClient {} -> cborTermVersionDataCodec nodeToClientCodecCBORTerm, + haAcceptVersion = acceptableVersion, + haQueryVersion = queryVersion, + haTimeLimits = timeLimitsHandshake + } + (case protocol of + NodeToNode networkMagic query -> + foldMapVersions + (\versionNumber -> + simpleSingletonVersions + versionNumber + NodeToNodeVersionData { + networkMagic, + diffusionMode = InitiatorOnlyDiffusionMode, + peerSharing = PeerSharingDisabled, + query + } + (const ()) + ) + [minBound..maxBound] + + NodeToClient networkMagic query -> + foldMapVersions + (\versionNumber -> + simpleSingletonVersions + versionNumber + NodeToClientVersionData { + networkMagic, + query + } + (const ()) + ) + [minBound..maxBound] + ) + case r of + Left err -> throwIO (PingClientProtocolLimitFailure err) + Right (Left err', rtt) -> do + logMsg (HandshakeRTT rtt) + throwIO (PingClientHandshakeProtocolError err' peerName) + Right (Right r', rtt) -> do + logMsg (HandshakeRTT rtt) + case r' of + HandshakeQueryResult versions -> do + -- print query results if it was supported by the remote side + unless pingOptsHandshakeQuery $ + logMsg $ QueriedVersions (Map.keys versions) + HandshakeNegotiationResult _ version _versionData -> do + -- show negotiated version + logMsg $ NegotiatedVersion version + case protocol of + NodeToClient {} -> pure () + NodeToNode {} | pingOptsGetTip -> do + -- + -- run chain sync to get the tip + -- + let host = + case Socket.addrAddress peer of + Socket.SockAddrUnix path -> Left path + Socket.SockAddrInet pn ha -> Right (IPv4 (fromHostAddress ha), pn) + Socket.SockAddrInet6 pn _ ha _ -> Right (IPv6 (fromHostAddress6 ha), pn) + stdGen <- initStdGen + mx <- Mx.new + Mx.nullTracers + [MiniProtocolInfo { + miniProtocolNum = NodeToNode.chainSyncMiniProtocolNum, + miniProtocolDir = Mx.InitiatorDirectionOnly, + miniProtocolLimits = NodeToNode.chainSyncProtocolLimits NodeToNode.defaultMiniProtocolParameters, + miniProtocolCapability = Nothing + }] + race_ (Mx.run mx bearer) + (Mx.runMiniProtocol mx + NodeToNode.chainSyncMiniProtocolNum + Mx.InitiatorDirectionOnly + Mx.StartEagerly + $ \channel -> do + runPeerWithLimitsRnd + nullTracer + stdGen + (ChainSync.codecChainSync CBOR.encodeTerm CBOR.decodeTerm + CBOR.encodeTerm CBOR.decodeTerm + (encodeTip Serialise.encode) + (decodeTip Serialise.decode)) + (ChainSync.byteLimitsChainSync (fromIntegral . BL.length)) + (ChainSync.timeLimitsChainSync defaultChainSyncIdleTimeout) + channel + (ChainSync.chainSyncClientPeer $ chainSyncClient stdout host pingOptsJson) + ) + `finally` Mx.stop mx + NodeToNode {} | otherwise -> do + -- + -- run keepalive client to get RTT samples + -- + mx <- Mx.new + Mx.nullTracers + [MiniProtocolInfo { + miniProtocolNum = NodeToNode.keepAliveMiniProtocolNum, + miniProtocolDir = Mx.InitiatorDirectionOnly, + miniProtocolLimits = NodeToNode.keepAliveProtocolLimits NodeToNode.defaultMiniProtocolParameters, + miniProtocolCapability = Nothing + }] + race_ (Mx.run mx bearer) + (Mx.runMiniProtocol mx + NodeToNode.chainSyncMiniProtocolNum + Mx.InitiatorDirectionOnly + Mx.StartEagerly + $ \channel -> do + runPeerWithLimits + nullTracer + KeepAlive.codecKeepAlive_v2 + (KeepAlive.byteLimitsKeepAlive (fromIntegral . BL.length)) + KeepAlive.timeLimitsKeepAlive + channel + (KeepAlive.keepAliveClientPeer + $ keepAliveClient + stdout + peerName + pingOptsJson + (tdigest []) + (KeepAlive.Cookie 0)) + ) + `finally` Mx.stop mx + MT.threadDelay idleTimeout + + getPeerName :: IO TL.Text + getPeerName = case Socket.addrFamily peer of - Socket.AF_UNIX -> return $ show $ Socket.addrAddress peer + Socket.AF_UNIX -> return $ TL.pack . show $ Socket.addrAddress peer _ -> do (Just host, Just port) <- Socket.getNameInfo [Socket.NI_NUMERICHOST, Socket.NI_NUMERICSERV] True True (Socket.addrAddress peer) - return $ host <> ":" <> port - - toSample :: Time -> Time -> Double - toSample t_e t_s = realToFrac $ diffTime t_e t_s - - eprint :: String -> IO () - eprint = traceWith stderr - - nextMsg :: Mx.Bearer IO -> TimeoutFn IO -> MiniProtocolNum -> IO (LBS.ByteString, Time) - nextMsg bearer timeoutfn ptclNum = do - (sdu, t_e) <- Network.Mux.Types.read bearer nullTracer timeoutfn - if Mx.mhNum (Mx.msHeader sdu) == ptclNum - then return (Mx.msBlob sdu, t_e) - else nextMsg bearer timeoutfn ptclNum - - keepAlive :: Mx.Bearer IO - -> TimeoutFn IO - -> String - -> NodeVersion - -> TDigest 5 - -> Word32 - -> IO () - keepAlive _ _ _ _ _ cookie | cookie == pingOptsCount = return () - keepAlive bearer timeoutfn peerStr version td !cookie = do - let cookie16 = fromIntegral cookie - !t_s <- write bearer nullTracer timeoutfn $ wrap keepaliveNum InitiatorDir (keepAliveReq version cookie16) - (!msg, !t_e) <- nextMsg bearer timeoutfn keepaliveNum - let rtt = toSample t_e t_s - td' = insert rtt td - case CBOR.deserialiseFromBytes (keepAliveRspDec version) msg of - Left err -> throwIO (PingClientKeepAliveDeserialiseFailure err peerStr) - Right (_, Left err) -> throwIO (PingClientKeepAliveProtocolFailure err peerStr) - Right (_, Right cookie') -> do - when (cookie' /= cookie16) $ eprint $ printf "%s cookie missmatch %d /= %d" - peerStr cookie' cookie - - now <- getCurrentTime - let point = toStatPoint now peerStr cookie16 rtt td' - if pingOptsJson - then traceWith stdout $ LogMsg (encode point) - else traceWith stdout $ LogMsg $ LBS.Char.pack $ show point <> "\n" - MT.threadDelay keepAliveDelay - keepAlive bearer timeoutfn peerStr version td' (cookie + 1) - - getTip :: Mx.Bearer IO - -> TimeoutFn IO - -> String - -> IO () - getTip bearer timeoutfn peerStr = do - !t_s <- write bearer nullTracer timeoutfn $ wrap chainSyncNum InitiatorDir chainSyncFindIntersect - (!msg, !t_e) <- nextMsg bearer timeoutfn chainSyncNum - case CBOR.deserialiseFromBytes chainSyncIntersectNotFoundDec msg of - Left err -> throwIO (PingClientFindIntersectDeserialiseFailure err peerStr) - Right (_, (slotNo, blockNo, hash)) -> - case fromSockAddr $ Socket.addrAddress peer of - Nothing -> throwIO (PingClientIPAddressFailure peerStr) - Just host -> - let tip = PingTip host (toSample t_e t_s) hash blockNo slotNo in - if pingOptsJson then traceWith stdout $ LogMsg (encode tip) - else traceWith stdout $ LogMsg $ LBS.Char.pack $ show tip <> "\n" - -isSameVersionAndMagic :: NodeVersion -> NodeVersion -> Bool -isSameVersionAndMagic v1 v2 = extract v1 == extract v2 - where extract :: NodeVersion -> (Int, Word32) - extract (NodeToClientVersionV9 m) = (-9, m) - extract (NodeToClientVersionV10 m) = (-10, m) - extract (NodeToClientVersionV11 m) = (-11, m) - extract (NodeToClientVersionV12 m) = (-12, m) - extract (NodeToClientVersionV13 m) = (-13, m) - extract (NodeToClientVersionV14 m) = (-14, m) - extract (NodeToClientVersionV15 m) = (-15, m) - extract (NodeToClientVersionV16 m) = (-16, m) - extract (NodeToClientVersionV17 m) = (-17, m) - extract (NodeToClientVersionV18 m) = (-18, m) - extract (NodeToClientVersionV19 m) = (-19, m) - extract (NodeToClientVersionV20 m) = (-20, m) - extract (NodeToClientVersionV21 m) = (-21, m) - extract (NodeToClientVersionV22 m) = (-22, m) - extract (NodeToNodeVersionV1 m) = (1, m) - extract (NodeToNodeVersionV2 m) = (2, m) - extract (NodeToNodeVersionV3 m) = (3, m) - extract (NodeToNodeVersionV4 m _) = (4, m) - extract (NodeToNodeVersionV5 m _) = (5, m) - extract (NodeToNodeVersionV6 m _) = (6, m) - extract (NodeToNodeVersionV7 m _) = (7, m) - extract (NodeToNodeVersionV8 m _) = (8, m) - extract (NodeToNodeVersionV9 m _) = (9, m) - extract (NodeToNodeVersionV10 m _) = (10, m) - extract (NodeToNodeVersionV11 m _) = (11, m) - extract (NodeToNodeVersionV12 m _) = (12, m) - extract (NodeToNodeVersionV13 m _ _) = (13, m) - extract (NodeToNodeVersionV14 m _ _) = (14, m) + return $ TL.pack $ host <> ":" <> port + + +toSample :: Time -> Time -> Double +toSample end start = realToFrac $ end `diffTime` start + +class Format a where + format :: LogFormat -> a -> TL.Text + +newtype NegotiatedVersion versionNumber = NegotiatedVersion versionNumber + +instance (ToJSON versionNumber, Show versionNumber) + => Format (NegotiatedVersion versionNumber) where + format AsJSON (NegotiatedVersion v) = encodeToLazyText $ object ["negotiated_version" .= toJSON v] + format AsText (NegotiatedVersion v) = TL.pack $ printf "Negotiated version %s" (show v) + +newtype QueriedVersions versionNumber = QueriedVersions [versionNumber] + +instance (ToJSON versionNumber, Show versionNumber) + => Format (QueriedVersions versionNumber) where + format AsJSON (QueriedVersions vs) = encodeToLazyText $ object ["queried_versions" .= toJSON vs] + format AsText (QueriedVersions vs) = TL.pack $ printf "Queried versions %s" (show vs) + +instance Format [NodeToClientVersion] where + format AsJSON vs = encodeToLazyText $ object ["negotiated_versions" .= toJSON vs] + format AsText v = TL.pack $ printf "Negotiated versions %s" (show v) + +newtype NetworkRTT = NetworkRTT Double + +instance Format NetworkRTT where + format AsJSON (NetworkRTT rtt) = encodeToLazyText $ object ["network_rtt" .= toJSON rtt] + format AsText (NetworkRTT rtt) = TL.pack $ printf "network rtt: %.3f" rtt + +newtype HandshakeRTT = HandshakeRTT DiffTime + +instance Format HandshakeRTT where + format AsJSON (HandshakeRTT diff) = encodeToLazyText $ object ["handshake_rtt" .= toJSON ((fromRational $ toRational diff) :: Double)] + format AsText (HandshakeRTT diff) = TL.pack $ printf "handshake rtt: %s" $ show diff + + +-- note: use `logMsg` defined above in terms of `logMsgWithPeer` +logMsgWithPeer :: Format msg + => PingOpts + -> TL.Text -- ^ peer identifier + -> msg + -> IO () +logMsgWithPeer PingOpts { pingOptsQuiet, pingOptsJson } peerStr msg = + unless pingOptsQuiet $ TL.hPutStrLn IO.stdout (peerStr <> " " <> format pingOptsJson msg) + + +instance ShowProxy CBOR.Term where + showProxy _ = "CBOR.Term" diff --git a/cardano-diffusion/protocols/tests-lib/Cardano/Network/Protocol/Handshake/Test.hs b/cardano-diffusion/protocols/tests-lib/Cardano/Network/Protocol/Handshake/Test.hs index 37194a4c7d6..32a8dafe250 100644 --- a/cardano-diffusion/protocols/tests-lib/Cardano/Network/Protocol/Handshake/Test.hs +++ b/cardano-diffusion/protocols/tests-lib/Cardano/Network/Protocol/Handshake/Test.hs @@ -33,7 +33,6 @@ import Cardano.Network.NodeToNode.Version as NTN import Ouroboros.Network.Channel import Ouroboros.Network.CodecCBORTerm import Ouroboros.Network.Driver.Simple (runConnectedPeers) -import Ouroboros.Network.Magic import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing (..)) import Ouroboros.Network.Protocol.Handshake.Client diff --git a/ouroboros-network/api/lib/Ouroboros/Network/Handshake/Acceptable.hs b/ouroboros-network/api/lib/Ouroboros/Network/Handshake/Acceptable.hs index 6acd04a0c7d..002cc27d102 100644 --- a/ouroboros-network/api/lib/Ouroboros/Network/Handshake/Acceptable.hs +++ b/ouroboros-network/api/lib/Ouroboros/Network/Handshake/Acceptable.hs @@ -8,13 +8,13 @@ import Data.Text -- | A @'Maybe'@ like type which better explains its purpose. -- -data Accept vData - = Accept vData +data Accept versionData + = Accept versionData | Refuse !Text deriving (Eq, Show) -class Acceptable v where +class Acceptable versionData where -- | The 'acceptableVersion' function ought to be symmetric, this guarantees -- that local and remote sides will agree on the same data. - acceptableVersion :: v -> v -> Accept v + acceptableVersion :: versionData -> versionData -> Accept versionData diff --git a/ouroboros-network/api/lib/Ouroboros/Network/Handshake/Queryable.hs b/ouroboros-network/api/lib/Ouroboros/Network/Handshake/Queryable.hs index c1d50d4562c..7f8ae8eefef 100644 --- a/ouroboros-network/api/lib/Ouroboros/Network/Handshake/Queryable.hs +++ b/ouroboros-network/api/lib/Ouroboros/Network/Handshake/Queryable.hs @@ -1,5 +1,5 @@ module Ouroboros.Network.Handshake.Queryable (Queryable (..)) where -class Queryable v where +class Queryable versionData where -- | Whether or not there was a query for the supported version. - queryVersion :: v -> Bool + queryVersion :: versionData -> Bool diff --git a/ouroboros-network/api/lib/Ouroboros/Network/PeerSelection/PeerSharing.hs b/ouroboros-network/api/lib/Ouroboros/Network/PeerSelection/PeerSharing.hs index 9033311ed9b..5fe7b4c8a94 100644 --- a/ouroboros-network/api/lib/Ouroboros/Network/PeerSelection/PeerSharing.hs +++ b/ouroboros-network/api/lib/Ouroboros/Network/PeerSelection/PeerSharing.hs @@ -17,7 +17,7 @@ import GHC.Generics (Generic) data PeerSharing = PeerSharingDisabled -- ^ Peer does not participate in Peer Sharing -- at all | PeerSharingEnabled -- ^ Peer participates in Peer Sharing - deriving (Eq, Show, Read, Generic) + deriving (Eq, Ord, Show, Read, Generic) -- | The combination of two 'PeerSharing' values forms a Monoid where the unit -- is 'PeerSharingEnabled'. diff --git a/ouroboros-network/framework/lib/Ouroboros/Network/Protocol/Handshake.hs b/ouroboros-network/framework/lib/Ouroboros/Network/Protocol/Handshake.hs index baa89ff9e48..e20d94ed19e 100644 --- a/ouroboros-network/framework/lib/Ouroboros/Network/Protocol/Handshake.hs +++ b/ouroboros-network/framework/lib/Ouroboros/Network/Protocol/Handshake.hs @@ -7,6 +7,7 @@ -- module Ouroboros.Network.Protocol.Handshake ( runHandshakeClient + , runHandshakeClientWithRTT , runHandshakeServer , HandshakeArguments (..) , Versions (..) @@ -89,7 +90,6 @@ tryHandshake doHandshake = do return $ Left $ HandshakeProtocolError err Right (Right r) -> return $ Right r - -- -- Record arguments -- @@ -131,24 +131,24 @@ data HandshakeArguments connectionId vNumber vData m = HandshakeArguments { } --- | Run client side of the 'Handshake' protocol +-- | Run client side of the 'Handshake' protocol. -- runHandshakeClient - :: ( MonadAsync m + :: forall versionNumber versionData application connId m. + ( MonadAsync m , MonadFork m , MonadTimer m , MonadMask m , MonadThrow (STM m) - , Ord vNumber + , Ord versionNumber ) => Mx.Bearer m - -> connectionId - -> HandshakeArguments connectionId vNumber vData m - -> Versions vNumber vData application - -> m (Either (HandshakeException vNumber) - (HandshakeResult application vNumber vData)) -runHandshakeClient bearer - connectionId + -> connId + -> HandshakeArguments connId versionNumber versionData m + -> Versions versionNumber versionData application + -> m (Either (HandshakeException versionNumber) + (HandshakeResult application versionNumber versionData)) +runHandshakeClient bearer connectionId HandshakeArguments { haHandshakeTracer, haBearerTracer, @@ -157,35 +157,89 @@ runHandshakeClient bearer haAcceptVersion, haTimeLimits } - versions = - tryHandshake - (fst <$> - runPeerWithLimits - (Mx.WithBearer connectionId `contramap` haHandshakeTracer) - haHandshakeCodec - byteLimitsHandshake - haTimeLimits - (Mx.bearerAsChannel (Mx.WithBearer connectionId `contramap` haBearerTracer) - bearer handshakeProtocolNum Mx.InitiatorDir) - (handshakeClientPeer haVersionDataCodec haAcceptVersion versions)) + versions = + tryHandshake + (fst <$> + runPeerWithLimits + (Mx.WithBearer connectionId `contramap` haHandshakeTracer) + haHandshakeCodec + byteLimitsHandshake + haTimeLimits + (Mx.bearerAsChannel (Mx.WithBearer connectionId `contramap` haBearerTracer) + bearer handshakeProtocolNum Mx.InitiatorDir) + (handshakeClientPeer haVersionDataCodec haAcceptVersion versions)) + +-- | Run client side of the 'Handshake' protocol and compute RTT. +-- +runHandshakeClientWithRTT + :: forall versionNumber versionData application connId m. + ( MonadAsync m + , MonadFork m + , MonadTimer m + , MonadMask m + , MonadThrow (STM m) + , Ord versionNumber + ) + => Mx.Bearer m + -> connId + -> HandshakeArguments connId versionNumber versionData m + -> Versions versionNumber versionData application + -> m (Either ProtocolLimitFailure + ( Either (HandshakeProtocolError versionNumber) + (HandshakeResult application versionNumber versionData) + , DiffTime + )) +runHandshakeClientWithRTT + bearer + connectionId + HandshakeArguments { + haHandshakeTracer, + haBearerTracer, + haHandshakeCodec, + haVersionDataCodec, + haAcceptVersion, + haTimeLimits + } + versions + = + tryHandshakeWithRTT + (fst <$> + runPeerWithLimits + (Mx.WithBearer connectionId `contramap` haHandshakeTracer) + haHandshakeCodec + byteLimitsHandshake + haTimeLimits + (Mx.bearerAsChannel (Mx.WithBearer connectionId `contramap` haBearerTracer) + bearer handshakeProtocolNum Mx.InitiatorDir) + (handshakeClientPeerWithRTT haVersionDataCodec haAcceptVersion versions)) + where + tryHandshakeWithRTT :: forall r. + m ( Either (HandshakeProtocolError versionNumber) r + , DiffTime + ) + -> m (Either ProtocolLimitFailure ( Either (HandshakeProtocolError versionNumber) r + , DiffTime + )) + tryHandshakeWithRTT = try -- | Run server side of the 'Handshake' protocol. -- runHandshakeServer - :: ( MonadAsync m + :: forall versionNumber versionData application connId m. + ( MonadAsync m , MonadFork m , MonadTimer m , MonadMask m , MonadThrow (STM m) - , Ord vNumber + , Ord versionNumber ) => Mx.Bearer m - -> connectionId - -> HandshakeArguments connectionId vNumber vData m - -> Versions vNumber vData application - -> m (Either (HandshakeException vNumber) - (HandshakeResult application vNumber vData)) + -> connId + -> HandshakeArguments connId versionNumber versionData m + -> Versions versionNumber versionData application + -> m (Either (HandshakeException versionNumber) + (HandshakeResult application versionNumber versionData)) runHandshakeServer bearer connectionId HandshakeArguments { diff --git a/ouroboros-network/framework/lib/Ouroboros/Network/Protocol/Handshake/Client.hs b/ouroboros-network/framework/lib/Ouroboros/Network/Protocol/Handshake/Client.hs index 01247093469..1d16832a1be 100644 --- a/ouroboros-network/framework/lib/Ouroboros/Network/Protocol/Handshake/Client.hs +++ b/ouroboros-network/framework/lib/Ouroboros/Network/Protocol/Handshake/Client.hs @@ -8,11 +8,13 @@ module Ouroboros.Network.Protocol.Handshake.Client ( handshakeClientPeer + , handshakeClientPeerWithRTT , decodeQueryResult , encodeVersions , acceptOrRefuse ) where +import Control.Monad.Class.MonadTime.SI import Data.Map (Map) import Data.Map qualified as Map import Data.Text (Text) @@ -25,62 +27,149 @@ import Ouroboros.Network.Protocol.Handshake.Codec import Ouroboros.Network.Protocol.Handshake.Type import Ouroboros.Network.Protocol.Handshake.Version - -- | Handshake client which offers @'Versions' vNumber vData@ to the -- remote peer. +handshakeClientPeer + :: ( Monad m + , Ord vNumber + ) + => VersionDataCodec CBOR.Term vNumber vData + -> (vData -> vData -> Accept vData) + -> Versions vNumber vData r + -> Client (Handshake vNumber CBOR.Term) + NonPipelined StPropose m + (Either + (HandshakeProtocolError vNumber) + (HandshakeResult r vNumber vData) + ) +handshakeClientPeer codec acceptVersion versions = + fst <$> handshakeClientPeer' nullTimeAPI + codec acceptVersion versions + +-- | Handshake client which offers @'Versions' vNumber vData@ to the +-- remote peer and computes round trip time. -- -- TODO: GADT encoding of the client (@Handshake.Client@ module). -- -handshakeClientPeer +handshakeClientPeerWithRTT :: ( Ord vNumber + , MonadMonotonicTime m ) => VersionDataCodec CBOR.Term vNumber vData -> (vData -> vData -> Accept vData) -> Versions vNumber vData r -> Client (Handshake vNumber CBOR.Term) NonPipelined StPropose m - (Either - (HandshakeProtocolError vNumber) - (HandshakeResult r vNumber vData)) -handshakeClientPeer codec@VersionDataCodec {encodeData, decodeData} - acceptVersion versions = - -- send known versions - Yield (MsgProposeVersions $ encodeVersions encodeData versions) $ - - Await $ \msg -> case msg of - MsgReplyVersions vMap -> - -- simultaneous open; 'accept' will choose version (the greatest common - -- version), and check if we can accept received version data. - Done $ case acceptOrRefuse codec acceptVersion versions vMap of - Right (r, vNumber, vData) -> Right $ HandshakeNegotiationResult r vNumber vData - Left vReason -> Left (HandshakeError vReason) - - MsgQueryReply vMap -> - Done $ Right $ decodeQueryResult decodeData vMap - - -- the server refused common highest version - MsgRefuse vReason -> - Done (Left $ HandshakeError vReason) - - -- the server accepted a version, sent back the version number and its - -- version data blob - MsgAcceptVersion vNumber vParams -> - case vNumber `Map.lookup` getVersions versions of - Nothing -> Done (Left $ NotRecognisedVersion vNumber) - Just (Version app vData) -> - case decodeData vNumber vParams of - - Left err -> - Done (Left (HandshakeError $ HandshakeDecodeError vNumber err)) - - Right vData' -> - case acceptVersion vData vData' of - Accept agreedData -> - Done $ Right $ HandshakeNegotiationResult (app agreedData) - vNumber - agreedData - Refuse err -> - Done (Left (InvalidServerSelection vNumber err)) + ( Either + (HandshakeProtocolError vNumber) + (HandshakeResult r vNumber vData) + , DiffTime + ) + -- ^ the client which offers the versions, does the negotiation and + -- provides round trip time + +handshakeClientPeerWithRTT = handshakeClientPeer' monotonicTimeAPI + + +data TimeAPI time diffTime m = TimeAPI { + getTime :: m time, + timeDiff :: time -> time -> diffTime + } + +monotonicTimeAPI :: MonadMonotonicTime m => TimeAPI Time DiffTime m +monotonicTimeAPI = TimeAPI { + getTime = getMonotonicTime, + timeDiff = diffTime + } + +nullTimeAPI :: Applicative m => TimeAPI () () m +nullTimeAPI = TimeAPI { + getTime = pure (), + timeDiff = \() () -> () + } + +-- | A generic handshake client. +-- +handshakeClientPeer' + :: ( Ord vNumber + , Monad m + ) + => TimeAPI time diffTime m + -> VersionDataCodec CBOR.Term vNumber vData + -> (vData -> vData -> Accept vData) + -> Versions vNumber vData r + -> Client (Handshake vNumber CBOR.Term) + NonPipelined StPropose m + ( Either + (HandshakeProtocolError vNumber) + (HandshakeResult r vNumber vData) + , diffTime + ) + -- ^ the client which offers the versions, does the negotiation and + -- provides round trip time +handshakeClientPeer' TimeAPI {getTime, timeDiff} + codec@VersionDataCodec {encodeData, decodeData} + acceptVersion versions = + Effect $ do + start <- getTime + return $ + -- send known versions + Yield (MsgProposeVersions $ encodeVersions encodeData versions) $ + + Await $ \msg -> case msg of + MsgReplyVersions vMap -> Effect $ do + end <- getTime + -- simultaneous open; 'accept' will choose version (the greatest common + -- version), and check if we can accept received version data. + return $ Done $ case acceptOrRefuse codec acceptVersion versions vMap of + Right (r, vNumber, vData) -> ( Right $ HandshakeNegotiationResult r vNumber vData + , end `timeDiff` start + ) + Left vReason -> ( Left (HandshakeError vReason) + , end `timeDiff` start + ) + + MsgQueryReply vMap -> Effect $ do + end <- getTime + return $ Done ( Right $ decodeQueryResult decodeData vMap + , end `timeDiff` start + ) + + -- the server refused common highest version + MsgRefuse vReason -> Effect $ do + end <- getTime + return $ Done ( Left $ HandshakeError vReason + , end `timeDiff` start + ) + + -- the server accepted a version, sent back the version number and its + -- version data blob + MsgAcceptVersion vNumber vParams -> Effect $ do + end <- getTime + return $ case vNumber `Map.lookup` getVersions versions of + Nothing -> Done ( Left $ NotRecognisedVersion vNumber + , end `timeDiff` start + ) + Just (Version app vData) -> + case decodeData vNumber vParams of + + Left err -> + Done ( Left (HandshakeError $ HandshakeDecodeError vNumber err) + , end `timeDiff` start + ) + + Right vData' -> + case acceptVersion vData vData' of + Accept agreedData -> + Done ( Right $ HandshakeNegotiationResult (app agreedData) + vNumber + agreedData + , end `timeDiff` start + ) + Refuse err -> + Done ( Left (InvalidServerSelection vNumber err) + , end `timeDiff` start + ) decodeQueryResult :: (vNumber -> bytes -> Either Text vData) From c0591350ddd3f932fe775ac4fced9f09042e7c41 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Wed, 1 Oct 2025 11:49:32 +0200 Subject: [PATCH 03/11] cardano-diffusion:ping - query tip over node-to-client protocol The instantiation of `ChainSync` is polymorphic enough to support both protocols. --- cardano-diffusion/cardano-diffusion.cabal | 2 +- cardano-diffusion/demo/chain-sync.hs | 9 ------- .../lib/Cardano/Network/NodeToClient.hs | 19 ++++++++++++++ .../ping/Cardano/Network/Ping.hs | 26 ++++++++++++------- 4 files changed, 37 insertions(+), 19 deletions(-) diff --git a/cardano-diffusion/cardano-diffusion.cabal b/cardano-diffusion/cardano-diffusion.cabal index 1d27ba94e5e..3b67c229eea 100644 --- a/cardano-diffusion/cardano-diffusion.cabal +++ b/cardano-diffusion/cardano-diffusion.cabal @@ -523,7 +523,7 @@ library ping aeson >=2.1.1.0 && <3, base >=4.14 && <4.22, bytestring >=0.10 && <0.13, - cardano-diffusion:{api, cardano-diffusion, orphan-instances, protocols}, + cardano-diffusion:{cardano-diffusion, api, orphan-instances, protocols}, cborg >=0.2.8 && <0.3, containers, contra-tracer >=0.1 && <0.3, diff --git a/cardano-diffusion/demo/chain-sync.hs b/cardano-diffusion/demo/chain-sync.hs index b8dc1661346..f74a18b9024 100644 --- a/cardano-diffusion/demo/chain-sync.hs +++ b/cardano-diffusion/demo/chain-sync.hs @@ -204,15 +204,6 @@ rmIfExists path = do b <- doesFileExist path when b (removeFile path) --- TODO: provide sensible limits --- https://github.com/intersectmbo/ouroboros-network/issues/575 -maximumMiniProtocolLimits :: MiniProtocolLimits -maximumMiniProtocolLimits = - MiniProtocolLimits { - maximumIngressQueue = maxBound - } - - -- -- Chain sync demo -- diff --git a/cardano-diffusion/lib/Cardano/Network/NodeToClient.hs b/cardano-diffusion/lib/Cardano/Network/NodeToClient.hs index 387cac9e2af..825b4e1d4a6 100644 --- a/cardano-diffusion/lib/Cardano/Network/NodeToClient.hs +++ b/cardano-diffusion/lib/Cardano/Network/NodeToClient.hs @@ -18,6 +18,11 @@ module Cardano.Network.NodeToClient , nullNetworkConnectTracers , connectTo , connectToWithMux + -- * Mini-Protocol numbers + , localChainSyncMiniProtocolNum + , localTxSubmissionMiniProtocolNum + , localStateQueryMiniProtocolNum + , localTxMonitorMiniProtocolNum -- * Null Protocol Peers , chainSyncPeerNull , localStateQueryPeerNull @@ -42,6 +47,8 @@ module Cardano.Network.NodeToClient , nodeToClientHandshakeCodec , nodeToClientVersionCodec , nodeToClientCodecCBORTerm + -- * Limits + , maximumMiniProtocolLimits -- * Re-exports , ConnectionId (..) , MinimalInitiatorContext (..) @@ -110,6 +117,18 @@ data NodeToClientProtocols appType ntcAddr bytes m a b = NodeToClientProtocols { appType ntcAddr bytes m a b } +localChainSyncMiniProtocolNum :: MiniProtocolNum +localChainSyncMiniProtocolNum = MiniProtocolNum 5 + +localTxSubmissionMiniProtocolNum :: MiniProtocolNum +localTxSubmissionMiniProtocolNum = MiniProtocolNum 6 + +localStateQueryMiniProtocolNum :: MiniProtocolNum +localStateQueryMiniProtocolNum = MiniProtocolNum 7 + +localTxMonitorMiniProtocolNum :: MiniProtocolNum +localTxMonitorMiniProtocolNum = MiniProtocolNum 9 + -- | Make an 'OuroborosApplication' for the bundle of mini-protocols that -- make up the overall node-to-client protocol. diff --git a/cardano-diffusion/ping/Cardano/Network/Ping.hs b/cardano-diffusion/ping/Cardano/Network/Ping.hs index a52763a2b3d..5e613365917 100644 --- a/cardano-diffusion/ping/Cardano/Network/Ping.hs +++ b/cardano-diffusion/ping/Cardano/Network/Ping.hs @@ -54,11 +54,11 @@ import Cardano.Network.Diffusion.Configuration (defaultChainSyncIdleTimeout) import Cardano.Network.NodeToNode.Version import Cardano.Network.NodeToNode qualified as NodeToNode import Cardano.Network.NodeToClient.Version +import Cardano.Network.NodeToClient qualified as NodeToClient import Cardano.Network.OrphanInstances () import Cardano.Network.Protocol.ChainSync.Client (ChainSyncClient) import Cardano.Network.Protocol.ChainSync.Client qualified as ChainSync import Cardano.Network.Protocol.ChainSync.Codec qualified as ChainSync -import Cardano.Network.Protocol.Handshake.Codec (nodeToClientHandshakeCodec, nodeToNodeHandshakeCodec) import Cardano.Network.Protocol.KeepAlive.Type qualified as KeepAlive import Cardano.Network.Protocol.KeepAlive.Client (KeepAliveClient (..)) import Cardano.Network.Protocol.KeepAlive.Client qualified as KeepAlive @@ -299,8 +299,10 @@ data ProtocolFlavour version versionData where -- ChainSync Tip Sampling -- --- We don't need blocks, headers or points, so we just go away with any valid CBOR --- term: +-- We don't need blocks, headers or points, so we just go away with any valid +-- CBOR term. As a result: +-- NOTE: the `chainSync` below is used for both `NodeToNode` and `NodeToClient` +-- protocols. type ChainSyncHeader = CBOR.Term type ChainSyncPoint = CBOR.Term data ChainSyncBlock @@ -309,6 +311,8 @@ instance ShowProxy ChainSyncBlock where type ChainSyncTip = Tip ChainSyncBlock +-- A `ChainSyncClient` that finds the current `Tip` over `node-to-node` +-- or `node-to-client` protocol. chainSyncClient :: Tracer IO LogMsg -> Either FilePath (IP, Socket.PortNumber) @@ -462,8 +466,8 @@ pingClient protocol stdout opts@PingOpts{..} peer = haHandshakeTracer = nullTracer, haBearerTracer = nullTracer, haHandshakeCodec = case protocol of - NodeToNode {} -> nodeToNodeHandshakeCodec - NodeToClient {} -> nodeToClientHandshakeCodec, + NodeToNode {} -> NodeToNode.nodeToNodeHandshakeCodec + NodeToClient {} -> NodeToClient.nodeToClientHandshakeCodec, haVersionDataCodec = case protocol of NodeToNode {} -> cborTermVersionDataCodec nodeToNodeCodecCBORTerm NodeToClient {} -> cborTermVersionDataCodec nodeToClientCodecCBORTerm, @@ -516,8 +520,7 @@ pingClient protocol stdout opts@PingOpts{..} peer = -- show negotiated version logMsg $ NegotiatedVersion version case protocol of - NodeToClient {} -> pure () - NodeToNode {} | pingOptsGetTip -> do + _ | pingOptsGetTip -> do -- -- run chain sync to get the tip -- @@ -530,9 +533,13 @@ pingClient protocol stdout opts@PingOpts{..} peer = mx <- Mx.new Mx.nullTracers [MiniProtocolInfo { - miniProtocolNum = NodeToNode.chainSyncMiniProtocolNum, + miniProtocolNum = case protocol of + NodeToNode {} -> NodeToNode.chainSyncMiniProtocolNum + NodeToClient {} -> NodeToClient.localChainSyncMiniProtocolNum, miniProtocolDir = Mx.InitiatorDirectionOnly, - miniProtocolLimits = NodeToNode.chainSyncProtocolLimits NodeToNode.defaultMiniProtocolParameters, + miniProtocolLimits = case protocol of + NodeToNode {} -> NodeToNode.chainSyncProtocolLimits NodeToNode.defaultMiniProtocolParameters + NodeToClient {} -> NodeToClient.maximumMiniProtocolLimits, miniProtocolCapability = Nothing }] race_ (Mx.run mx bearer) @@ -587,6 +594,7 @@ pingClient protocol stdout opts@PingOpts{..} peer = (KeepAlive.Cookie 0)) ) `finally` Mx.stop mx + NodeToClient {} | otherwise -> pure () MT.threadDelay idleTimeout getPeerName :: IO TL.Text From 134eea777803d1103831a776e3d22d693287647a Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Wed, 1 Oct 2025 12:01:52 +0200 Subject: [PATCH 04/11] cardano-diffusion:ping - stylish-haskell --- .../ping/Cardano/Network/Ping.hs | 147 +++++++++--------- 1 file changed, 74 insertions(+), 73 deletions(-) diff --git a/cardano-diffusion/ping/Cardano/Network/Ping.hs b/cardano-diffusion/ping/Cardano/Network/Ping.hs index 5e613365917..bb0adf736ef 100644 --- a/cardano-diffusion/ping/Cardano/Network/Ping.hs +++ b/cardano-diffusion/ping/Cardano/Network/Ping.hs @@ -1,105 +1,106 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wno-orphans #-} module Cardano.Network.Ping - ( PingOpts(..) - , LogFormat(..) - , LogMsg(..) - , StatPoint(..) - , ProtocolFlavour(..) + ( PingOpts (..) + , LogFormat (..) + , LogMsg (..) + , StatPoint (..) + , ProtocolFlavour (..) , pingClients , mainnetMagic ) where -import Control.Monad (unless, when) -import Control.Concurrent.Class.MonadSTM.Strict -import Control.Monad.Class.MonadAsync -import Control.Monad.Class.MonadThrow -import Control.Monad.Class.MonadTime.SI -import Control.Tracer (Tracer (..), nullTracer, traceWith) -import Data.Aeson (Value, ToJSON(toJSON), object, encode, KeyValue((.=))) -import Data.Aeson.Text (encodeToLazyText) -import Data.ByteString (ByteString) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as BL -import qualified Data.ByteString.Lazy.Char8 as LBS.Char -import Data.IP -import qualified Data.Map.Strict as Map -import Data.Maybe (fromMaybe,) -import Data.TDigest (insert, maximumValue, minimumValue, tdigest, mean, quantile, stddev, TDigest) -import Data.Time.Format.ISO8601 (iso8601Show) -import Data.Word (Word16, Word32) -import Network.Mux (MiniProtocolInfo (..)) -import qualified Network.Mux as Mx -import Network.Mux.Bearer (MakeBearer (..), makeSocketBearer) -import Network.Socket (AddrInfo, StructLinger (..)) -import System.Random (initStdGen) -import Text.Printf (printf) +import Control.Concurrent.Class.MonadSTM.Strict +import Control.Monad (unless, when) +import Control.Monad.Class.MonadAsync +import Control.Monad.Class.MonadThrow +import Control.Monad.Class.MonadTime.SI +import Control.Monad.Class.MonadTimer.SI qualified as MT +import Control.Tracer (Tracer (..), nullTracer, traceWith) + +import Codec.CBOR.Term qualified as CBOR +import Codec.Serialise qualified as Serialise +import Data.Aeson (KeyValue ((.=)), ToJSON (toJSON), Value, encode, object) +import Data.Aeson.Text (encodeToLazyText) +import Data.ByteString (ByteString) +import Data.ByteString qualified as BS +import Data.ByteString.Lazy qualified as BL +import Data.ByteString.Lazy.Char8 qualified as LBS.Char +import Data.IP +import Data.Map.Strict qualified as Map +import Data.Maybe (fromMaybe) +import Data.TDigest (TDigest) +import Data.TDigest qualified as TDigest +import Data.Text.Lazy qualified as TL +import Data.Text.Lazy.IO qualified as TL +import Data.Time.Format.ISO8601 (iso8601Show) +import Data.Word (Word16, Word32) +import Network.Mux (MiniProtocolInfo (..)) +import Network.Mux qualified as Mx +import Network.Mux.Bearer (MakeBearer (..), makeSocketBearer) +import Network.Socket (AddrInfo, StructLinger (..)) +import Network.Socket qualified as Socket +import System.IO qualified as IO +import System.Random (initStdGen) +import Text.Printf (printf) import Cardano.Network.Diffusion.Configuration (defaultChainSyncIdleTimeout) -import Cardano.Network.NodeToNode.Version -import Cardano.Network.NodeToNode qualified as NodeToNode -import Cardano.Network.NodeToClient.Version import Cardano.Network.NodeToClient qualified as NodeToClient +import Cardano.Network.NodeToClient.Version +import Cardano.Network.NodeToNode qualified as NodeToNode +import Cardano.Network.NodeToNode.Version import Cardano.Network.OrphanInstances () import Cardano.Network.Protocol.ChainSync.Client (ChainSyncClient) import Cardano.Network.Protocol.ChainSync.Client qualified as ChainSync import Cardano.Network.Protocol.ChainSync.Codec qualified as ChainSync -import Cardano.Network.Protocol.KeepAlive.Type qualified as KeepAlive import Cardano.Network.Protocol.KeepAlive.Client (KeepAliveClient (..)) import Cardano.Network.Protocol.KeepAlive.Client qualified as KeepAlive import Cardano.Network.Protocol.KeepAlive.Codec qualified as KeepAlive +import Cardano.Network.Protocol.KeepAlive.Type qualified as KeepAlive import Ouroboros.Network.Block hiding (blockNo) import Ouroboros.Network.ConnectionId import Ouroboros.Network.Driver.Limits -import Ouroboros.Network.Protocol.Handshake hiding (Accept (..), RefuseReason (..)) import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing (..)) +import Ouroboros.Network.Protocol.Handshake hiding (Accept (..), + RefuseReason (..)) import Ouroboros.Network.Util.ShowProxy -import qualified Codec.CBOR.Term as CBOR -import qualified Codec.Serialise as Serialise -import qualified Control.Monad.Class.MonadTimer.SI as MT -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.IO as TL -import qualified Network.Socket as Socket -import qualified System.IO as IO - data LogFormat = AsJSON | AsText deriving (Eq, Show) data PingOpts = PingOpts - { pingOptsCount :: Word32 + { pingOptsCount :: Word32 -- ^ Number of messages to send to the server - , pingOptsHost :: Maybe String + , pingOptsHost :: Maybe String -- ^ The host to connect to , pingOptsHandshakeQuery :: Bool -- ^ Whether to send a query during the handshake to request the available protocol versions - , pingOptsUnixSock :: Maybe String + , pingOptsUnixSock :: Maybe String -- ^ The unix socket to connect to - , pingOptsPort :: String + , pingOptsPort :: String -- ^ The port to connect to - , pingOptsMagic :: Word32 + , pingOptsMagic :: Word32 -- ^ The network magic to use for the connection - , pingOptsJson :: LogFormat + , pingOptsJson :: LogFormat -- ^ Print output in JSON - , pingOptsQuiet :: Bool + , pingOptsQuiet :: Bool -- ^ Less verbose output - , pingOptsGetTip :: Bool + , pingOptsGetTip :: Bool -- ^ Get Tip after handshake } deriving (Eq, Show) @@ -241,19 +242,19 @@ toStatPoint ts host cookie sample td = , spMedian = quantile' 0.5 , spP90 = quantile' 0.9 , spMean = mean' - , spMin = minimumValue td - , spMax = maximumValue td + , spMin = TDigest.minimumValue td + , spMax = TDigest.maximumValue td , spStd = stddev' } where quantile' :: Double -> Double - quantile' q = fromMaybe 0 (quantile q td) + quantile' q = fromMaybe 0 (TDigest.quantile q td) mean' :: Double - mean' = fromMaybe 0 (mean td) + mean' = fromMaybe 0 (TDigest.mean td) stddev' :: Double - stddev' = fromMaybe 0 (stddev td) + stddev' = fromMaybe 0 (TDigest.stddev td) keepAliveDelay :: MT.DiffTime @@ -335,7 +336,7 @@ chainSyncClient stdout host logFormat = ChainSync.ChainSyncClient $ do end <- getMonotonicTime let (ptSlotNo, ptHash, ptBlockNo) = case tip of - TipGenesis -> (0, mempty, 0) + TipGenesis -> (0, mempty, 0) Tip slotNo hash blockNo -> (slotNo, hash, blockNo) pingTip = PingTip { ptHost = host, @@ -374,7 +375,7 @@ keepAliveClient stdout peerName logFormat td0 cookie0 = end <- getMonotonicTime now <- getCurrentTime let rtt = toSample end start - td' = insert rtt td + td' = TDigest.insert rtt td point = toStatPoint now peerName (KeepAlive.unCookie cookie) rtt td' case logFormat of AsJSON -> traceWith stdout $ LogMsg (encode point) @@ -533,7 +534,7 @@ pingClient protocol stdout opts@PingOpts{..} peer = mx <- Mx.new Mx.nullTracers [MiniProtocolInfo { - miniProtocolNum = case protocol of + miniProtocolNum = case protocol of NodeToNode {} -> NodeToNode.chainSyncMiniProtocolNum NodeToClient {} -> NodeToClient.localChainSyncMiniProtocolNum, miniProtocolDir = Mx.InitiatorDirectionOnly, @@ -562,7 +563,7 @@ pingClient protocol stdout opts@PingOpts{..} peer = ) `finally` Mx.stop mx NodeToNode {} | otherwise -> do - -- + -- -- run keepalive client to get RTT samples -- mx <- Mx.new @@ -590,7 +591,7 @@ pingClient protocol stdout opts@PingOpts{..} peer = stdout peerName pingOptsJson - (tdigest []) + (TDigest.tdigest []) (KeepAlive.Cookie 0)) ) `finally` Mx.stop mx From 199fe5690a5ad06b32fd63dc5618645113ed5a8f Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Wed, 1 Oct 2025 12:40:59 +0200 Subject: [PATCH 05/11] cardano-diffusion:ping - added changelog entry --- .../changelog.d/20251001_123658_coot_cardano_ping.md | 9 +++++++++ 1 file changed, 9 insertions(+) create mode 100644 cardano-diffusion/changelog.d/20251001_123658_coot_cardano_ping.md diff --git a/cardano-diffusion/changelog.d/20251001_123658_coot_cardano_ping.md b/cardano-diffusion/changelog.d/20251001_123658_coot_cardano_ping.md new file mode 100644 index 00000000000..0f8bb220865 --- /dev/null +++ b/cardano-diffusion/changelog.d/20251001_123658_coot_cardano_ping.md @@ -0,0 +1,9 @@ +### Breaking + +- `cardano-ping` has been deprecated and it is recommended to switch to + `cardano-diffusion:ping` library. The API has slightly changed. The logger + is instantiated by the top level `pingClients` function. It supports + connecting to multiple nodes at once. Note that `pingClient` is now an + internal, not-exported function. The new API suports querying tip over + node-to-node and node-to-client protocols. + From cce32ea6d77da0166358c3206f408f29fcd573f0 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Wed, 1 Oct 2025 13:39:19 +0200 Subject: [PATCH 06/11] api: provide nodeTo{Node,Client}VersionDataCodec We used to need to call `cborTermVersionDataCodec` to get `VersionDataCodec` from `CodecCBORTerm`. The `VersionDataCodec` and `cborTermVersionDataCodec` is moved to `ouroboros-network:api` library (`Ouroboros.network.CodecCBORTerm` module). `cardano-diffusion` provides both `nodeToNodeVersionDataCodec` and `nodeToClientVersionDataCodec`. This required a refactorisation in tests to get rid of some newtype wrappers, however the semantics of all the tests is preserved. --- .../Cardano/Network/NodeToClient/Version.hs | 5 ++ .../lib/Cardano/Network/NodeToNode/Version.hs | 4 ++ cardano-diffusion/cardano-diffusion.cabal | 1 - .../lib/Cardano/Network/NodeToClient.hs | 1 + .../lib/Cardano/Network/NodeToNode.hs | 3 +- .../Network/Protocol/Handshake/Test.hs | 55 +++++++------------ .../lib/Ouroboros/Network/CodecCBORTerm.hs | 24 +++++++- .../Ouroboros/Network/Protocol/Handshake.hs | 2 +- .../Network/Protocol/Handshake/Client.hs | 12 ++-- .../Network/Protocol/Handshake/Codec.hs | 25 --------- .../Network/Protocol/Handshake/Server.hs | 2 +- .../Network/Protocol/Handshake/Unversioned.hs | 4 +- .../framework/lib/Ouroboros/Network/Socket.hs | 2 +- .../Network/Protocol/Handshake/Test.hs | 29 ++++------ .../tests/io/Test/Ouroboros/Network/Socket.hs | 3 +- .../Test/Ouroboros/Network/Diffusion/Node.hs | 2 +- 16 files changed, 79 insertions(+), 95 deletions(-) diff --git a/cardano-diffusion/api/lib/Cardano/Network/NodeToClient/Version.hs b/cardano-diffusion/api/lib/Cardano/Network/NodeToClient/Version.hs index bbbb88d5801..ea4519db514 100644 --- a/cardano-diffusion/api/lib/Cardano/Network/NodeToClient/Version.hs +++ b/cardano-diffusion/api/lib/Cardano/Network/NodeToClient/Version.hs @@ -8,6 +8,7 @@ module Cardano.Network.NodeToClient.Version , NodeToClientVersionData (..) , nodeToClientCodecCBORTerm , nodeToClientVersionCodec + , nodeToClientVersionDataCodec , NetworkMagic (..) ) where @@ -146,3 +147,7 @@ nodeToClientCodecCBORTerm _v = CodecCBORTerm {encodeTerm, decodeTerm} decoder :: Int -> Bool -> Either Text NodeToClientVersionData decoder x query | x >= 0 && x <= 0xffffffff = Right (NodeToClientVersionData (NetworkMagic $ fromIntegral x) query) | otherwise = Left $ T.pack $ "networkMagic out of bound: " <> show x + + +nodeToClientVersionDataCodec :: VersionDataCodec NodeToClientVersion NodeToClientVersionData +nodeToClientVersionDataCodec = cborTermVersionDataCodec nodeToClientCodecCBORTerm diff --git a/cardano-diffusion/api/lib/Cardano/Network/NodeToNode/Version.hs b/cardano-diffusion/api/lib/Cardano/Network/NodeToNode/Version.hs index 1bc515e0688..21582c10f1f 100644 --- a/cardano-diffusion/api/lib/Cardano/Network/NodeToNode/Version.hs +++ b/cardano-diffusion/api/lib/Cardano/Network/NodeToNode/Version.hs @@ -10,6 +10,7 @@ module Cardano.Network.NodeToNode.Version , ConnectionMode (..) , nodeToNodeVersionCodec , nodeToNodeCodecCBORTerm + , nodeToNodeVersionDataCodec , NetworkMagic (..) ) where @@ -170,4 +171,7 @@ nodeToNodeCodecCBORTerm = = Left $ T.pack $ "unknown encoding: " ++ show t +nodeToNodeVersionDataCodec :: VersionDataCodec NodeToNodeVersion NodeToNodeVersionData +nodeToNodeVersionDataCodec = cborTermVersionDataCodec nodeToNodeCodecCBORTerm + data ConnectionMode = UnidirectionalMode | DuplexMode diff --git a/cardano-diffusion/cardano-diffusion.cabal b/cardano-diffusion/cardano-diffusion.cabal index 3b67c229eea..dd79da56f36 100644 --- a/cardano-diffusion/cardano-diffusion.cabal +++ b/cardano-diffusion/cardano-diffusion.cabal @@ -342,7 +342,6 @@ library protocols-tests-lib ouroboros-network:{api, framework, protocols-tests-lib}, tasty, tasty-quickcheck, - text, typed-protocols, test-suite protocols-tests diff --git a/cardano-diffusion/lib/Cardano/Network/NodeToClient.hs b/cardano-diffusion/lib/Cardano/Network/NodeToClient.hs index 825b4e1d4a6..dd1987cc30b 100644 --- a/cardano-diffusion/lib/Cardano/Network/NodeToClient.hs +++ b/cardano-diffusion/lib/Cardano/Network/NodeToClient.hs @@ -47,6 +47,7 @@ module Cardano.Network.NodeToClient , nodeToClientHandshakeCodec , nodeToClientVersionCodec , nodeToClientCodecCBORTerm + , nodeToClientVersionDataCodec -- * Limits , maximumMiniProtocolLimits -- * Re-exports diff --git a/cardano-diffusion/lib/Cardano/Network/NodeToNode.hs b/cardano-diffusion/lib/Cardano/Network/NodeToNode.hs index e25f712f305..47ee63fcf9d 100644 --- a/cardano-diffusion/lib/Cardano/Network/NodeToNode.hs +++ b/cardano-diffusion/lib/Cardano/Network/NodeToNode.hs @@ -44,6 +44,7 @@ module Cardano.Network.NodeToNode , nodeToNodeHandshakeCodec , nodeToNodeVersionCodec , nodeToNodeCodecCBORTerm + , nodeToNodeVersionDataCodec -- * Re-exports , ExpandedInitiatorContext (..) , MinimalInitiatorContext (..) @@ -406,7 +407,7 @@ connectTo sn tr = ConnectToArgs { ctaHandshakeCodec = nodeToNodeHandshakeCodec, ctaHandshakeTimeLimits = timeLimitsHandshake, - ctaVersionDataCodec = cborTermVersionDataCodec nodeToNodeCodecCBORTerm, + ctaVersionDataCodec = nodeToNodeVersionDataCodec, ctaConnectTracers = tr, ctaHandshakeCallbacks = HandshakeCallbacks acceptableVersion queryVersion } diff --git a/cardano-diffusion/protocols/tests-lib/Cardano/Network/Protocol/Handshake/Test.hs b/cardano-diffusion/protocols/tests-lib/Cardano/Network/Protocol/Handshake/Test.hs index 32a8dafe250..8e81b45f057 100644 --- a/cardano-diffusion/protocols/tests-lib/Cardano/Network/Protocol/Handshake/Test.hs +++ b/cardano-diffusion/protocols/tests-lib/Cardano/Network/Protocol/Handshake/Test.hs @@ -15,7 +15,6 @@ module Cardano.Network.Protocol.Handshake.Test where import Data.ByteString.Lazy (ByteString) import Data.Map qualified as Map -import Data.Text (Text) import Codec.CBOR.Read qualified as CBOR import Codec.CBOR.Term qualified as CBOR @@ -110,7 +109,6 @@ newtype ArbitraryNodeToNodeVersionData = ArbitraryNodeToNodeVersionData { getNodeToNodeVersionData :: NodeToNodeVersionData } deriving Show - deriving Acceptable via NodeToNodeVersionData -- | With the introduction of PeerSharing to 'NodeToNodeVersionData' this type's -- 'Acceptable' instance is no longer symmetric. Because when handshake is @@ -124,9 +122,6 @@ instance Eq ArbitraryNodeToNodeVersionData where (ArbitraryNodeToNodeVersionData (NodeToNodeVersionData nm' dm' ps' _)) = nm == nm' && dm == dm' && ps == ps' -instance Queryable ArbitraryNodeToNodeVersionData where - queryVersion = queryVersion . getNodeToNodeVersionData - instance Arbitrary ArbitraryNodeToNodeVersionData where arbitrary = fmap (fmap (fmap ArbitraryNodeToNodeVersionData)) . NodeToNodeVersionData @@ -165,7 +160,7 @@ instance Arbitrary ArbitraryNodeToNodeVersionData where newtype ArbitraryNodeToNodeVersions = ArbitraryNodeToNodeVersions { getArbitraryNodeToNodeVersiosn :: Versions NodeToNodeVersion - ArbitraryNodeToNodeVersionData Bool } + NodeToNodeVersionData Bool } instance Show ArbitraryNodeToNodeVersions where show (ArbitraryNodeToNodeVersions (Versions vs)) @@ -174,7 +169,7 @@ instance Show ArbitraryNodeToNodeVersions where instance Arbitrary ArbitraryNodeToNodeVersions where arbitrary = do vs <- listOf (getNodeToNodeVersion <$> arbitrary) - ds <- vectorOf (length vs) arbitrary + ds <- map getNodeToNodeVersionData <$> vectorOf (length vs) arbitrary r <- arbitrary return $ ArbitraryNodeToNodeVersions $ Versions @@ -244,7 +239,7 @@ prop_acceptable_symmetric_NodeToNode :: ArbitraryNodeToNodeVersionData -> ArbitraryNodeToNodeVersionData -> Bool -prop_acceptable_symmetric_NodeToNode a b = +prop_acceptable_symmetric_NodeToNode (ArbitraryNodeToNodeVersionData a) (ArbitraryNodeToNodeVersionData b) = prop_acceptable_symmetric a b @@ -268,11 +263,10 @@ prop_query_version_NodeToNode_ST runSimOrThrow $ prop_query_version createConnectedChannels (codecHandshake nodeToNodeVersionCodec) - (cborTermVersionDataCodec (fmap transformNodeToNodeVersionData nodeToNodeCodecCBORTerm)) + nodeToNodeVersionDataCodec clientVersions serverVersions - (\(ArbitraryNodeToNodeVersionData vd) -> - ArbitraryNodeToNodeVersionData $ + (\vd -> vd { NTN.query = True , NTN.peerSharing = PeerSharingEnabled }) @@ -288,11 +282,10 @@ prop_query_version_NodeToNode_IO ioProperty $ prop_query_version createConnectedChannels (codecHandshake nodeToNodeVersionCodec) - (cborTermVersionDataCodec (fmap transformNodeToNodeVersionData nodeToNodeCodecCBORTerm)) + nodeToNodeVersionDataCodec clientVersions serverVersions - (\(ArbitraryNodeToNodeVersionData vd) -> - ArbitraryNodeToNodeVersionData $ + (\vd -> vd { NTN.query = True , NTN.peerSharing = PeerSharingEnabled }) @@ -308,11 +301,10 @@ prop_query_version_NodeToNode_SimNet runSimOrThrow $ prop_query_version createConnectedChannels (codecHandshake nodeToNodeVersionCodec) - (cborTermVersionDataCodec (fmap transformNodeToNodeVersionData nodeToNodeCodecCBORTerm)) + nodeToNodeVersionDataCodec clientVersions serverVersions - (\(ArbitraryNodeToNodeVersionData vd) -> - ArbitraryNodeToNodeVersionData $ + (\vd -> vd { NTN.query = True , NTN.peerSharing = PeerSharingEnabled }) @@ -375,9 +367,9 @@ prop_peerSharing_symmetric :: => m (Channel m ByteString, Channel m ByteString) -> Codec (Handshake NodeToNodeVersion CBOR.Term) CBOR.DeserialiseFailure m ByteString - -> VersionDataCodec CBOR.Term NodeToNodeVersion ArbitraryNodeToNodeVersionData - -> Versions NodeToNodeVersion ArbitraryNodeToNodeVersionData Bool - -> Versions NodeToNodeVersion ArbitraryNodeToNodeVersionData Bool + -> VersionDataCodec NodeToNodeVersion NodeToNodeVersionData + -> Versions NodeToNodeVersion NodeToNodeVersionData Bool + -> Versions NodeToNodeVersion NodeToNodeVersionData Bool -> m Property prop_peerSharing_symmetric createChannels codec versionDataCodec clientVersions serverVersions = do (clientRes, serverRes) <- @@ -395,8 +387,8 @@ prop_peerSharing_symmetric createChannels codec versionDataCodec clientVersions pure $ case (clientRes, serverRes) of -- TODO: make this return ArbitraryNodeToNodeVersionData rather than a pair -- of NodeToNodeVersionData - ( Right (HandshakeNegotiationResult _ v (ArbitraryNodeToNodeVersionData clientResult)) - , Right (HandshakeNegotiationResult _ v' (ArbitraryNodeToNodeVersionData serverResult)) + ( Right (HandshakeNegotiationResult _ v clientResult) + , Right (HandshakeNegotiationResult _ v' serverResult) ) | v == v' , v >= NodeToNodeV_14 -> counterexample @@ -421,7 +413,7 @@ prop_peerSharing_symmetric_NodeToNode_SimNet runSimOrThrow $ prop_peerSharing_symmetric createConnectedChannels (codecHandshake nodeToNodeVersionCodec) - (cborTermVersionDataCodec (fmap transformNodeToNodeVersionData nodeToNodeCodecCBORTerm)) + nodeToNodeVersionDataCodec clientVersions serverVersions @@ -433,7 +425,7 @@ prop_acceptOrRefuse_symmetric_NodeToNode prop_acceptOrRefuse_symmetric_NodeToNode (ArbitraryNodeToNodeVersions a) (ArbitraryNodeToNodeVersions b) = - prop_acceptOrRefuse_symmetric a b + prop_acceptOrRefuse_symmetric nodeToNodeVersionDataCodec a b prop_acceptOrRefuse_symmetric_NodeToClient @@ -443,7 +435,7 @@ prop_acceptOrRefuse_symmetric_NodeToClient prop_acceptOrRefuse_symmetric_NodeToClient (ArbitraryNodeToClientVersions a) (ArbitraryNodeToClientVersions b) = - prop_acceptOrRefuse_symmetric a b + prop_acceptOrRefuse_symmetric nodeToClientVersionDataCodec a b prop_channel_simultaneous_open_NodeToNode_ST :: ArbitraryNodeToNodeVersions @@ -455,17 +447,10 @@ prop_channel_simultaneous_open_NodeToNode_ST runSimOrThrow $ prop_channel_simultaneous_open createConnectedChannels (codecHandshake nodeToNodeVersionCodec) - (cborTermVersionDataCodec (fmap transformNodeToNodeVersionData nodeToNodeCodecCBORTerm)) + nodeToNodeVersionDataCodec clientVersions serverVersions -transformNodeToNodeVersionData :: CodecCBORTerm Text NodeToNodeVersionData - -> CodecCBORTerm Text ArbitraryNodeToNodeVersionData -transformNodeToNodeVersionData (CodecCBORTerm g h) = - CodecCBORTerm { encodeTerm = \(ArbitraryNodeToNodeVersionData a) -> g a - , decodeTerm = fmap (fmap ArbitraryNodeToNodeVersionData) h - } - prop_channel_simultaneous_open_NodeToNode_IO :: ArbitraryNodeToNodeVersions -> ArbitraryNodeToNodeVersions @@ -476,7 +461,7 @@ prop_channel_simultaneous_open_NodeToNode_IO ioProperty $ prop_channel_simultaneous_open createConnectedChannels (codecHandshake nodeToNodeVersionCodec) - (cborTermVersionDataCodec (fmap transformNodeToNodeVersionData nodeToNodeCodecCBORTerm)) + nodeToNodeVersionDataCodec clientVersions serverVersions @@ -517,7 +502,7 @@ prop_channel_simultaneous_open_NodeToNode_SimNet (ArbitraryNodeToNodeVersions serverVersions) = runSimOrThrow $ prop_channel_simultaneous_open_sim (codecHandshake nodeToNodeVersionCodec) - (cborTermVersionDataCodec (fmap transformNodeToNodeVersionData nodeToNodeCodecCBORTerm)) + nodeToNodeVersionDataCodec clientVersions serverVersions diff --git a/ouroboros-network/api/lib/Ouroboros/Network/CodecCBORTerm.hs b/ouroboros-network/api/lib/Ouroboros/Network/CodecCBORTerm.hs index d9f92ee9bf8..a7d981ae249 100644 --- a/ouroboros-network/api/lib/Ouroboros/Network/CodecCBORTerm.hs +++ b/ouroboros-network/api/lib/Ouroboros/Network/CodecCBORTerm.hs @@ -1,6 +1,11 @@ -module Ouroboros.Network.CodecCBORTerm where +module Ouroboros.Network.CodecCBORTerm + ( CodecCBORTerm (..) + , VersionDataCodec (..) + , cborTermVersionDataCodec + ) where import Codec.CBOR.Term qualified as CBOR +import Data.Text (Text) -- | A pure codec which encodes to / decodes from 'CBOR.Term'. This is useful @@ -11,3 +16,20 @@ data CodecCBORTerm fail a = CodecCBORTerm { encodeTerm :: a -> CBOR.Term , decodeTerm :: CBOR.Term -> Either fail a } + +-- | Codec for version data exchanged by the handshake protocol. +-- +data VersionDataCodec vNumber vData = VersionDataCodec { + encodeData :: vNumber -> vData -> CBOR.Term, + -- ^ encoder of 'vData' which has access to 'extra vData' which can bring + -- extra instances into the scope (by means of pattern matching on a GADT). + decodeData :: vNumber -> CBOR.Term -> Either Text vData + -- ^ decoder of 'vData'. + } + +cborTermVersionDataCodec :: (vNumber -> CodecCBORTerm Text vData) + -> VersionDataCodec vNumber vData +cborTermVersionDataCodec codec = VersionDataCodec { + encodeData = encodeTerm . codec, + decodeData = decodeTerm . codec + } diff --git a/ouroboros-network/framework/lib/Ouroboros/Network/Protocol/Handshake.hs b/ouroboros-network/framework/lib/Ouroboros/Network/Protocol/Handshake.hs index e20d94ed19e..521c6574ed7 100644 --- a/ouroboros-network/framework/lib/Ouroboros/Network/Protocol/Handshake.hs +++ b/ouroboros-network/framework/lib/Ouroboros/Network/Protocol/Handshake.hs @@ -114,7 +114,7 @@ data HandshakeArguments connectionId vNumber vData m = HandshakeArguments { -- | A codec for protocol parameters. -- haVersionDataCodec - :: VersionDataCodec CBOR.Term vNumber vData, + :: VersionDataCodec vNumber vData, -- | accept version, first argument is our version data the second -- argument is the remote version data. diff --git a/ouroboros-network/framework/lib/Ouroboros/Network/Protocol/Handshake/Client.hs b/ouroboros-network/framework/lib/Ouroboros/Network/Protocol/Handshake/Client.hs index 1d16832a1be..663cf54d209 100644 --- a/ouroboros-network/framework/lib/Ouroboros/Network/Protocol/Handshake/Client.hs +++ b/ouroboros-network/framework/lib/Ouroboros/Network/Protocol/Handshake/Client.hs @@ -33,7 +33,7 @@ handshakeClientPeer :: ( Monad m , Ord vNumber ) - => VersionDataCodec CBOR.Term vNumber vData + => VersionDataCodec vNumber vData -> (vData -> vData -> Accept vData) -> Versions vNumber vData r -> Client (Handshake vNumber CBOR.Term) @@ -55,7 +55,7 @@ handshakeClientPeerWithRTT :: ( Ord vNumber , MonadMonotonicTime m ) - => VersionDataCodec CBOR.Term vNumber vData + => VersionDataCodec vNumber vData -> (vData -> vData -> Accept vData) -> Versions vNumber vData r -> Client (Handshake vNumber CBOR.Term) @@ -95,7 +95,7 @@ handshakeClientPeer' , Monad m ) => TimeAPI time diffTime m - -> VersionDataCodec CBOR.Term vNumber vData + -> VersionDataCodec vNumber vData -> (vData -> vData -> Accept vData) -> Versions vNumber vData r -> Client (Handshake vNumber CBOR.Term) @@ -189,12 +189,12 @@ encodeVersions encoder (Versions vs) = go `Map.mapWithKey` vs acceptOrRefuse - :: forall vParams vNumber vData r. + :: forall vNumber vData r. Ord vNumber - => VersionDataCodec vParams vNumber vData + => VersionDataCodec vNumber vData -> (vData -> vData -> Accept vData) -> Versions vNumber vData r - -> Map vNumber vParams + -> Map vNumber CBOR.Term -- ^ proposed versions received either with `MsgProposeVersions` or -- `MsgReplyVersions` -> Either (RefuseReason vNumber) (r, vNumber, vData) diff --git a/ouroboros-network/framework/lib/Ouroboros/Network/Protocol/Handshake/Codec.hs b/ouroboros-network/framework/lib/Ouroboros/Network/Protocol/Handshake/Codec.hs index fda789bc361..68dd5b53df5 100644 --- a/ouroboros-network/framework/lib/Ouroboros/Network/Protocol/Handshake/Codec.hs +++ b/ouroboros-network/framework/lib/Ouroboros/Network/Protocol/Handshake/Codec.hs @@ -27,7 +27,6 @@ import Data.Either (partitionEithers) import Data.Map (Map) import Data.Map qualified as Map import Data.Maybe (mapMaybe) -import Data.Text (Text) import Text.Printf import Network.TypedProtocol.Codec.CBOR @@ -44,30 +43,6 @@ import Ouroboros.Network.Driver.Limits import Ouroboros.Network.Protocol.Handshake.Type import Ouroboros.Network.Protocol.Limits --- | Codec for version data ('vData' in code) exchanged by the handshake --- protocol. --- --- Note: 'extra' type param is instantiated to 'DictVersion'; 'agreedOptions' --- is instantiated to 'NodeToNodeVersionData' in "Ouroboros.Network.NodeToNode" --- or to '()' in "Ouroboros.Network.NodeToClient". --- -data VersionDataCodec bytes vNumber vData = VersionDataCodec { - encodeData :: vNumber -> vData -> bytes, - -- ^ encoder of 'vData' which has access to 'extra vData' which can bring - -- extra instances into the scope (by means of pattern matching on a GADT). - decodeData :: vNumber -> bytes -> Either Text vData - -- ^ decoder of 'vData'. - } - --- TODO: remove this from top level API, this is the only way we encode or --- decode version data. -cborTermVersionDataCodec :: (vNumber -> CodecCBORTerm Text vData) - -> VersionDataCodec CBOR.Term vNumber vData -cborTermVersionDataCodec codec = VersionDataCodec { - encodeData = encodeTerm . codec, - decodeData = decodeTerm . codec - } - -- | -- We assume that a TCP segment size of 1440 bytes with initial window of size -- 4. This sets upper limit of 5760 bytes on each message of handshake diff --git a/ouroboros-network/framework/lib/Ouroboros/Network/Protocol/Handshake/Server.hs b/ouroboros-network/framework/lib/Ouroboros/Network/Protocol/Handshake/Server.hs index f087d83fd75..972e95b3b18 100644 --- a/ouroboros-network/framework/lib/Ouroboros/Network/Protocol/Handshake/Server.hs +++ b/ouroboros-network/framework/lib/Ouroboros/Network/Protocol/Handshake/Server.hs @@ -23,7 +23,7 @@ import Ouroboros.Network.Protocol.Handshake.Version handshakeServerPeer :: ( Ord vNumber ) - => VersionDataCodec CBOR.Term vNumber vData + => VersionDataCodec vNumber vData -> (vData -> vData -> Accept vData) -> (vData -> Bool) -> Versions vNumber vData r diff --git a/ouroboros-network/framework/lib/Ouroboros/Network/Protocol/Handshake/Unversioned.hs b/ouroboros-network/framework/lib/Ouroboros/Network/Protocol/Handshake/Unversioned.hs index 8edacc48d91..5c60d79a613 100644 --- a/ouroboros-network/framework/lib/Ouroboros/Network/Protocol/Handshake/Unversioned.hs +++ b/ouroboros-network/framework/lib/Ouroboros/Network/Protocol/Handshake/Unversioned.hs @@ -51,8 +51,8 @@ instance Queryable UnversionedProtocolData where queryVersion UnversionedProtocolData = False -unversionedProtocolDataCodec :: VersionDataCodec CBOR.Term UnversionedProtocol - UnversionedProtocolData +unversionedProtocolDataCodec :: VersionDataCodec UnversionedProtocol + UnversionedProtocolData unversionedProtocolDataCodec = cborTermVersionDataCodec (const CodecCBORTerm {encodeTerm, decodeTerm}) where diff --git a/ouroboros-network/framework/lib/Ouroboros/Network/Socket.hs b/ouroboros-network/framework/lib/Ouroboros/Network/Socket.hs index 94cfa9f18be..6e32cce3db7 100644 --- a/ouroboros-network/framework/lib/Ouroboros/Network/Socket.hs +++ b/ouroboros-network/framework/lib/Ouroboros/Network/Socket.hs @@ -228,7 +228,7 @@ sduHandshakeTimeout = 10 data ConnectToArgs fd addr vNumber vData = ConnectToArgs { ctaHandshakeCodec :: Codec (Handshake vNumber CBOR.Term) CBOR.DeserialiseFailure IO BL.ByteString, ctaHandshakeTimeLimits :: ProtocolTimeLimits (Handshake vNumber CBOR.Term), - ctaVersionDataCodec :: VersionDataCodec CBOR.Term vNumber vData, + ctaVersionDataCodec :: VersionDataCodec vNumber vData, ctaConnectTracers :: NetworkConnectTracers addr vNumber, ctaHandshakeCallbacks :: HandshakeCallbacks vData } diff --git a/ouroboros-network/protocols/tests-lib/Ouroboros/Network/Protocol/Handshake/Test.hs b/ouroboros-network/protocols/tests-lib/Ouroboros/Network/Protocol/Handshake/Test.hs index 96afd91836d..0c19a9f4462 100644 --- a/ouroboros-network/protocols/tests-lib/Ouroboros/Network/Protocol/Handshake/Test.hs +++ b/ouroboros-network/protocols/tests-lib/Ouroboros/Network/Protocol/Handshake/Test.hs @@ -621,7 +621,7 @@ prop_query_version :: ( MonadAsync m => m (Channel m ByteString, Channel m ByteString) -> Codec (Handshake vNumber CBOR.Term) CBOR.DeserialiseFailure m ByteString - -> VersionDataCodec CBOR.Term vNumber vData + -> VersionDataCodec vNumber vData -> Versions vNumber vData Bool -> Versions vNumber vData Bool -> (vData -> vData) @@ -675,10 +675,11 @@ prop_acceptOrRefuse_symmetric , Ord vNumber , Show vNumber ) - => Versions vNumber vData r + => VersionDataCodec vNumber vData + -> Versions vNumber vData r -> Versions vNumber vData r -> Property -prop_acceptOrRefuse_symmetric clientVersions serverVersions = +prop_acceptOrRefuse_symmetric codec clientVersions serverVersions = case ( acceptOrRefuse codec acceptableVersion clientVersions serverMap , acceptOrRefuse codec acceptableVersion serverVersions clientMap ) of @@ -698,25 +699,17 @@ prop_acceptOrRefuse_symmetric clientVersions serverVersions = property False where - codec :: VersionDataCodec vData vNumber vData - codec = VersionDataCodec { - encodeData = \_ vData -> vData, - decodeData = \_ vData -> Right vData - } - - toMap :: Versions vNumber vData r - -> Map vNumber vData - toMap (Versions m) = versionData `Map.map` m - - clientMap = toMap clientVersions - serverMap = toMap serverVersions + clientMap, serverMap :: Map vNumber CBOR.Term + clientMap = Map.mapWithKey (\v -> encodeData codec v . versionData) $ getVersions clientVersions + serverMap = Map.mapWithKey (\v -> encodeData codec v . versionData) $ getVersions serverVersions prop_acceptOrRefuse_symmetric_VersionData :: ArbitraryVersions -> Property prop_acceptOrRefuse_symmetric_VersionData (ArbitraryVersions a b) = - prop_acceptOrRefuse_symmetric a b + prop_acceptOrRefuse_symmetric (cborTermVersionDataCodec dataCodecCBORTerm) + a b -- | Run two handshake clients against each other, which simulates a TCP @@ -731,7 +724,7 @@ prop_channel_simultaneous_open => m (Channel m ByteString, Channel m ByteString) -> Codec (Handshake vNumber CBOR.Term) CBOR.DeserialiseFailure m ByteString - -> VersionDataCodec CBOR.Term vNumber vData + -> VersionDataCodec vNumber vData -> Versions vNumber vData Bool -> Versions vNumber vData Bool -> m Property @@ -817,7 +810,7 @@ prop_channel_simultaneous_open_sim ) => Codec (Handshake vNumber CBOR.Term) CBOR.DeserialiseFailure m ByteString - -> VersionDataCodec CBOR.Term vNumber vData + -> VersionDataCodec vNumber vData -> Versions vNumber vData Bool -> Versions vNumber vData Bool -> m Property diff --git a/ouroboros-network/tests/io/Test/Ouroboros/Network/Socket.hs b/ouroboros-network/tests/io/Test/Ouroboros/Network/Socket.hs index 122bccb4883..3deeed1ae18 100644 --- a/ouroboros-network/tests/io/Test/Ouroboros/Network/Socket.hs +++ b/ouroboros-network/tests/io/Test/Ouroboros/Network/Socket.hs @@ -45,8 +45,7 @@ import Ouroboros.Network.Protocol.ChainSync.Codec qualified as ChainSync import Ouroboros.Network.Protocol.ChainSync.Examples qualified as ChainSync import Ouroboros.Network.Protocol.ChainSync.Server qualified as ChainSync import Ouroboros.Network.Protocol.Handshake (HandshakeArguments (..)) -import Ouroboros.Network.Protocol.Handshake.Codec (cborTermVersionDataCodec, - noTimeLimitsHandshake) +import Ouroboros.Network.Protocol.Handshake.Codec (noTimeLimitsHandshake) import Ouroboros.Network.Protocol.Handshake.Version (simpleSingletonVersions) import Ouroboros.Network.Server.Simple qualified as Server.Simple import Ouroboros.Network.Util.ShowProxy diff --git a/ouroboros-network/tests/lib/Test/Ouroboros/Network/Diffusion/Node.hs b/ouroboros-network/tests/lib/Test/Ouroboros/Network/Diffusion/Node.hs index a8f7ad26fc7..26254f3654f 100644 --- a/ouroboros-network/tests/lib/Test/Ouroboros/Network/Diffusion/Node.hs +++ b/ouroboros-network/tests/lib/Test/Ouroboros/Network/Diffusion/Node.hs @@ -445,7 +445,7 @@ run blockGeneratorArgs ni na -- various pseudo random generators (diffStgGen, keepAliveStdGen) = split (iRng ni) - ntnUnversionedDataCodec :: VersionDataCodec CBOR.Term NtNVersion NtNVersionData + ntnUnversionedDataCodec :: VersionDataCodec NtNVersion NtNVersionData ntnUnversionedDataCodec = VersionDataCodec { encodeData, decodeData } where encodeData _ NtNVersionData { ntnDiffusionMode, ntnPeerSharing } = From cad41b2aec9f035a7444696a116fa115d1f1f358 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Wed, 1 Oct 2025 21:45:26 +0200 Subject: [PATCH 07/11] handshake: fixed prop_acceptOrRefuse_symmetric failure The tests started to fail due to usage of version data codec which doesn't satisfy round robin property on invalid version data in the previous commit. --- .../Network/Protocol/Handshake/Test.hs | 24 ++++++++++++------- 1 file changed, 15 insertions(+), 9 deletions(-) diff --git a/ouroboros-network/protocols/tests-lib/Ouroboros/Network/Protocol/Handshake/Test.hs b/ouroboros-network/protocols/tests-lib/Ouroboros/Network/Protocol/Handshake/Test.hs index 0c19a9f4462..3f09eed328a 100644 --- a/ouroboros-network/protocols/tests-lib/Ouroboros/Network/Protocol/Handshake/Test.hs +++ b/ouroboros-network/protocols/tests-lib/Ouroboros/Network/Protocol/Handshake/Test.hs @@ -320,8 +320,8 @@ prop_shrink_ArbitraryValidVersions a = all id | ArbitraryValidVersions vs' <- shrink a ] --- | --- Generators for pairs of arbitrary list of versions. + +-- | Generators for pairs of arbitrary list of versions. -- data ArbitraryVersions = ArbitraryVersions @@ -345,9 +345,7 @@ instance Arbitrary ArbitraryVersions where | vs'' <- shrinkList (const []) (Map.toList vs') ] - --- | --- Check if a @'ProtocolVersion' 'VersionNumber' r@ is valid. +-- | Check if a @'ProtocolVersion' 'VersionNumber' r@ is valid. -- validVersion :: VersionNumber -> Version VersionData Bool -> Bool validVersion Version_0 ((Version _ d)) = dataVersion1 d == False @@ -667,6 +665,11 @@ prop_query_version createChannels codec versionDataCodec clientVersions serverVe -- The refuse reason might differ, although if one side refuses it with -- `Refused` the other side must refuse the same version. -- +-- NOTE: this test should be run with only valid versions, otherwise it might +-- fail, e.g. if `Version_0` with `VersionData 0 True True` is passed, then +-- `clientVersions` will be `VersionData 0 False False`, which inevitably leads +-- to a failure. +-- prop_acceptOrRefuse_symmetric :: forall vNumber vData r. ( Acceptable vData @@ -684,8 +687,10 @@ prop_acceptOrRefuse_symmetric codec clientVersions serverVersions = , acceptOrRefuse codec acceptableVersion serverVersions clientMap ) of (Right (_, vNumber, vData), Right (_, vNumber', vData')) -> - vNumber === vNumber' - .&&. vData === vData' + (counterexample "negotiated version numbers mismatch:" $ + vNumber === vNumber') + .&&. (counterexample "negotiated version data mismatch:" $ + vData === vData') (Left (VersionMismatch vNumbers _), Left (VersionMismatch vNumbers' _)) -> vNumbers === Map.keys clientMap .&&. vNumbers' === Map.keys serverMap @@ -705,9 +710,10 @@ prop_acceptOrRefuse_symmetric codec clientVersions serverVersions = prop_acceptOrRefuse_symmetric_VersionData - :: ArbitraryVersions + :: ArbitraryValidVersions + -> ArbitraryValidVersions -> Property -prop_acceptOrRefuse_symmetric_VersionData (ArbitraryVersions a b) = +prop_acceptOrRefuse_symmetric_VersionData (ArbitraryValidVersions a) (ArbitraryValidVersions b) = prop_acceptOrRefuse_symmetric (cborTermVersionDataCodec dataCodecCBORTerm) a b From 5aa3478779d7d96e0af6d21bc3fd54d0f69c4829 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Wed, 1 Oct 2025 14:37:47 +0200 Subject: [PATCH 08/11] api: hide nodeTo{Node,Client}CodecCBORTerm Exposed `nodeTo{Node,Client}VersionDataCodec` instead. --- .../Cardano/Network/NodeToClient/Version.hs | 1 - .../lib/Cardano/Network/NodeToNode/Version.hs | 1 - .../Cardano/Network/NodeToClient/Version.hs | 4 +-- .../Cardano/Network/NodeToNode/Version.hs | 4 +-- .../lib/Cardano/Network/Diffusion.hs | 8 ++---- .../lib/Cardano/Network/NodeToClient.hs | 5 ++-- .../lib/Cardano/Network/NodeToNode.hs | 1 - .../ping/Cardano/Network/Ping.hs | 4 +-- cardano-diffusion/protocols/cddl/Main.hs | 28 +++++++++++-------- .../Network/Protocol/Handshake/Test.hs | 12 ++++---- 10 files changed, 33 insertions(+), 35 deletions(-) diff --git a/cardano-diffusion/api/lib/Cardano/Network/NodeToClient/Version.hs b/cardano-diffusion/api/lib/Cardano/Network/NodeToClient/Version.hs index ea4519db514..d5aac3d12b5 100644 --- a/cardano-diffusion/api/lib/Cardano/Network/NodeToClient/Version.hs +++ b/cardano-diffusion/api/lib/Cardano/Network/NodeToClient/Version.hs @@ -6,7 +6,6 @@ module Cardano.Network.NodeToClient.Version ( NodeToClientVersion (..) , NodeToClientVersionData (..) - , nodeToClientCodecCBORTerm , nodeToClientVersionCodec , nodeToClientVersionDataCodec , NetworkMagic (..) diff --git a/cardano-diffusion/api/lib/Cardano/Network/NodeToNode/Version.hs b/cardano-diffusion/api/lib/Cardano/Network/NodeToNode/Version.hs index 21582c10f1f..bb41530b4de 100644 --- a/cardano-diffusion/api/lib/Cardano/Network/NodeToNode/Version.hs +++ b/cardano-diffusion/api/lib/Cardano/Network/NodeToNode/Version.hs @@ -9,7 +9,6 @@ module Cardano.Network.NodeToNode.Version , DiffusionMode (..) , ConnectionMode (..) , nodeToNodeVersionCodec - , nodeToNodeCodecCBORTerm , nodeToNodeVersionDataCodec , NetworkMagic (..) ) where diff --git a/cardano-diffusion/api/tests/Test/Cardano/Network/NodeToClient/Version.hs b/cardano-diffusion/api/tests/Test/Cardano/Network/NodeToClient/Version.hs index 2354ff57ae0..ee5b3c22d50 100644 --- a/cardano-diffusion/api/tests/Test/Cardano/Network/NodeToClient/Version.hs +++ b/cardano-diffusion/api/tests/Test/Cardano/Network/NodeToClient/Version.hs @@ -44,8 +44,8 @@ prop_nodeToClientVersionCodec version = prop_nodeToClientCodec :: VersionAndVersionData -> Bool prop_nodeToClientCodec (VersionAndVersionData vNumber vData) = - case decodeTerm (encodeTerm vData) of + case decodeData vNumber (encodeData vNumber vData) of Right vData' -> networkMagic vData' == networkMagic vData Left {} -> False where - CodecCBORTerm { encodeTerm, decodeTerm } = nodeToClientCodecCBORTerm vNumber + VersionDataCodec { encodeData, decodeData } = nodeToClientVersionDataCodec diff --git a/cardano-diffusion/api/tests/Test/Cardano/Network/NodeToNode/Version.hs b/cardano-diffusion/api/tests/Test/Cardano/Network/NodeToNode/Version.hs index e63dc699e39..d9ee6a47593 100644 --- a/cardano-diffusion/api/tests/Test/Cardano/Network/NodeToNode/Version.hs +++ b/cardano-diffusion/api/tests/Test/Cardano/Network/NodeToNode/Version.hs @@ -51,9 +51,9 @@ prop_nodeToNodeVersionCodec version = prop_nodeToNodeCodec :: NodeToNodeVersion -> NodeToNodeVersionData -> Bool prop_nodeToNodeCodec ntnVersion ntnData = - case decodeTerm (encodeTerm ntnData) of + case decodeData ntnVersion (encodeData ntnVersion ntnData) of Right ntnData' -> networkMagic ntnData' == networkMagic ntnData && diffusionMode ntnData' == diffusionMode ntnData Left {} -> False where - CodecCBORTerm { encodeTerm, decodeTerm } = nodeToNodeCodecCBORTerm ntnVersion + VersionDataCodec { encodeData, decodeData } = nodeToNodeVersionDataCodec diff --git a/cardano-diffusion/lib/Cardano/Network/Diffusion.hs b/cardano-diffusion/lib/Cardano/Network/Diffusion.hs index 94e1c4c1d48..2fbecf3bf16 100644 --- a/cardano-diffusion/lib/Cardano/Network/Diffusion.hs +++ b/cardano-diffusion/lib/Cardano/Network/Diffusion.hs @@ -82,9 +82,7 @@ run CardanoNodeArguments { haBearerTracer = Diffusion.dtBearerTracer tracers, haHandshakeTracer = Diffusion.dtHandshakeTracer tracers, haHandshakeCodec = NodeToNode.nodeToNodeHandshakeCodec, - haVersionDataCodec = - cborTermVersionDataCodec - NodeToNode.nodeToNodeCodecCBORTerm, + haVersionDataCodec = NodeToNode.nodeToNodeVersionDataCodec, haAcceptVersion = acceptableVersion, haQueryVersion = queryVersion, haTimeLimits = timeLimitsHandshake @@ -94,9 +92,7 @@ run CardanoNodeArguments { haBearerTracer = Diffusion.dtLocalBearerTracer tracers, haHandshakeTracer = Diffusion.dtLocalHandshakeTracer tracers, haHandshakeCodec = NodeToClient.nodeToClientHandshakeCodec, - haVersionDataCodec = - cborTermVersionDataCodec - NodeToClient.nodeToClientCodecCBORTerm, + haVersionDataCodec = NodeToClient.nodeToClientVersionDataCodec, haAcceptVersion = acceptableVersion, haQueryVersion = queryVersion, haTimeLimits = noTimeLimitsHandshake diff --git a/cardano-diffusion/lib/Cardano/Network/NodeToClient.hs b/cardano-diffusion/lib/Cardano/Network/NodeToClient.hs index dd1987cc30b..33ae4acb90b 100644 --- a/cardano-diffusion/lib/Cardano/Network/NodeToClient.hs +++ b/cardano-diffusion/lib/Cardano/Network/NodeToClient.hs @@ -46,7 +46,6 @@ module Cardano.Network.NodeToClient -- ** Codecs , nodeToClientHandshakeCodec , nodeToClientVersionCodec - , nodeToClientCodecCBORTerm , nodeToClientVersionDataCodec -- * Limits , maximumMiniProtocolLimits @@ -236,7 +235,7 @@ connectTo snocket tracers versions path = ConnectToArgs { ctaHandshakeCodec = nodeToClientHandshakeCodec, ctaHandshakeTimeLimits = noTimeLimitsHandshake, - ctaVersionDataCodec = cborTermVersionDataCodec nodeToClientCodecCBORTerm, + ctaVersionDataCodec = nodeToClientVersionDataCodec, ctaConnectTracers = tracers, ctaHandshakeCallbacks = HandshakeCallbacks acceptableVersion queryVersion } @@ -285,7 +284,7 @@ connectToWithMux snocket tracers versions path k = ConnectToArgs { ctaHandshakeCodec = nodeToClientHandshakeCodec, ctaHandshakeTimeLimits = noTimeLimitsHandshake, - ctaVersionDataCodec = cborTermVersionDataCodec nodeToClientCodecCBORTerm, + ctaVersionDataCodec = nodeToClientVersionDataCodec, ctaConnectTracers = tracers, ctaHandshakeCallbacks = HandshakeCallbacks acceptableVersion queryVersion } diff --git a/cardano-diffusion/lib/Cardano/Network/NodeToNode.hs b/cardano-diffusion/lib/Cardano/Network/NodeToNode.hs index 47ee63fcf9d..ea9c09cd63f 100644 --- a/cardano-diffusion/lib/Cardano/Network/NodeToNode.hs +++ b/cardano-diffusion/lib/Cardano/Network/NodeToNode.hs @@ -43,7 +43,6 @@ module Cardano.Network.NodeToNode -- *** Codecs , nodeToNodeHandshakeCodec , nodeToNodeVersionCodec - , nodeToNodeCodecCBORTerm , nodeToNodeVersionDataCodec -- * Re-exports , ExpandedInitiatorContext (..) diff --git a/cardano-diffusion/ping/Cardano/Network/Ping.hs b/cardano-diffusion/ping/Cardano/Network/Ping.hs index bb0adf736ef..9b0020ea73f 100644 --- a/cardano-diffusion/ping/Cardano/Network/Ping.hs +++ b/cardano-diffusion/ping/Cardano/Network/Ping.hs @@ -470,8 +470,8 @@ pingClient protocol stdout opts@PingOpts{..} peer = NodeToNode {} -> NodeToNode.nodeToNodeHandshakeCodec NodeToClient {} -> NodeToClient.nodeToClientHandshakeCodec, haVersionDataCodec = case protocol of - NodeToNode {} -> cborTermVersionDataCodec nodeToNodeCodecCBORTerm - NodeToClient {} -> cborTermVersionDataCodec nodeToClientCodecCBORTerm, + NodeToNode {} -> NodeToNode.nodeToNodeVersionDataCodec + NodeToClient {} -> NodeToClient.nodeToClientVersionDataCodec, haAcceptVersion = acceptableVersion, haQueryVersion = queryVersion, haTimeLimits = timeLimitsHandshake diff --git a/cardano-diffusion/protocols/cddl/Main.hs b/cardano-diffusion/protocols/cddl/Main.hs index 1c394d37217..1bfceaec7e3 100644 --- a/cardano-diffusion/protocols/cddl/Main.hs +++ b/cardano-diffusion/protocols/cddl/Main.hs @@ -61,11 +61,11 @@ import Ouroboros.Network.CodecCBORTerm import Ouroboros.Network.Magic import Cardano.Network.NodeToClient.Version (NodeToClientVersion, - NodeToClientVersionData (..), nodeToClientCodecCBORTerm) + NodeToClientVersionData (..), nodeToClientVersionDataCodec) import Cardano.Network.NodeToClient.Version qualified as NtCVersion import Cardano.Network.NodeToNode.Version (DiffusionMode (..), NodeToNodeVersion (..), NodeToNodeVersionData (..), - nodeToNodeCodecCBORTerm) + nodeToNodeVersionDataCodec) import Cardano.Network.NodeToNode.Version qualified as NtNVersion import Ouroboros.Network.PeerSelection.RelayAccessPoint (PortNumber) @@ -327,11 +327,13 @@ validateEncoder spec validateCBORTermEncoder :: Show a => CDDLSpec a - -> CodecCBORTerm fail a + -> VersionDataCodec v a + -> v -> a -> Property validateCBORTermEncoder spec - CodecCBORTerm { encodeTerm } + VersionDataCodec { encodeData } + v a = counterexample (show a) $ counterexample sterms $ @@ -342,7 +344,7 @@ validateCBORTermEncoder spec where blob = CBOR.toLazyByteString . CBOR.encodeTerm - . encodeTerm + . encodeData v $ a terms = CBOR.deserialiseFromBytes CBOR.decodeTerm blob @@ -414,12 +416,12 @@ genNtNHandshake genVersion = oneof [ AnyMessage . Handshake.MsgProposeVersions . Map.fromList - . map (\(v, d) -> (v, encodeTerm (nodeToNodeCodecCBORTerm v) d)) + . map (\(v, d) -> (v, encodeData nodeToNodeVersionDataCodec v d)) <$> listOf ((,) <$> genVersion <*> genData) , AnyMessage . uncurry Handshake.MsgAcceptVersion - . (\(v, d) -> (v, encodeTerm (nodeToNodeCodecCBORTerm v) d)) + . (\(v, d) -> (v, encodeData nodeToNodeVersionDataCodec v d)) <$> ((,) <$> genVersion <*> genData) , AnyMessage @@ -472,12 +474,12 @@ instance Arbitrary (AnyMessage (Handshake NodeToClientVersion CBOR.Term)) where [ AnyMessage . Handshake.MsgProposeVersions . Map.fromList - . map (\(v, d) -> (v, encodeTerm (nodeToClientCodecCBORTerm v) d)) + . map (\(v, d) -> (v, encodeData nodeToClientVersionDataCodec v d)) <$> listOf ((,) <$> genVersion <*> genData) , AnyMessage . uncurry Handshake.MsgAcceptVersion - . (\(v, d) -> (v, encodeTerm (nodeToClientCodecCBORTerm v) d)) + . (\(v, d) -> (v, encodeData nodeToClientVersionDataCodec v d)) <$> ((,) <$> genVersion <*> genData) , AnyMessage @@ -620,7 +622,7 @@ prop_encodeNodeToNodeVersionDataV14ToLast -> NtNVersionDataV14ToLast -> Property prop_encodeNodeToNodeVersionDataV14ToLast spec (NtNVersionDataV14ToLast (v, a)) = - validateCBORTermEncoder spec (nodeToNodeCodecCBORTerm v) a + validateCBORTermEncoder spec nodeToNodeVersionDataCodec v a -- -- Test decoders @@ -952,7 +954,11 @@ unit_decodeNodeToNodeVersionDataV14ToLast -> Assertion unit_decodeNodeToNodeVersionDataV14ToLast spec = forM_ [NodeToNodeV_14 ..] $ \v -> - validateCBORTermDecoder Nothing spec (nodeToNodeCodecCBORTerm v) 100 + validateCBORTermDecoder Nothing spec (c v) 100 + where + c = \v -> case nodeToNodeVersionDataCodec of + VersionDataCodec enc dec -> CodecCBORTerm (enc v) (dec v) + -- -- Utils diff --git a/cardano-diffusion/protocols/tests-lib/Cardano/Network/Protocol/Handshake/Test.hs b/cardano-diffusion/protocols/tests-lib/Cardano/Network/Protocol/Handshake/Test.hs index 8e81b45f057..e37ef7e3383 100644 --- a/cardano-diffusion/protocols/tests-lib/Cardano/Network/Protocol/Handshake/Test.hs +++ b/cardano-diffusion/protocols/tests-lib/Cardano/Network/Protocol/Handshake/Test.hs @@ -320,7 +320,7 @@ prop_query_version_NodeToClient_ST runSimOrThrow $ prop_query_version createConnectedChannels (codecHandshake nodeToClientVersionCodec) - (cborTermVersionDataCodec nodeToClientCodecCBORTerm) + nodeToClientVersionDataCodec clientVersions serverVersions (\vd -> vd {NTC.query = True}) @@ -336,7 +336,7 @@ prop_query_version_NodeToClient_IO ioProperty $ prop_query_version createConnectedChannels (codecHandshake nodeToClientVersionCodec) - (cborTermVersionDataCodec nodeToClientCodecCBORTerm) + nodeToClientVersionDataCodec clientVersions serverVersions (\vd -> vd {NTC.query = True}) @@ -352,7 +352,7 @@ prop_query_version_NodeToClient_SimNet runSimOrThrow $ prop_query_version createConnectedChannels (codecHandshake nodeToClientVersionCodec) - (cborTermVersionDataCodec nodeToClientCodecCBORTerm) + nodeToClientVersionDataCodec clientVersions serverVersions (\vd -> vd {NTC.query = True}) @@ -475,7 +475,7 @@ prop_channel_simultaneous_open_NodeToClient_ST runSimOrThrow $ prop_channel_simultaneous_open createConnectedChannels (codecHandshake nodeToClientVersionCodec) - (cborTermVersionDataCodec nodeToClientCodecCBORTerm) + nodeToClientVersionDataCodec clientVersions serverVersions @@ -489,7 +489,7 @@ prop_channel_simultaneous_open_NodeToClient_IO ioProperty $ prop_channel_simultaneous_open createConnectedChannels (codecHandshake nodeToClientVersionCodec) - (cborTermVersionDataCodec nodeToClientCodecCBORTerm) + nodeToClientVersionDataCodec clientVersions serverVersions @@ -514,6 +514,6 @@ prop_channel_simultaneous_open_NodeToClient_SimNet (ArbitraryNodeToClientVersions serverVersions) = runSimOrThrow $ prop_channel_simultaneous_open_sim (codecHandshake nodeToClientVersionCodec) - (cborTermVersionDataCodec nodeToClientCodecCBORTerm) + nodeToClientVersionDataCodec clientVersions serverVersions From 402a2386e4ff984dba2f09fe0a9fcd33c7072b94 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Wed, 1 Oct 2025 15:04:13 +0200 Subject: [PATCH 09/11] api: VersionedCodecCBORTerm --- .../Cardano/Network/NodeToClient/Version.hs | 2 +- .../lib/Cardano/Network/NodeToNode/Version.hs | 2 +- .../lib/Ouroboros/Network/CodecCBORTerm.hs | 57 ++++++++++++++----- .../Network/Protocol/Handshake/Codec.hs | 5 +- .../Network/Protocol/Handshake/Unversioned.hs | 2 +- .../Network/ConnectionManager/Experiments.hs | 4 +- .../Network/Protocol/Handshake/Test.hs | 20 +++---- .../tests/io/Test/Ouroboros/Network/Socket.hs | 6 +- .../Test/Ouroboros/Network/Diffusion/Node.hs | 5 +- 9 files changed, 68 insertions(+), 35 deletions(-) diff --git a/cardano-diffusion/api/lib/Cardano/Network/NodeToClient/Version.hs b/cardano-diffusion/api/lib/Cardano/Network/NodeToClient/Version.hs index d5aac3d12b5..5d3bc67e8c7 100644 --- a/cardano-diffusion/api/lib/Cardano/Network/NodeToClient/Version.hs +++ b/cardano-diffusion/api/lib/Cardano/Network/NodeToClient/Version.hs @@ -149,4 +149,4 @@ nodeToClientCodecCBORTerm _v = CodecCBORTerm {encodeTerm, decodeTerm} nodeToClientVersionDataCodec :: VersionDataCodec NodeToClientVersion NodeToClientVersionData -nodeToClientVersionDataCodec = cborTermVersionDataCodec nodeToClientCodecCBORTerm +nodeToClientVersionDataCodec = mkVersionedCodecCBORTerm nodeToClientCodecCBORTerm diff --git a/cardano-diffusion/api/lib/Cardano/Network/NodeToNode/Version.hs b/cardano-diffusion/api/lib/Cardano/Network/NodeToNode/Version.hs index bb41530b4de..ad90d107a30 100644 --- a/cardano-diffusion/api/lib/Cardano/Network/NodeToNode/Version.hs +++ b/cardano-diffusion/api/lib/Cardano/Network/NodeToNode/Version.hs @@ -171,6 +171,6 @@ nodeToNodeCodecCBORTerm = nodeToNodeVersionDataCodec :: VersionDataCodec NodeToNodeVersion NodeToNodeVersionData -nodeToNodeVersionDataCodec = cborTermVersionDataCodec nodeToNodeCodecCBORTerm +nodeToNodeVersionDataCodec = mkVersionedCodecCBORTerm nodeToNodeCodecCBORTerm data ConnectionMode = UnidirectionalMode | DuplexMode diff --git a/ouroboros-network/api/lib/Ouroboros/Network/CodecCBORTerm.hs b/ouroboros-network/api/lib/Ouroboros/Network/CodecCBORTerm.hs index a7d981ae249..c5b7481a726 100644 --- a/ouroboros-network/api/lib/Ouroboros/Network/CodecCBORTerm.hs +++ b/ouroboros-network/api/lib/Ouroboros/Network/CodecCBORTerm.hs @@ -1,7 +1,12 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PatternSynonyms #-} + module Ouroboros.Network.CodecCBORTerm ( CodecCBORTerm (..) - , VersionDataCodec (..) - , cborTermVersionDataCodec + , VersionDataCodec + , VersionedCodecCBORTerm (.., VersionDataCodec, encodeData, decodeData) + , mkVersionedCodecCBORTerm + , unVersionCodecCBORTerm ) where import Codec.CBOR.Term qualified as CBOR @@ -17,19 +22,43 @@ data CodecCBORTerm fail a = CodecCBORTerm , decodeTerm :: CBOR.Term -> Either fail a } --- | Codec for version data exchanged by the handshake protocol. + +-- | A pure codec which encodes to / decodes from `CBOR.Term` which can +-- depend on a version. -- -data VersionDataCodec vNumber vData = VersionDataCodec { - encodeData :: vNumber -> vData -> CBOR.Term, - -- ^ encoder of 'vData' which has access to 'extra vData' which can bring - -- extra instances into the scope (by means of pattern matching on a GADT). - decodeData :: vNumber -> CBOR.Term -> Either Text vData - -- ^ decoder of 'vData'. +data VersionedCodecCBORTerm fail v a = VersionedCodecCBORTerm { + encodeVersionedTerm :: v -> a -> CBOR.Term, + decodeVersionedTerm :: v -> CBOR.Term -> Either fail a } -cborTermVersionDataCodec :: (vNumber -> CodecCBORTerm Text vData) - -> VersionDataCodec vNumber vData -cborTermVersionDataCodec codec = VersionDataCodec { - encodeData = encodeTerm . codec, - decodeData = decodeTerm . codec +mkVersionedCodecCBORTerm :: (vNumber -> CodecCBORTerm fail vData) + -> VersionedCodecCBORTerm fail vNumber vData +mkVersionedCodecCBORTerm codec = VersionedCodecCBORTerm { + encodeVersionedTerm = encodeTerm . codec, + decodeVersionedTerm = decodeTerm . codec } + +unVersionCodecCBORTerm :: VersionedCodecCBORTerm fail vNumber vData + -> vNumber -> CodecCBORTerm fail vData +unVersionCodecCBORTerm VersionedCodecCBORTerm{encodeVersionedTerm, decodeVersionedTerm} v = + CodecCBORTerm { + encodeTerm = encodeVersionedTerm v, + decodeTerm = decodeVersionedTerm v + } + +-- +-- A specialised VersionedCodecCBORTerm used for encoding / decoding +-- handshake's version data +-- + +type VersionDataCodec versionNumber versionData = + VersionedCodecCBORTerm Text versionNumber versionData + +-- | Codec for version data exchanged by the handshake protocol. +-- +pattern VersionDataCodec :: (v -> a -> CBOR.Term) + -> (v -> CBOR.Term -> Either Text a) + -> VersionDataCodec v a +pattern VersionDataCodec { encodeData, decodeData } = + VersionedCodecCBORTerm encodeData decodeData +{-# COMPLETE VersionDataCodec #-} diff --git a/ouroboros-network/framework/lib/Ouroboros/Network/Protocol/Handshake/Codec.hs b/ouroboros-network/framework/lib/Ouroboros/Network/Protocol/Handshake/Codec.hs index 68dd5b53df5..6b4ecb3eb19 100644 --- a/ouroboros-network/framework/lib/Ouroboros/Network/Protocol/Handshake/Codec.hs +++ b/ouroboros-network/framework/lib/Ouroboros/Network/Protocol/Handshake/Codec.hs @@ -14,8 +14,9 @@ module Ouroboros.Network.Protocol.Handshake.Codec , encodeRefuseReason , decodeRefuseReason -- ** Version data codec - , VersionDataCodec (..) - , cborTermVersionDataCodec + , VersionDataCodec + , VersionedCodecCBORTerm (..) + , mkVersionedCodecCBORTerm ) where import Control.Monad (replicateM, unless) diff --git a/ouroboros-network/framework/lib/Ouroboros/Network/Protocol/Handshake/Unversioned.hs b/ouroboros-network/framework/lib/Ouroboros/Network/Protocol/Handshake/Unversioned.hs index 5c60d79a613..fe645695795 100644 --- a/ouroboros-network/framework/lib/Ouroboros/Network/Protocol/Handshake/Unversioned.hs +++ b/ouroboros-network/framework/lib/Ouroboros/Network/Protocol/Handshake/Unversioned.hs @@ -53,7 +53,7 @@ instance Queryable UnversionedProtocolData where unversionedProtocolDataCodec :: VersionDataCodec UnversionedProtocol UnversionedProtocolData -unversionedProtocolDataCodec = cborTermVersionDataCodec +unversionedProtocolDataCodec = mkVersionedCodecCBORTerm (const CodecCBORTerm {encodeTerm, decodeTerm}) where encodeTerm :: UnversionedProtocolData -> CBOR.Term diff --git a/ouroboros-network/framework/tests-lib/Test/Ouroboros/Network/ConnectionManager/Experiments.hs b/ouroboros-network/framework/tests-lib/Test/Ouroboros/Network/ConnectionManager/Experiments.hs index 05de7bd770d..9c54c73643c 100644 --- a/ouroboros-network/framework/tests-lib/Test/Ouroboros/Network/ConnectionManager/Experiments.hs +++ b/ouroboros-network/framework/tests-lib/Test/Ouroboros/Network/ConnectionManager/Experiments.hs @@ -291,7 +291,7 @@ withInitiatorOnlyConnectionManager name timeouts trTracer tracer stdGen snocket haHandshakeTracer = WithName name `contramap` nullTracer, haBearerTracer = WithName name `contramap` nullTracer, haHandshakeCodec = unversionedHandshakeCodec, - haVersionDataCodec = cborTermVersionDataCodec dataFlowProtocolDataCodec, + haVersionDataCodec = mkVersionedCodecCBORTerm dataFlowProtocolDataCodec, haAcceptVersion = acceptableVersion, haQueryVersion = queryVersion, haTimeLimits = handshakeTimeLimits @@ -487,7 +487,7 @@ withBidirectionalConnectionManager name timeouts haHandshakeTracer = WithName name `contramap` nullTracer, haBearerTracer = WithName `contramap` nullTracer, haHandshakeCodec = unversionedHandshakeCodec, - haVersionDataCodec = cborTermVersionDataCodec dataFlowProtocolDataCodec, + haVersionDataCodec = mkVersionedCodecCBORTerm dataFlowProtocolDataCodec, haAcceptVersion = acceptableVersion, haQueryVersion = queryVersion, haTimeLimits = handshakeTimeLimits diff --git a/ouroboros-network/protocols/tests-lib/Ouroboros/Network/Protocol/Handshake/Test.hs b/ouroboros-network/protocols/tests-lib/Ouroboros/Network/Protocol/Handshake/Test.hs index 3f09eed328a..a81cfd830d7 100644 --- a/ouroboros-network/protocols/tests-lib/Ouroboros/Network/Protocol/Handshake/Test.hs +++ b/ouroboros-network/protocols/tests-lib/Ouroboros/Network/Protocol/Handshake/Test.hs @@ -397,11 +397,11 @@ prop_connect (ArbitraryVersions clientVersions serverVersions) = in case runSimOrThrow (connect (handshakeClientPeer - (cborTermVersionDataCodec dataCodecCBORTerm) + (mkVersionedCodecCBORTerm dataCodecCBORTerm) acceptableVersion clientVersions) (handshakeServerPeer - (cborTermVersionDataCodec dataCodecCBORTerm) + (mkVersionedCodecCBORTerm dataCodecCBORTerm) acceptableVersion queryVersion serverVersions)) of @@ -438,11 +438,11 @@ prop_channel createChannels clientVersions serverVersions = runConnectedPeers createChannels nullTracer versionNumberHandshakeCodec (handshakeClientPeer - (cborTermVersionDataCodec dataCodecCBORTerm) + (mkVersionedCodecCBORTerm dataCodecCBORTerm) acceptableVersion clientVersions) (handshakeServerPeer - (cborTermVersionDataCodec dataCodecCBORTerm) + (mkVersionedCodecCBORTerm dataCodecCBORTerm) acceptableVersion queryVersion serverVersions) @@ -513,11 +513,11 @@ prop_channel_asymmetric createChannels clientVersions = do versionNumberHandshakeCodec (codecHandshake versionNumberCodec') (handshakeClientPeer - (cborTermVersionDataCodec dataCodecCBORTerm) + (mkVersionedCodecCBORTerm dataCodecCBORTerm) acceptableVersion clientVersions) (handshakeServerPeer - (cborTermVersionDataCodec dataCodecCBORTerm) + (mkVersionedCodecCBORTerm dataCodecCBORTerm) acceptableVersion queryVersion serverVersions) @@ -714,7 +714,7 @@ prop_acceptOrRefuse_symmetric_VersionData -> ArbitraryValidVersions -> Property prop_acceptOrRefuse_symmetric_VersionData (ArbitraryValidVersions a) (ArbitraryValidVersions b) = - prop_acceptOrRefuse_symmetric (cborTermVersionDataCodec dataCodecCBORTerm) + prop_acceptOrRefuse_symmetric (mkVersionedCodecCBORTerm dataCodecCBORTerm) a b @@ -785,7 +785,7 @@ prop_channel_simultaneous_open_ST (ArbitraryVersions clientVersions serverVersio runSimOrThrow $ prop_channel_simultaneous_open createConnectedChannels versionNumberHandshakeCodec - (cborTermVersionDataCodec dataCodecCBORTerm) + (mkVersionedCodecCBORTerm dataCodecCBORTerm) clientVersions serverVersions @@ -796,7 +796,7 @@ prop_channel_simultaneous_open_IO (ArbitraryVersions clientVersions serverVersio ioProperty $ prop_channel_simultaneous_open createConnectedChannels versionNumberHandshakeCodec - (cborTermVersionDataCodec dataCodecCBORTerm) + (mkVersionedCodecCBORTerm dataCodecCBORTerm) clientVersions serverVersions @@ -880,7 +880,7 @@ prop_channel_simultaneous_open_SimNet (ArbitraryVersions clientVersions serverVersions) = runSimOrThrow $ prop_channel_simultaneous_open_sim versionNumberHandshakeCodec - (cborTermVersionDataCodec dataCodecCBORTerm) + (mkVersionedCodecCBORTerm dataCodecCBORTerm) clientVersions serverVersions diff --git a/ouroboros-network/tests/io/Test/Ouroboros/Network/Socket.hs b/ouroboros-network/tests/io/Test/Ouroboros/Network/Socket.hs index 3deeed1ae18..1e270985880 100644 --- a/ouroboros-network/tests/io/Test/Ouroboros/Network/Socket.hs +++ b/ouroboros-network/tests/io/Test/Ouroboros/Network/Socket.hs @@ -138,6 +138,8 @@ testVersionCodecCBORTerm !_ = decodeTerm t = Left $ T.pack $ "unknown encoding: " ++ show t +testVersionDataCodec :: VersionDataCodec TestVersion TestVersionData +testVersionDataCodec = mkVersionedCodecCBORTerm testVersionCodecCBORTerm -- -- The list of all tests @@ -245,7 +247,7 @@ demo chain0 updates = withIOManager $ \iocp -> do haHandshakeTracer = nullTracer, haBearerTracer = nullTracer, haHandshakeCodec = handshakeCodec, - haVersionDataCodec = cborTermVersionDataCodec testVersionCodecCBORTerm, + haVersionDataCodec = testVersionDataCodec, haAcceptVersion = acceptableVersion, haQueryVersion = queryVersion, haTimeLimits = noTimeLimitsHandshake @@ -263,7 +265,7 @@ demo chain0 updates = withIOManager $ \iocp -> do ConnectToArgs { ctaHandshakeCodec = handshakeCodec, ctaHandshakeTimeLimits = noTimeLimitsHandshake, - ctaVersionDataCodec = cborTermVersionDataCodec testVersionCodecCBORTerm, + ctaVersionDataCodec = testVersionDataCodec, ctaConnectTracers = nullNetworkConnectTracers, ctaHandshakeCallbacks = HandshakeCallbacks acceptableVersion queryVersion } diff --git a/ouroboros-network/tests/lib/Test/Ouroboros/Network/Diffusion/Node.hs b/ouroboros-network/tests/lib/Test/Ouroboros/Network/Diffusion/Node.hs index 26254f3654f..41a4585a1e8 100644 --- a/ouroboros-network/tests/lib/Test/Ouroboros/Network/Diffusion/Node.hs +++ b/ouroboros-network/tests/lib/Test/Ouroboros/Network/Diffusion/Node.hs @@ -62,10 +62,11 @@ import Data.Void (Void) import Network.DNS (Domain, TYPE) import System.Random (StdGen, split) +import Ouroboros.Network.CodecCBORTerm import Ouroboros.Network.Mux (noBindForkPolicy) import Ouroboros.Network.Protocol.Handshake (HandshakeArguments (..)) -import Ouroboros.Network.Protocol.Handshake.Codec (VersionDataCodec (..), - noTimeLimitsHandshake, timeLimitsHandshake) +import Ouroboros.Network.Protocol.Handshake.Codec (noTimeLimitsHandshake, + timeLimitsHandshake) import Ouroboros.Network.Protocol.Handshake.Unversioned (unversionedHandshakeCodec, unversionedProtocolDataCodec) import Ouroboros.Network.Protocol.Handshake.Version (Accept (Accept)) From 247a2e1693f60d5cd73563f807877e3bb2267eda Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Wed, 1 Oct 2025 15:28:20 +0200 Subject: [PATCH 10/11] dmq-node: updated to API changes --- dmq-node/src/DMQ/NodeToClient.hs | 8 +++----- dmq-node/src/DMQ/NodeToClient/Version.hs | 7 +++++-- dmq-node/src/DMQ/NodeToNode.hs | 6 +++--- dmq-node/src/DMQ/NodeToNode/Version.hs | 7 +++++-- dmq-node/test/Test/DMQ/NodeToClient.hs | 4 ++-- dmq-node/test/Test/DMQ/NodeToNode.hs | 4 ++-- 6 files changed, 20 insertions(+), 16 deletions(-) diff --git a/dmq-node/src/DMQ/NodeToClient.hs b/dmq-node/src/DMQ/NodeToClient.hs index a6684db27d5..879fa8d1417 100644 --- a/dmq-node/src/DMQ/NodeToClient.hs +++ b/dmq-node/src/DMQ/NodeToClient.hs @@ -56,8 +56,8 @@ import Ouroboros.Network.Handshake.Queryable (Queryable (..)) import Ouroboros.Network.Mux import Ouroboros.Network.OrphanInstances () import Ouroboros.Network.Protocol.Handshake (Handshake, HandshakeArguments (..)) -import Ouroboros.Network.Protocol.Handshake.Codec (cborTermVersionDataCodec, - codecHandshake, noTimeLimitsHandshake) +import Ouroboros.Network.Protocol.Handshake.Codec (codecHandshake, + noTimeLimitsHandshake) import Ouroboros.Network.TxSubmission.Inbound.V2.Types (TxSubmissionMempoolWriter) import Ouroboros.Network.TxSubmission.Mempool.Reader @@ -78,9 +78,7 @@ ntcHandshakeArguments tracer = haHandshakeTracer = tracer , haBearerTracer = nullTracer -- TODO , haHandshakeCodec = codecHandshake nodeToClientVersionCodec - , haVersionDataCodec = - cborTermVersionDataCodec - nodeToClientCodecCBORTerm + , haVersionDataCodec = nodeToClientVersionDataCodec , haAcceptVersion = acceptableVersion , haQueryVersion = queryVersion , haTimeLimits = noTimeLimitsHandshake diff --git a/dmq-node/src/DMQ/NodeToClient/Version.hs b/dmq-node/src/DMQ/NodeToClient/Version.hs index 5b5b117b911..f825ae8884f 100644 --- a/dmq-node/src/DMQ/NodeToClient/Version.hs +++ b/dmq-node/src/DMQ/NodeToClient/Version.hs @@ -8,8 +8,8 @@ module DMQ.NodeToClient.Version ( NodeToClientVersion (..) , NodeToClientVersionData (..) , stdVersionDataNTC - , nodeToClientCodecCBORTerm , nodeToClientVersionCodec + , nodeToClientVersionDataCodec ) where import Codec.CBOR.Term qualified as CBOR @@ -22,7 +22,7 @@ import Data.Text (Text) import Data.Text qualified as T import GHC.Generics (Generic) -import Ouroboros.Network.CodecCBORTerm (CodecCBORTerm (..)) +import Ouroboros.Network.CodecCBORTerm import Ouroboros.Network.Handshake.Acceptable (Acceptable (..)) import Ouroboros.Network.Handshake.Queryable (Queryable (..)) import Ouroboros.Network.Magic (NetworkMagic (..)) @@ -120,6 +120,9 @@ nodeToClientCodecCBORTerm _v = CodecCBORTerm {encodeTerm, decodeTerm} decoder x query | x >= 0 && x <= 0xffffffff = Right (NodeToClientVersionData (NetworkMagic $ fromIntegral x) query) | otherwise = Left $ T.pack $ "networkMagic out of bound: " <> show x +nodeToClientVersionDataCodec :: VersionDataCodec NodeToClientVersion NodeToClientVersionData +nodeToClientVersionDataCodec = mkVersionedCodecCBORTerm nodeToClientCodecCBORTerm + stdVersionDataNTC :: NetworkMagic -> NodeToClientVersionData stdVersionDataNTC networkMagic = NodeToClientVersionData diff --git a/dmq-node/src/DMQ/NodeToNode.hs b/dmq-node/src/DMQ/NodeToNode.hs index 9ff7a3acc7c..28eb2e35433 100644 --- a/dmq-node/src/DMQ/NodeToNode.hs +++ b/dmq-node/src/DMQ/NodeToNode.hs @@ -91,8 +91,8 @@ import Ouroboros.Network.TxSubmission.Outbound import Ouroboros.Network.OrphanInstances () import Ouroboros.Network.Protocol.Handshake (Handshake, HandshakeArguments (..)) -import Ouroboros.Network.Protocol.Handshake.Codec (cborTermVersionDataCodec, - codecHandshake, timeLimitsHandshake) +import Ouroboros.Network.Protocol.Handshake.Codec (codecHandshake, + timeLimitsHandshake) import Ouroboros.Network.Protocol.KeepAlive.Client (keepAliveClientPeer) import Ouroboros.Network.Protocol.KeepAlive.Codec (byteLimitsKeepAlive, codecKeepAlive_v2, timeLimitsKeepAlive) @@ -640,7 +640,7 @@ ntnHandshakeArguments tracer = haHandshakeTracer = tracer , haBearerTracer = nullTracer -- TODO , haHandshakeCodec = codecHandshake nodeToNodeVersionCodec - , haVersionDataCodec = cborTermVersionDataCodec nodeToNodeCodecCBORTerm + , haVersionDataCodec = nodeToNodeVersionDataCodec , haAcceptVersion = acceptableVersion , haQueryVersion = queryVersion , haTimeLimits = timeLimitsHandshake diff --git a/dmq-node/src/DMQ/NodeToNode/Version.hs b/dmq-node/src/DMQ/NodeToNode/Version.hs index 752c97ac9dc..562132b7b05 100644 --- a/dmq-node/src/DMQ/NodeToNode/Version.hs +++ b/dmq-node/src/DMQ/NodeToNode/Version.hs @@ -7,8 +7,8 @@ module DMQ.NodeToNode.Version ( NodeToNodeVersion (..) , NodeToNodeVersionData (..) - , nodeToNodeCodecCBORTerm , nodeToNodeVersionCodec + , nodeToNodeVersionDataCodec , ntnDataFlow ) where @@ -19,7 +19,7 @@ import Data.Text (Text) import Data.Text qualified as T import GHC.Generics (Generic) -import Ouroboros.Network.CodecCBORTerm (CodecCBORTerm (..)) +import Ouroboros.Network.CodecCBORTerm import Ouroboros.Network.ConnectionManager.Types (DataFlow (..)) import Ouroboros.Network.DiffusionMode import Ouroboros.Network.Handshake.Acceptable (Acceptable (..)) @@ -154,6 +154,9 @@ nodeToNodeCodecCBORTerm = decodeTerm1 t = Left $ T.pack $ "unknown encoding: " ++ show t +nodeToNodeVersionDataCodec :: VersionDataCodec NodeToNodeVersion NodeToNodeVersionData +nodeToNodeVersionDataCodec = mkVersionedCodecCBORTerm nodeToNodeCodecCBORTerm + ntnDataFlow :: NodeToNodeVersionData -> DataFlow ntnDataFlow NodeToNodeVersionData { diffusionMode } = case diffusionMode of diff --git a/dmq-node/test/Test/DMQ/NodeToClient.hs b/dmq-node/test/Test/DMQ/NodeToClient.hs index c72864a4672..be9b81c249b 100644 --- a/dmq-node/test/Test/DMQ/NodeToClient.hs +++ b/dmq-node/test/Test/DMQ/NodeToClient.hs @@ -45,8 +45,8 @@ prop_nodeToClientVersionCodec version = prop_nodeToClientCodec :: VersionAndVersionData -> Bool prop_nodeToClientCodec (VersionAndVersionData vNumber vData) = - case decodeTerm (encodeTerm vData) of + case decodeData vNumber (encodeData vNumber vData) of Right vData' -> networkMagic vData' == networkMagic vData Left {} -> False where - CodecCBORTerm { encodeTerm, decodeTerm } = nodeToClientCodecCBORTerm vNumber + VersionDataCodec { encodeData, decodeData } = nodeToClientVersionDataCodec diff --git a/dmq-node/test/Test/DMQ/NodeToNode.hs b/dmq-node/test/Test/DMQ/NodeToNode.hs index 74960ee131e..019dc4b172d 100644 --- a/dmq-node/test/Test/DMQ/NodeToNode.hs +++ b/dmq-node/test/Test/DMQ/NodeToNode.hs @@ -53,10 +53,10 @@ prop_nodeToNodeVersionCodec version = prop_nodeToNodeCodec :: NodeToNodeVersion -> NodeToNodeVersionData -> Bool prop_nodeToNodeCodec ntnVersion ntnData = - case decodeTerm (encodeTerm ntnData) of + case decodeData ntnVersion (encodeData ntnVersion ntnData) of Right ntnData' -> networkMagic ntnData' == networkMagic ntnData && diffusionMode ntnData' == diffusionMode ntnData Left {} -> False where - CodecCBORTerm { encodeTerm, decodeTerm } = nodeToNodeCodecCBORTerm ntnVersion + VersionDataCodec { encodeData, decodeData } = nodeToNodeVersionDataCodec From 06bc66737b9367a96815acf9b152a1c6c39e75d4 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Wed, 1 Oct 2025 16:14:04 +0200 Subject: [PATCH 11/11] api: documented changes in the changelog --- .../changelog.d/20251001_160442_coot_cardano_ping.md | 5 +++++ .../changelog.d/20251001_161141_coot_cardano_ping.md | 7 +++++++ .../changelog.d/20251001_160226_coot_cardano_ping.md | 10 ++++++++++ 3 files changed, 22 insertions(+) create mode 100644 cardano-diffusion/changelog.d/20251001_160442_coot_cardano_ping.md create mode 100644 dmq-node/changelog.d/20251001_161141_coot_cardano_ping.md create mode 100644 ouroboros-network/changelog.d/20251001_160226_coot_cardano_ping.md diff --git a/cardano-diffusion/changelog.d/20251001_160442_coot_cardano_ping.md b/cardano-diffusion/changelog.d/20251001_160442_coot_cardano_ping.md new file mode 100644 index 00000000000..53f60015a1b --- /dev/null +++ b/cardano-diffusion/changelog.d/20251001_160442_coot_cardano_ping.md @@ -0,0 +1,5 @@ +### Breaking + +- Added `nodeTo{Client,Node}VersionDataCodec` to + `Cardano.Network.NodeTo{Client,Node}` modules. +- Removed `nodeTo{Client,Node}CodecCBORTerm`, use the above binding instead. diff --git a/dmq-node/changelog.d/20251001_161141_coot_cardano_ping.md b/dmq-node/changelog.d/20251001_161141_coot_cardano_ping.md new file mode 100644 index 00000000000..cb62c7ed5f5 --- /dev/null +++ b/dmq-node/changelog.d/20251001_161141_coot_cardano_ping.md @@ -0,0 +1,7 @@ +### Breaking + +- Added `nodeTo{Client,Node}VersionDataCodec` to `DMQ.NodeTo{Client,Node}` + modules. +- Removed `nodeTo{Client,Node}CodecCBORTerm`, use the above binding instead. + + diff --git a/ouroboros-network/changelog.d/20251001_160226_coot_cardano_ping.md b/ouroboros-network/changelog.d/20251001_160226_coot_cardano_ping.md new file mode 100644 index 00000000000..8f9aaf19fd6 --- /dev/null +++ b/ouroboros-network/changelog.d/20251001_160226_coot_cardano_ping.md @@ -0,0 +1,10 @@ +### Breaking + +- `VersionDataCodec` and `cborTermVersionDataCodec` moved to + `ouroboros-network:api` package (`Ouroboros.Network.CodecCBORTerm` module). +- `VersionDataCodec`: removed the `bytes` polymorphic variable, since it was + always instantiated to `CBOR.Term`. +- `CodecCBORTerm` module provides now `VersionedCodecCBORTerm` a versioned + version of `CodecCBORTerm`, and a pattern synonym `VersionDataCodec` as used + in the rest of the codebase. The `cborTermVersionDataCodec` was renamed as + `mkVersionedCodecCBORTerm`. Also added its inverse `unVersionCodecCBORTerm`.