From f3fb46f4367da7f14ead6c237caee769022d8479 Mon Sep 17 00:00:00 2001 From: Fabrizio Ferrai Date: Tue, 26 May 2026 17:35:03 +0300 Subject: [PATCH 1/4] Integration for Node release 11.1 --- cabal.project | 67 +++++++++++++++++-- cardano-cli/cardano-cli.cabal | 7 +- .../src/Cardano/CLI/Byron/UpdateProposal.hs | 2 +- cardano-cli/src/Cardano/CLI/Byron/Vote.hs | 2 +- .../CLI/EraIndependent/Cip/Cip129/Run.hs | 13 ++-- .../EraIndependent/Debug/LogEpochState/Run.hs | 9 +++ .../Cardano/CLI/EraIndependent/Ping/Run.hs | 4 +- cardano-cli/src/Cardano/CLI/Orphan.hs | 8 --- cardano-cli/src/Cardano/CLI/Read.hs | 13 ++++ 9 files changed, 99 insertions(+), 26 deletions(-) diff --git a/cabal.project b/cabal.project index 3bb37cdadf..b2daa4ee24 100644 --- a/cabal.project +++ b/cabal.project @@ -16,10 +16,6 @@ index-state: , hackage.haskell.org 2026-06-02T21:49:32Z , cardano-haskell-packages 2026-06-02T21:14:32Z -active-repositories: - , :rest - , cardano-haskell-packages:override - packages: cardano-cli @@ -100,3 +96,66 @@ if impl(ghc >= 9.14) , with-utf8:base -- cabal-allow-newer end +source-repository-package + type: git + location: https://github.com/IntersectMBO/cardano-api.git + tag: 500e283a93fcb4c82b03febf243cb976431a613f + --sha256: sha256-aHpjdMQhjRpe0w5Fb9a5LeVGcO44VAl928CS7HoYB0Q= + subdir: + cardano-api + +source-repository-package + type: git + location: https://github.com/IntersectMBO/cardano-ledger.git + tag: 3f879bb37df4738ed8211e500c7d180443cfcbe4 + --sha256: sha256-uLjiIHiU1SzAmoKs+rynQphc3FUYXKeJLlOnp87uNdg= + subdir: + eras/allegra/impl + eras/alonzo/impl + eras/babbage/impl + eras/byron/chain/executable-spec + eras/byron/crypto + eras/byron/ledger/executable-spec + eras/byron/ledger/impl + eras/conway/impl + eras/dijkstra/impl + eras/mary/impl + eras/shelley-ma/test-suite + eras/shelley/impl + eras/shelley/test-suite + libs/cardano-data + libs/cardano-ledger-api + libs/cardano-ledger-binary + libs/cardano-ledger-core + libs/cardano-protocol-tpraos + libs/non-integral + libs/small-steps + libs/vector-map + +source-repository-package + type: git + location: https://github.com/f-f/kes-agent.git + tag: 0b362519f6915841c92869ed288ce83f89b17b73 + --sha256: sha256-8pZYF7MJZZ1tM19wIUhbLKORDL+OP2ckhueWJM4aG/c= + subdir: + kes-agent + kes-agent-crypto + +source-repository-package + type: git + location: https://github.com/IntersectMBO/ouroboros-consensus.git + tag: 0411b4d50dc62cab07bbbf75805cf585a7a1f8e7 + --sha256: sha256-DNnGHdo+oQDBbHzAl6UZ/VcPoS4TxGrC9eCOiMxgc8A= + subdir: + . + +source-repository-package + type: git + location: https://github.com/IntersectMBO/ouroboros-network.git + tag: 10e173b21a82f6142261f0f38da0ec14c8b8a91c + --sha256: sha256-l3lpFzcFj2xiKaj54A7Rvhuu3s6EtzIboaHyuGhBhG8= + subdir: + ./cardano-diffusion + ./monoidal-synchronisation + ./network-mux + ./ouroboros-network diff --git a/cardano-cli/cardano-cli.cabal b/cardano-cli/cardano-cli.cabal index 2e24f66059..246daff998 100644 --- a/cardano-cli/cardano-cli.cabal +++ b/cardano-cli/cardano-cli.cabal @@ -245,15 +245,15 @@ library cardano-api ^>=11.3, cardano-binary, cardano-crypto, - cardano-crypto-class ^>=2.3, + cardano-crypto-class ^>=2.5, cardano-crypto-wrapper ^>=1.7, cardano-data >=1.1, + cardano-diffusion:ping ^>=1.0, cardano-git-rev ^>=0.2.2, cardano-ledger-api, cardano-ledger-conway, cardano-ledger-core, cardano-ledger-dijkstra, - cardano-ping ^>=0.10, cardano-prelude, cardano-protocol-tpraos, cardano-slotting ^>=0.2.0.0, @@ -267,6 +267,7 @@ library exceptions, filepath, formatting, + fs-api, generic-lens, haskeline, http-client, @@ -292,7 +293,7 @@ library transformers, unliftio-core, utf8-string, - validation, + validation ^>=1.2, vary ^>=0.1.1.2, vector, yaml, diff --git a/cardano-cli/src/Cardano/CLI/Byron/UpdateProposal.hs b/cardano-cli/src/Cardano/CLI/Byron/UpdateProposal.hs index 79a3b7e146..d929c2a0cd 100644 --- a/cardano-cli/src/Cardano/CLI/Byron/UpdateProposal.hs +++ b/cardano-cli/src/Cardano/CLI/Byron/UpdateProposal.hs @@ -69,5 +69,5 @@ submitByronUpdateProposal submitByronUpdateProposal nodeSocketPath network proposalFp = do proposal <- readByronUpdateProposal proposalFp let genTx = toByronLedgerUpdateProposal proposal - traceWith stdoutTracer $ "Update proposal TxId: " ++ condense (txId genTx) + liftIO $ traceWith stdoutTracer $ "Update proposal TxId: " ++ condense (txId genTx) fromExceptTCli $ nodeSubmitTx nodeSocketPath network genTx diff --git a/cardano-cli/src/Cardano/CLI/Byron/Vote.hs b/cardano-cli/src/Cardano/CLI/Byron/Vote.hs index 10c99d15b2..6dea978de1 100644 --- a/cardano-cli/src/Cardano/CLI/Byron/Vote.hs +++ b/cardano-cli/src/Cardano/CLI/Byron/Vote.hs @@ -52,7 +52,7 @@ submitByronVote submitByronVote nodeSocketPath network voteFp = do vote <- readByronVote voteFp let genTx = toByronLedgertoByronVote vote - traceWith stdoutTracer ("Vote TxId: " ++ condense (txId genTx)) + liftIO $ traceWith stdoutTracer ("Vote TxId: " ++ condense (txId genTx)) fromExceptTCli $ nodeSubmitTx nodeSocketPath network genTx readByronVote :: FilePath -> CIO e ByronVote diff --git a/cardano-cli/src/Cardano/CLI/EraIndependent/Cip/Cip129/Run.hs b/cardano-cli/src/Cardano/CLI/EraIndependent/Cip/Cip129/Run.hs index 2c231cc6b3..78c5b6635c 100644 --- a/cardano-cli/src/Cardano/CLI/EraIndependent/Cip/Cip129/Run.hs +++ b/cardano-cli/src/Cardano/CLI/EraIndependent/Cip/Cip129/Run.hs @@ -22,7 +22,6 @@ import Data.ByteString (ByteString) import Data.ByteString qualified as BS import Data.ByteString.Char8 qualified as BSC import Data.Text.Encoding qualified as Text -import Data.Validation qualified as Valid import System.IO runCip129 :: Cip129 -> CIO e () @@ -32,9 +31,9 @@ runCip129 (Cip129DRep inp out) = do f <- liftIO $ fileOrPipe textEnvFp fromEitherIOCli $ readDrepVerificationKeyFile f InputHexText t -> do - fromEitherCli . Valid.toEither $ readDRepHexVerificationKeyText t + fromEitherCli . toEither $ readDRepHexVerificationKeyText t InputBech32Text t -> do - fromEitherCli . Valid.toEither $ readDRepBech32VerificationKeyText t + fromEitherCli . toEither $ readDRepBech32VerificationKeyText t let cip129Output = Text.encodeUtf8 $ encodeCip129DrepVerficationKeyText k renderOutput cip129Output out runCip129 (Cip129CommitteeHotKey inp out) = do @@ -43,9 +42,9 @@ runCip129 (Cip129CommitteeHotKey inp out) = do f <- liftIO $ fileOrPipe textEnvFp fromEitherIOCli $ readCommitteeHotVerificationKeyFile f InputHexText t -> - fromEitherCli . Valid.toEither $ readCommitteeHotHexVerificationKeyText t + fromEitherCli . toEither $ readCommitteeHotHexVerificationKeyText t InputBech32Text t -> - fromEitherCli . Valid.toEither $ readCommitteeHotBech32VerificationKeyText t + fromEitherCli . toEither $ readCommitteeHotBech32VerificationKeyText t let cip129Output = Text.encodeUtf8 $ encodeCip129CommitteeHotVerficationKeyText k renderOutput cip129Output out runCip129 (Cip129CommitteeColdKey inp out) = do @@ -54,9 +53,9 @@ runCip129 (Cip129CommitteeColdKey inp out) = do f <- liftIO $ fileOrPipe textEnvFp fromEitherIOCli $ readCommitteeColdVerificationKeyFile f InputHexText t -> - fromEitherCli . Valid.toEither $ readCommitteeColdHexVerificationKeyText t + fromEitherCli . toEither $ readCommitteeColdHexVerificationKeyText t InputBech32Text t -> - fromEitherCli . Valid.toEither $ readCommitteeColdBech32VerificationKeyText t + fromEitherCli . toEither $ readCommitteeColdBech32VerificationKeyText t let cip129Output = Text.encodeUtf8 $ encodeCip129CommitteeColdVerficationKeyText k renderOutput cip129Output out runCip129 (Cip129GovernanceAction inp out) = diff --git a/cardano-cli/src/Cardano/CLI/EraIndependent/Debug/LogEpochState/Run.hs b/cardano-cli/src/Cardano/CLI/EraIndependent/Debug/LogEpochState/Run.hs index 61093b9505..a786fbc52d 100644 --- a/cardano-cli/src/Cardano/CLI/EraIndependent/Debug/LogEpochState/Run.hs +++ b/cardano-cli/src/Cardano/CLI/EraIndependent/Debug/LogEpochState/Run.hs @@ -15,6 +15,11 @@ import Cardano.CLI.Orphan () import Data.Aeson qualified as Aeson import Data.ByteString.Lazy qualified as LBS +import System.Directory (makeAbsolute) +import System.FS.API (SomeHasFS (..)) +import System.FS.API.Types (MountPoint (MountPoint)) +import System.FS.IO (ioHasFS) +import System.FilePath (takeDirectory) import System.IO qualified as IO runLogEpochStateCmd @@ -28,9 +33,13 @@ runLogEpochStateCmd } = do LBS.appendFile outputFilePath "" + configDir <- takeDirectory <$> makeAbsolute (unFile configurationFile) + let fs = SomeHasFS (ioHasFS (MountPoint configDir)) + result <- runExceptT $ foldEpochState + fs configurationFile nodeSocketPath Api.QuickValidation diff --git a/cardano-cli/src/Cardano/CLI/EraIndependent/Ping/Run.hs b/cardano-cli/src/Cardano/CLI/EraIndependent/Ping/Run.hs index de66b74651..596d3540bf 100644 --- a/cardano-cli/src/Cardano/CLI/EraIndependent/Ping/Run.hs +++ b/cardano-cli/src/Cardano/CLI/EraIndependent/Ping/Run.hs @@ -19,7 +19,7 @@ import Control.Concurrent.Class.MonadSTM.Strict qualified as STM import Control.Exception (SomeException) import Control.Monad (forM, unless) import Control.Monad.Class.MonadAsync (MonadAsync (async, wait, waitCatch)) -import Control.Tracer (Tracer (..)) +import Control.Tracer (Tracer, mkTracer) import Data.List qualified as L import Data.List qualified as List import Network.Socket (AddrInfo) @@ -96,7 +96,7 @@ runPingCmd options = do -- Ping client thread handles caids <- forM addresses $ - liftIO . async . pingClient (Tracer $ doLog msgQueue) (Tracer doErrLog) options versions + liftIO . async . pingClient (mkTracer $ doLog msgQueue) (mkTracer doErrLog) options versions res <- L.zip addresses <$> mapM (liftIO . waitCatch) caids liftIO $ doLog msgQueue CNP.LogEnd liftIO $ wait laid diff --git a/cardano-cli/src/Cardano/CLI/Orphan.hs b/cardano-cli/src/Cardano/CLI/Orphan.hs index 4a81e7c75c..ec8a8112c7 100644 --- a/cardano-cli/src/Cardano/CLI/Orphan.hs +++ b/cardano-cli/src/Cardano/CLI/Orphan.hs @@ -15,7 +15,6 @@ import Cardano.Api.Experimental as Exp import Cardano.Api.Ledger qualified as L import Cardano.CLI.Type.Error.ScriptDecodeError -import Cardano.Ledger.Conway.Governance qualified as L import Cardano.Ledger.Conway.State qualified as L import Control.Exception @@ -24,13 +23,6 @@ import Data.List qualified as List import Data.Typeable import Data.Word -instance ToJSON L.DefaultVote where - toJSON defaultVote = - case defaultVote of - L.DefaultNo -> String "DefaultNo" - L.DefaultAbstain -> String "DefaultAbstain" - L.DefaultNoConfidence -> String "DefaultNoConfidence" - instance Error [Bech32DecodeError] where prettyError errs = vsep $ map prettyError errs diff --git a/cardano-cli/src/Cardano/CLI/Read.hs b/cardano-cli/src/Cardano/CLI/Read.hs index 93d64b2605..7e11c21e51 100644 --- a/cardano-cli/src/Cardano/CLI/Read.hs +++ b/cardano-cli/src/Cardano/CLI/Read.hs @@ -91,6 +91,8 @@ module Cardano.CLI.Read -- * utilities , readerFromParsecParser + , liftError + , toEither ) where @@ -134,6 +136,7 @@ import Data.Text qualified as T import Data.Text qualified as Text import Data.Text.Encoding qualified as Text import Data.Text.Encoding.Error qualified as Text +import Data.Validation (Validation (Failure, Success)) import GHC.IO.Handle (hClose, hIsSeekable) import GHC.IO.Handle.FD (openFileBlocking) import GHC.Stack @@ -819,6 +822,16 @@ readFileCli = withFrozenCallStack . readFileBinary readerFromParsecParser :: P.Parser a -> Opt.ReadM a readerFromParsecParser p = Opt.eitherReader (P.runParser p . T.pack) +liftError :: (e -> e') -> Either e a -> Validation e' a +liftError f = \case + Left e -> Failure (f e) + Right a -> Success a + +toEither :: Validation e a -> Either e a +toEither = \case + Failure e -> Left e + Success a -> Right a + -- TODO: Update to handle hex script bytes directly as well! readFilePlutusScript :: forall e era From 97968170496036b6c136530161cf1beff8e44412 Mon Sep 17 00:00:00 2001 From: Fabrizio Ferrai Date: Tue, 16 Jun 2026 18:37:22 +0200 Subject: [PATCH 2/4] Use latest network --- cabal.project | 8 +- cardano-cli/cardano-cli.cabal | 6 +- .../CLI/EraBased/Transaction/Option.hs | 44 ++--- .../Cardano/CLI/EraIndependent/Ping/Option.hs | 2 +- .../Cardano/CLI/EraIndependent/Ping/Run.hs | 153 +++++------------- cardano-cli/src/Cardano/CLI/Option.hs | 9 +- cardano-cli/src/Cardano/CLI/Render.hs | 88 +++++----- 7 files changed, 119 insertions(+), 191 deletions(-) diff --git a/cabal.project b/cabal.project index b2daa4ee24..932878a7b6 100644 --- a/cabal.project +++ b/cabal.project @@ -135,8 +135,8 @@ source-repository-package source-repository-package type: git location: https://github.com/f-f/kes-agent.git - tag: 0b362519f6915841c92869ed288ce83f89b17b73 - --sha256: sha256-8pZYF7MJZZ1tM19wIUhbLKORDL+OP2ckhueWJM4aG/c= + tag: fdb4f4db05e3744ed413f83477020fdf43cf32a2 + --sha256: sha256-eyQc8Dk7+upSRQvH5eXZuj6asYhOLsH59ABJZDyvQ6I= subdir: kes-agent kes-agent-crypto @@ -152,8 +152,8 @@ source-repository-package source-repository-package type: git location: https://github.com/IntersectMBO/ouroboros-network.git - tag: 10e173b21a82f6142261f0f38da0ec14c8b8a91c - --sha256: sha256-l3lpFzcFj2xiKaj54A7Rvhuu3s6EtzIboaHyuGhBhG8= + tag: 1db937ff3acd9c5862af8bf7b30900a701e8dd46 + --sha256: sha256-P/9vK8PwRAp+ORGMeU5UUTDMotlUXFcqNXUReX5CQDw= subdir: ./cardano-diffusion ./monoidal-synchronisation diff --git a/cardano-cli/cardano-cli.cabal b/cardano-cli/cardano-cli.cabal index 246daff998..5fe34661d9 100644 --- a/cardano-cli/cardano-cli.cabal +++ b/cardano-cli/cardano-cli.cabal @@ -273,15 +273,13 @@ library http-client, http-client-tls, http-types, - io-classes, - io-classes:strict-stm, iproute, microlens, mmorph, mtl, network, network-uri, - optparse-applicative-fork, + optparse-applicative, ordered-containers, prettyprinter, prettyprinter-ansi-terminal, @@ -311,7 +309,7 @@ executable cardano-cli cardano-api, cardano-cli, cardano-crypto-class, - optparse-applicative-fork, + optparse-applicative, rio, terminal-size, diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Transaction/Option.hs b/cardano-cli/src/Cardano/CLI/EraBased/Transaction/Option.hs index 424a55915d..f290aea1f6 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Transaction/Option.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Transaction/Option.hs @@ -30,7 +30,7 @@ import Data.Time.Clock.POSIX (posixSecondsToUTCTime) import Data.Universe (Some) import Options.Applicative hiding (help, str) import Options.Applicative qualified as Opt -import Options.Applicative.Help qualified as H +-- import Options.Applicative.Help qualified as H import Prettyprinter (line) pTransactionCmds @@ -55,13 +55,13 @@ pTransactionCmds envCli = [ pretty @String "Build a transaction (low-level, inconvenient)" , line , line - , H.yellow $ - mconcat - [ "Please note " - , H.underline "the order" - , " of some cmd options is crucial. If used incorrectly may produce " - , "undesired tx body. See nested [] notation above for details." - ] + -- , H.yellow $ + -- mconcat + -- [ "Please note " + -- , H.underline "the order" + -- , " of some cmd options is crucial. If used incorrectly may produce " + -- , "undesired tx body. See nested [] notation above for details." + -- ] ] , pTransactionBuildCmd envCli , pTransactionBuildEstimateCmd envCli @@ -179,13 +179,13 @@ pTransactionBuildCmd envCli = do [ pretty @String "Build a balanced transaction (automatically calculates fees)" , line , line - , H.yellow $ - mconcat - [ "Please note " - , H.underline "the order" - , " of some cmd options is crucial. If used incorrectly may produce " - , "undesired tx body. See nested [] notation above for details." - ] + -- , H.yellow $ + -- mconcat + -- [ "Please note " + -- , H.underline "the order" + -- , " of some cmd options is crucial. If used incorrectly may produce " + -- , "undesired tx body. See nested [] notation above for details." + -- ] ] where pCmd era' = do @@ -243,13 +243,13 @@ pTransactionBuildEstimateCmd _envCli = do "Build a balanced transaction without access to a live node (automatically estimates fees)" , line , line - , H.yellow $ - mconcat - [ "Please note " - , H.underline "the order" - , " of some cmd options is crucial. If used incorrectly may produce " - , "undesired tx body. See nested [] notation above for details." - ] + -- , H.yellow $ + -- mconcat + -- [ "Please note " + -- , H.underline "the order" + -- , " of some cmd options is crucial. If used incorrectly may produce " + -- , "undesired tx body. See nested [] notation above for details." + -- ] ] where pCmd :: Parser (TransactionCmds era) diff --git a/cardano-cli/src/Cardano/CLI/EraIndependent/Ping/Option.hs b/cardano-cli/src/Cardano/CLI/EraIndependent/Ping/Option.hs index 5ec4a81d58..6743ebaddf 100644 --- a/cardano-cli/src/Cardano/CLI/EraIndependent/Ping/Option.hs +++ b/cardano-cli/src/Cardano/CLI/EraIndependent/Ping/Option.hs @@ -80,7 +80,7 @@ pPing = , Opt.short 'm' , Opt.metavar "MAGIC" , Opt.help "Network magic." - , Opt.value CNP.mainnetMagic + , Opt.value (CNP.unNetworkMagic CNP.mainnetMagic) ] ) <*> ( Opt.switch $ diff --git a/cardano-cli/src/Cardano/CLI/EraIndependent/Ping/Run.hs b/cardano-cli/src/Cardano/CLI/EraIndependent/Ping/Run.hs index 596d3540bf..7e00b51eaa 100644 --- a/cardano-cli/src/Cardano/CLI/EraIndependent/Ping/Run.hs +++ b/cardano-cli/src/Cardano/CLI/EraIndependent/Ping/Run.hs @@ -1,10 +1,8 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE RankNTypes #-} module Cardano.CLI.EraIndependent.Ping.Run - ( PingClientCmdError (..) - , renderPingClientCmdError - , runPingCmd + ( runPingCmd ) where @@ -14,118 +12,51 @@ import Cardano.CLI.Compatible.Exception import Cardano.CLI.EraIndependent.Ping.Command import Cardano.Network.Ping qualified as CNP -import Control.Concurrent.Class.MonadSTM.Strict (StrictTMVar) -import Control.Concurrent.Class.MonadSTM.Strict qualified as STM -import Control.Exception (SomeException) -import Control.Monad (forM, unless) -import Control.Monad.Class.MonadAsync (MonadAsync (async, wait, waitCatch)) -import Control.Tracer (Tracer, mkTracer) -import Data.List qualified as L -import Data.List qualified as List -import Network.Socket (AddrInfo) -import Network.Socket qualified as Socket -import System.Exit qualified as IO -import System.IO qualified as IO +import Data.IP qualified as IP +import Text.Read (readMaybe) -data PingClientCmdError - = PingClientCmdError [(AddrInfo, SomeException)] - | PingClientMisconfigurationError String +newtype PingClientCmdError = PingClientMisconfigurationError String deriving Show instance Error PingClientCmdError where prettyError = renderPingClientCmdError -maybeHostEndPoint :: EndPoint -> Maybe String -maybeHostEndPoint = \case - HostEndPoint host -> Just host - UnixSockEndPoint _ -> Nothing - -maybeUnixSockEndPoint :: EndPoint -> Maybe String -maybeUnixSockEndPoint = \case - HostEndPoint _ -> Nothing - UnixSockEndPoint sock -> Just sock - -pingClient - :: Tracer IO CNP.LogMsg -> Tracer IO String -> PingCmd -> [CNP.NodeVersion] -> AddrInfo -> IO () -pingClient stdout stderr cmd = CNP.pingClient stdout stderr opts - where - opts = - CNP.PingOpts - { CNP.pingOptsQuiet = pingCmdQuiet cmd - , CNP.pingOptsJson = pingCmdJson cmd - , CNP.pingOptsCount = pingCmdCount cmd - , CNP.pingOptsHost = maybeHostEndPoint (pingCmdEndPoint cmd) - , CNP.pingOptsUnixSock = maybeUnixSockEndPoint (pingCmdEndPoint cmd) - , CNP.pingOptsPort = pingCmdPort cmd - , CNP.pingOptsMagic = pingCmdMagic cmd - , CNP.pingOptsHandshakeQuery = pingOptsHandshakeQuery cmd - , CNP.pingOptsGetTip = pingOptsGetTip cmd - } +renderPingClientCmdError :: PingClientCmdError -> Doc ann +renderPingClientCmdError (PingClientMisconfigurationError err) = pretty err runPingCmd :: PingCmd -> CIO e () -runPingCmd options - | Just err <- getConfigurationError options = - throwCliError $ PingClientMisconfigurationError err -runPingCmd options = do - let hints = Socket.defaultHints{Socket.addrSocketType = Socket.Stream} - - msgQueue <- liftIO STM.newEmptyTMVarIO - - -- 'addresses' are all the endpoints to connect to and 'versions' are the node protocol versions - -- to ping with. - (addresses, versions) <- case pingCmdEndPoint options of - HostEndPoint host -> do - addrs <- liftIO $ Socket.getAddrInfo (Just hints) (Just host) (Just (pingCmdPort options)) - return (addrs, CNP.supportedNodeToNodeVersions $ pingCmdMagic options) - UnixSockEndPoint fname -> do - let addr = - Socket.AddrInfo - [] - Socket.AF_UNIX - Socket.Stream - Socket.defaultProtocol - (Socket.SockAddrUnix fname) - Nothing - return ([addr], CNP.supportedNodeToClientVersions $ pingCmdMagic options) - - -- Logger async thread handle - laid <- - liftIO . async $ - CNP.logger msgQueue (pingCmdJson options) (pingOptsHandshakeQuery options) (pingOptsGetTip options) - - -- Ping client thread handles - caids <- - forM addresses $ - liftIO . async . pingClient (mkTracer $ doLog msgQueue) (mkTracer doErrLog) options versions - res <- L.zip addresses <$> mapM (liftIO . waitCatch) caids - liftIO $ doLog msgQueue CNP.LogEnd - liftIO $ wait laid - - -- Collect errors 'es' from failed pings and 'addrs' from successful pings. - let (es, addrs) = L.foldl' partition ([], []) res - - -- Report any errors - case (es, addrs) of - ([], _) -> liftIO IO.exitSuccess - (_, []) -> throwCliError $ PingClientCmdError es - (_, _) -> do - unless (pingCmdQuiet options) $ mapM_ (liftIO . IO.hPrint IO.stderr) es - liftIO IO.exitSuccess - where - partition - :: ([(AddrInfo, SomeException)], [AddrInfo]) - -> (AddrInfo, Either SomeException ()) - -> ([(AddrInfo, SomeException)], [AddrInfo]) - partition (es, as) (a, Left e) = ((a, e) : es, as) - partition (es, as) (a, Right _) = (es, a : as) - - doLog :: StrictTMVar IO CNP.LogMsg -> CNP.LogMsg -> IO () - doLog msgQueue msg = STM.atomically $ STM.putTMVar msgQueue msg - - doErrLog :: String -> IO () - doErrLog = IO.hPutStrLn IO.stderr - -renderPingClientCmdError :: PingClientCmdError -> Doc ann -renderPingClientCmdError = \case - PingClientCmdError es -> mconcat $ List.intersperse "\n" $ pshow <$> es - PingClientMisconfigurationError err -> pretty err +runPingCmd cmd + | Just err <- getConfigurationError cmd = + throwCliError (PingClientMisconfigurationError err) + | otherwise = + -- TODO(network): CNP.pingClients does its own output and exit handling, maybe we want to expose that? + liftIO (CNP.pingClients (toPingOpts cmd) [toAddress cmd]) + +toPingOpts :: PingCmd -> CNP.PingOpts +toPingOpts cmd = + CNP.PingOpts + { CNP.pingOptsCount = pingCmdCount cmd + , CNP.pingOptsMagic = CNP.NetworkMagic (pingCmdMagic cmd) + , CNP.pingOptsJson = if pingCmdJson cmd then CNP.AsJSON else CNP.AsText + , CNP.pingOptsQuiet = pingCmdQuiet cmd + , CNP.pingOptsMode = + if pingOptsGetTip cmd + then CNP.TipMode + else + if pingOptsHandshakeQuery cmd + then CNP.QueryMode + else CNP.PingMode + , -- cardano-cli has no flags for these yet, so use network's own defaults. + CNP.pingOptsSRVPrefix = "_cardano._tcp" + , CNP.pingOptsColor = CNP.ColorAuto + } + +toAddress :: PingCmd -> CNP.Address (CNP.Unresolved CNP.SRVOrFilePathUnresolved) +toAddress cmd = + case pingCmdEndPoint cmd of + UnixSockEndPoint path -> CNP.FilePathOrDomain path + -- TODO(network): we could export a parseAddress :: String -> Either String (Address ...) + HostEndPoint host -> + case (readMaybe host :: Maybe IP.IP, readMaybe (pingCmdPort cmd) :: Maybe Word) of + (Just ip, Just port) -> CNP.IP ip port + _ -> CNP.FilePathOrDomain (host <> ":" <> pingCmdPort cmd) diff --git a/cardano-cli/src/Cardano/CLI/Option.hs b/cardano-cli/src/Cardano/CLI/Option.hs index 328f78722f..0c491c0f4d 100644 --- a/cardano-cli/src/Cardano/CLI/Option.hs +++ b/cardano-cli/src/Cardano/CLI/Option.hs @@ -25,13 +25,14 @@ import Cardano.CLI.EraIndependent.Node.Option import Cardano.CLI.EraIndependent.Ping.Option (parsePingCmd) import Cardano.CLI.Legacy.Option (parseLegacyCmds) import Cardano.CLI.Parser -import Cardano.CLI.Render (customRenderHelp) +-- import Cardano.CLI.Render (customRenderHelp) import Cardano.CLI.Run (ClientCommand (..)) import Data.Foldable import Options.Applicative import Options.Applicative qualified as Opt -import Prettyprinter qualified as PP + +-- import Prettyprinter qualified as PP opts :: EnvCli -> ParserInfo ClientCommand opts envCli = @@ -51,8 +52,8 @@ pref = Opt.prefs $ mconcat [ showHelpOnEmpty - , helpEmbedBriefDesc PP.align - , helpRenderHelp customRenderHelp + -- , helpEmbedBriefDesc PP.align + -- , helpRenderHelp customRenderHelp ] addressCmdsTopLevel :: EnvCli -> Parser ClientCommand diff --git a/cardano-cli/src/Cardano/CLI/Render.hs b/cardano-cli/src/Cardano/CLI/Render.hs index d3043fd4ae..69c8b2a563 100644 --- a/cardano-cli/src/Cardano/CLI/Render.hs +++ b/cardano-cli/src/Cardano/CLI/Render.hs @@ -4,61 +4,59 @@ module Cardano.CLI.Render ) where -import Cardano.Api (textShow) - import Data.Text (Text) -import Data.Text qualified as T import Options.Applicative -import Options.Applicative.Help.Ann -import Options.Applicative.Help.Types (helpText, renderHelp) +import Options.Applicative.Help.Types (renderHelp) import Prettyprinter -import Prettyprinter.Render.Util.SimpleDocTree -import System.Environment qualified as IO -import System.IO.Unsafe qualified as IO -cliHelpTraceEnabled :: Bool -cliHelpTraceEnabled = IO.unsafePerformIO $ do - mValue <- IO.lookupEnv "CLI_HELP_TRACE" - return $ mValue == Just "1" -{-# NOINLINE cliHelpTraceEnabled #-} +-- import Cardano.Api (textShow) +-- import Data.Text qualified as T +-- import Options.Applicative.Help.Ann +-- import Options.Applicative.Help.Types (helpText) +-- import Prettyprinter.Render.Util.SimpleDocTree +-- import System.Environment qualified as IO +-- import System.IO.Unsafe qualified as IO +-- +-- cliHelpTraceEnabled :: Bool +-- cliHelpTraceEnabled = IO.unsafePerformIO $ do +-- mValue <- IO.lookupEnv "CLI_HELP_TRACE" +-- return $ mValue == Just "1" +-- {-# NOINLINE cliHelpTraceEnabled #-} +-- -- | Convert a help text to 'String'. When the CLI_HELP_TRACE environment variable is set -- to '1', the output will be in HTML so that it can be viewed in a browser where developer -- tools can be used to inspect tracing that aids in describing the structure of the output -- document. +-- customRenderHelpAsHtml :: Int -> ParserHelp -> String +-- customRenderHelpAsHtml cols = +-- T.unpack +-- . wrapper +-- . renderSimplyDecorated id renderElement +-- . treeForm +-- . layoutSmart (LayoutOptions (AvailablePerLine cols 1.0)) +-- . helpText +-- where +-- renderElement :: Ann -> Text -> Text +-- renderElement ann x = +-- if cliHelpTraceEnabled +-- then case ann of +-- AnnTrace _ name -> "" <> x <> "" +-- AnnStyle _ -> x +-- else x +-- wrapper = +-- if cliHelpTraceEnabled +-- then +-- id +-- . ("\n" <>) +-- . ("\n" <>) +-- . ("
\n" <>)
+--           . (<> "\n")
+--           . (<> "\n")
+--           . (<> "\n
") +-- else id customRenderHelp :: Int -> ParserHelp -> String -customRenderHelp = - if cliHelpTraceEnabled - then customRenderHelpAsHtml - else customRenderHelpAsAnsi - -customRenderHelpAsHtml :: Int -> ParserHelp -> String -customRenderHelpAsHtml cols = - T.unpack - . wrapper - . renderSimplyDecorated id renderElement - . treeForm - . layoutSmart (LayoutOptions (AvailablePerLine cols 1.0)) - . helpText - where - renderElement :: Ann -> Text -> Text - renderElement ann x = - if cliHelpTraceEnabled - then case ann of - AnnTrace _ name -> "" <> x <> "" - AnnStyle _ -> x - else x - wrapper = - if cliHelpTraceEnabled - then - id - . ("\n" <>) - . ("\n" <>) - . ("
\n" <>)
-          . (<> "\n")
-          . (<> "\n")
-          . (<> "\n
") - else id +customRenderHelp = customRenderHelpAsAnsi customRenderHelpAsAnsi :: Int -> ParserHelp -> String customRenderHelpAsAnsi = renderHelp From c8c4e4abd374e94a9496483cd003112f0d95a903 Mon Sep 17 00:00:00 2001 From: Fabrizio Ferrai Date: Wed, 17 Jun 2026 15:42:30 +0200 Subject: [PATCH 3/4] WIP new network --- cabal.project | 4 +- cardano-cli/cardano-cli.cabal | 1 + .../Cardano/CLI/EraIndependent/Ping/Run.hs | 117 ++++++++++++++---- 3 files changed, 97 insertions(+), 25 deletions(-) diff --git a/cabal.project b/cabal.project index 932878a7b6..b967214d0c 100644 --- a/cabal.project +++ b/cabal.project @@ -152,8 +152,8 @@ source-repository-package source-repository-package type: git location: https://github.com/IntersectMBO/ouroboros-network.git - tag: 1db937ff3acd9c5862af8bf7b30900a701e8dd46 - --sha256: sha256-P/9vK8PwRAp+ORGMeU5UUTDMotlUXFcqNXUReX5CQDw= + tag: 1881340e26ca98b3ee2b89ea536348406b79e051 + --sha256: sha256-O1Th+YI6LZqCLM6n75tVV+3InA4W8sC0yHEi09u8Fyw= subdir: ./cardano-diffusion ./monoidal-synchronisation diff --git a/cardano-cli/cardano-cli.cabal b/cardano-cli/cardano-cli.cabal index 5fe34661d9..416746deca 100644 --- a/cardano-cli/cardano-cli.cabal +++ b/cardano-cli/cardano-cli.cabal @@ -273,6 +273,7 @@ library http-client, http-client-tls, http-types, + io-classes, iproute, microlens, mmorph, diff --git a/cardano-cli/src/Cardano/CLI/EraIndependent/Ping/Run.hs b/cardano-cli/src/Cardano/CLI/EraIndependent/Ping/Run.hs index 7e00b51eaa..56c3227ab2 100644 --- a/cardano-cli/src/Cardano/CLI/EraIndependent/Ping/Run.hs +++ b/cardano-cli/src/Cardano/CLI/EraIndependent/Ping/Run.hs @@ -1,8 +1,10 @@ -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} module Cardano.CLI.EraIndependent.Ping.Run - ( runPingCmd + ( PingClientCmdError (..) + , renderPingClientCmdError + , runPingCmd ) where @@ -12,25 +14,71 @@ import Cardano.CLI.Compatible.Exception import Cardano.CLI.EraIndependent.Ping.Command import Cardano.Network.Ping qualified as CNP -import Data.IP qualified as IP -import Text.Read (readMaybe) +import Control.Exception (SomeException, toException) +import Control.Monad (unless) +import Control.Monad.Class.MonadAsync (mapConcurrently) +import Control.Tracer (mkTracer) +import Data.Aeson qualified as Aeson +import Data.Aeson.Text (encodeToLazyText) +import Data.List qualified as L +import Data.List qualified as List +import Data.Text qualified as T +import Data.Text.Lazy qualified as TL +import Data.Text.Lazy.IO qualified as TLIO +import Network.Socket (AddrInfo) +import Network.Socket qualified as Socket +import System.IO qualified as IO +import Text.Printf (printf) -newtype PingClientCmdError = PingClientMisconfigurationError String +data PingClientCmdError + = PingClientCmdError [(AddrInfo, SomeException)] + | PingClientMisconfigurationError String deriving Show instance Error PingClientCmdError where prettyError = renderPingClientCmdError -renderPingClientCmdError :: PingClientCmdError -> Doc ann -renderPingClientCmdError (PingClientMisconfigurationError err) = pretty err - runPingCmd :: PingCmd -> CIO e () -runPingCmd cmd - | Just err <- getConfigurationError cmd = - throwCliError (PingClientMisconfigurationError err) - | otherwise = - -- TODO(network): CNP.pingClients does its own output and exit handling, maybe we want to expose that? - liftIO (CNP.pingClients (toPingOpts cmd) [toAddress cmd]) +runPingCmd options + | Just err <- getConfigurationError options = + throwCliError $ PingClientMisconfigurationError err +runPingCmd options = do + let hints = Socket.defaultHints{Socket.addrSocketType = Socket.Stream} + + addresses <- case pingCmdEndPoint options of + HostEndPoint host -> + liftIO $ Socket.getAddrInfo (Just hints) (Just host) (Just (pingCmdPort options)) + UnixSockEndPoint fname -> + pure + [ Socket.AddrInfo + [] + Socket.AF_UNIX + Socket.Stream + Socket.defaultProtocol + (Socket.SockAddrUnix fname) + Nothing + ] + + let stdout = mkTracer (TLIO.putStrLn . renderLogMsg (pingCmdJson options)) + stderr = mkTracer (IO.hPutStrLn IO.stderr . renderPingWarning) + + res <- + liftIO $ + mapConcurrently + (\addr -> (,) addr <$> CNP.pingClient stdout stderr (toPingOpts options) addr) + addresses + + case L.foldl' partition ([], []) res of + ([], _) -> pure () + (_, []) -> throwCliError $ PingClientCmdError es + (_, _) -> unless (pingCmdQuiet options) $ mapM_ (liftIO . IO.hPrint IO.stderr) es + where + partition + :: ([(AddrInfo, SomeException)], [AddrInfo]) + -> (AddrInfo, Either CNP.PingClientException ()) + -> ([(AddrInfo, SomeException)], [AddrInfo]) + partition (es, as) (a, Left e) = ((a, toException e) : es, as) + partition (es, as) (a, Right _) = (es, a : as) toPingOpts :: PingCmd -> CNP.PingOpts toPingOpts cmd = @@ -51,12 +99,35 @@ toPingOpts cmd = , CNP.pingOptsColor = CNP.ColorAuto } -toAddress :: PingCmd -> CNP.Address (CNP.Unresolved CNP.SRVOrFilePathUnresolved) -toAddress cmd = - case pingCmdEndPoint cmd of - UnixSockEndPoint path -> CNP.FilePathOrDomain path - -- TODO(network): we could export a parseAddress :: String -> Either String (Address ...) - HostEndPoint host -> - case (readMaybe host :: Maybe IP.IP, readMaybe (pingCmdPort cmd) :: Maybe Word) of - (Just ip, Just port) -> CNP.IP ip port - _ -> CNP.FilePathOrDomain (host <> ":" <> pingCmdPort cmd) +-- | Format a ping log message. Mirrors the network library's internal +-- @format@/@ToText@ helpers, which are not exported. +renderLogMsg :: Bool -> CNP.WithHost CNP.LogMsg -> TL.Text +renderLogMsg True msg = encodeToLazyText (Aeson.toJSON msg) +renderLogMsg False (CNP.WithHost host logMsg) = + TL.pack (printf "%-47s" (show host <> ", ")) <> renderLogMsgText logMsg + +renderLogMsgText :: CNP.LogMsg -> TL.Text +renderLogMsgText = \case + CNP.LogChainSyncTip tip -> TL.pack (show tip) + CNP.LogStatPoint point -> TL.pack (show point) + CNP.LogNodeToClientVersionData version versionData -> + TL.pack (unwords [show version, either T.unpack show versionData]) + CNP.LogNodeToNodeVersionData version versionData -> + TL.pack (unwords [show version, either T.unpack show versionData]) + +-- | Format a ping warning. Mirrors the network library's internal +-- @formatPingWarning@, which is not exported. +renderPingWarning :: CNP.PingWarning -> String +renderPingWarning = \case + CNP.FilePathDoesNotExist path -> "WARNING: file path " <> show path <> " does not exist" + CNP.DNSError domain err -> "WARNING: dns: " <> show domain <> " " <> show err + CNP.DNSResolution domain ips port -> + show domain <> ": " <> List.intercalate ", " [show ip <> ":" <> show port | ip <- ips] + CNP.MissingPort ip -> "WARNING: missing port for " <> show ip + CNP.Error err -> "WARNING: " <> show err + CNP.ConnectError sockAddr err -> "WARNING: " <> show sockAddr <> " " <> show err + +renderPingClientCmdError :: PingClientCmdError -> Doc ann +renderPingClientCmdError = \case + PingClientCmdError es -> mconcat $ List.intersperse "\n" $ pshow <$> es + PingClientMisconfigurationError err -> pretty err From 9678a844fd2b53bc3777906d61b53fe0ff93e8ed Mon Sep 17 00:00:00 2001 From: Fabrizio Ferrai Date: Wed, 17 Jun 2026 20:50:42 +0200 Subject: [PATCH 4/4] Typo --- cardano-cli/src/Cardano/CLI/EraIndependent/Ping/Run.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/cardano-cli/src/Cardano/CLI/EraIndependent/Ping/Run.hs b/cardano-cli/src/Cardano/CLI/EraIndependent/Ping/Run.hs index 56c3227ab2..8c0e8127ab 100644 --- a/cardano-cli/src/Cardano/CLI/EraIndependent/Ping/Run.hs +++ b/cardano-cli/src/Cardano/CLI/EraIndependent/Ping/Run.hs @@ -70,8 +70,8 @@ runPingCmd options = do case L.foldl' partition ([], []) res of ([], _) -> pure () - (_, []) -> throwCliError $ PingClientCmdError es - (_, _) -> unless (pingCmdQuiet options) $ mapM_ (liftIO . IO.hPrint IO.stderr) es + (es, []) -> throwCliError $ PingClientCmdError es + (es, _) -> unless (pingCmdQuiet options) $ mapM_ (liftIO . IO.hPrint IO.stderr) es where partition :: ([(AddrInfo, SomeException)], [AddrInfo])