From 8d29779ab30c5a8a081cf974ea4f60dc7b95f006 Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Thu, 13 Aug 2026 10:22:09 -0400 Subject: [PATCH] Replace cardano-diffusion's ping parser with an identical local parser cardano-cli used Ping.cmdlineParser from cardano-diffusion:ping, which only type-checks when cardano-diffusion is built with its manual optparse-applicative-fork cabal flag. That flag was set via cabal.project, which does not ship with the sdist, so the released package was unbuildable with default flags (CHaP CI rejected 11.2.0.0). The parser is replaced with a verbatim local copy written against optparse-applicative-fork: same options, readers, defaults and help text, so the command line interface is unchanged. The cabal.project flag stanza is removed, and Test.Cli.Ping pins the parser's defaults, option readers, address classification and rejected command lines. --- ...dano-cli_jordan.millar_fix_ping_parser.yml | 9 + cabal.project | 3 - cardano-cli/cardano-cli.cabal | 3 + .../Cardano/CLI/EraIndependent/Ping/Option.hs | 179 +++++++++++++++++- .../test/cardano-cli-test/Test/Cli/Ping.hs | 148 +++++++++++++++ 5 files changed, 338 insertions(+), 4 deletions(-) create mode 100644 .changes/20260812_101216_cardano-cli_jordan.millar_fix_ping_parser.yml create mode 100644 cardano-cli/test/cardano-cli-test/Test/Cli/Ping.hs diff --git a/.changes/20260812_101216_cardano-cli_jordan.millar_fix_ping_parser.yml b/.changes/20260812_101216_cardano-cli_jordan.millar_fix_ping_parser.yml new file mode 100644 index 0000000000..be6214d61d --- /dev/null +++ b/.changes/20260812_101216_cardano-cli_jordan.millar_fix_ping_parser.yml @@ -0,0 +1,9 @@ +project: cardano-cli + +pr: 1413 + +kind: + - bugfix + +description: | + Fixed `cardano-cli ping`'s dependency on the command line parser of `cardano-diffusion:ping`, which made the released package unbuildable with default cabal flags (it required a manual `optparse-applicative-fork` cabal flag set via `cabal.project`, which does not ship with the sdist). The parser is replaced with a behaviourally identical local one; the command line interface is unchanged. diff --git a/cabal.project b/cabal.project index cf02f75ad7..a26e9b2d6d 100644 --- a/cabal.project +++ b/cabal.project @@ -56,9 +56,6 @@ package text package formatting flags: +no-double-conversion -package cardano-diffusion - flags: +optparse-applicative-fork - tests: True test-show-details: direct diff --git a/cardano-cli/cardano-cli.cabal b/cardano-cli/cardano-cli.cabal index 3bce7f3755..8a5ab58f6b 100644 --- a/cardano-cli/cardano-cli.cabal +++ b/cardano-cli/cardano-cli.cabal @@ -363,6 +363,7 @@ test-suite cardano-cli-test cardano-api:{cardano-api, gen}, cardano-cli, cardano-cli:cardano-cli-test-lib, + cardano-diffusion:ping, cardano-slotting, containers, directory, @@ -374,6 +375,7 @@ test-suite cardano-cli-test microlens-aeson, mmorph, monad-control, + optparse-applicative-fork, regex-tdfa, resourcet, tasty, @@ -407,6 +409,7 @@ test-suite cardano-cli-test Test.Cli.Json Test.Cli.MonadWarning Test.Cli.Parser + Test.Cli.Ping Test.Cli.Pioneers.Exercise1 Test.Cli.Pioneers.Exercise2 Test.Cli.Pioneers.Exercise3 diff --git a/cardano-cli/src/Cardano/CLI/EraIndependent/Ping/Option.hs b/cardano-cli/src/Cardano/CLI/EraIndependent/Ping/Option.hs index 021d821645..ce435a31b6 100644 --- a/cardano-cli/src/Cardano/CLI/EraIndependent/Ping/Option.hs +++ b/cardano-cli/src/Cardano/CLI/EraIndependent/Ping/Option.hs @@ -1,7 +1,9 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE TypeApplications #-} module Cardano.CLI.EraIndependent.Ping.Option ( parsePingCmd + , pPing ) where @@ -10,8 +12,11 @@ import Cardano.CLI.EraIndependent.Ping.Command import Cardano.Network.Ping qualified as Ping import Control.Applicative +import Data.IP (IP) import Options.Applicative qualified as Opt +import Options.Applicative.Help.Pretty qualified as Pretty import Prettyprinter qualified as PP +import Text.Read (readMaybe) parsePingCmd :: Opt.Mod Opt.CommandFields ClientCommand parsePingCmd = @@ -24,5 +29,177 @@ parsePingCmd = , PP.pretty @String "It negotiates a handshake and keeps sending keep alive messages." ] +-- | A local mirror of @Cardano.Network.Ping.cmdlineParser@ from +-- @cardano-diffusion:ping@, which cardano-cli used directly before. The +-- library parser is built against vanilla @optparse-applicative@ by default, +-- while cardano-cli uses @optparse-applicative-fork@; using it required +-- building @cardano-diffusion@ with a non-default cabal flag set via +-- @cabal.project@, which does not ship with the sdist. +-- +-- This parser must behave exactly like @cmdlineParser@; it is a verbatim +-- copy modulo qualification. 'Test.Cli.Ping' checks the equivalence of the +-- two parsers, and the golden help tests pin the rendered help text. pPing :: Opt.Parser PingCmd -pPing = uncurry PingCmd <$> Ping.cmdlineParser +pPing = PingCmd <$> pPingOpts <*> pPingAddresses + +-- | A copy of @Cardano.Network.Ping.pingOptsParser@. +pPingOpts :: Opt.Parser Ping.PingOpts +pPingOpts = + Ping.PingOpts + <$> Opt.option + Opt.auto + ( Opt.long "count" + <> Opt.short 'c' + <> Opt.help + ( mconcat + [ "Stop after sending count requests and receiving count responses. " + , "If this option is not specified, ping will operate until interrupted. " + ] + ) + <> Opt.metavar "COUNT" + <> Opt.value maxBound + <> Opt.showDefault + ) + <*> Opt.option + (Ping.NetworkMagic <$> Opt.auto) + ( Opt.long "network-magic" + <> Opt.short 'm' + <> Opt.help "Network magic." + <> Opt.value Ping.mainnetMagic + <> Opt.metavar "MAGIC" + <> Opt.showDefaultWith (show . Ping.unNetworkMagic) + ) + <*> Opt.flag + Ping.AsText + Ping.AsJSON + ( Opt.long "json" + <> Opt.short 'j' + <> Opt.help "JSON output flag." + ) + <*> Opt.flag + False + True + ( Opt.long "quiet" + <> Opt.short 'q' + <> Opt.help "Quiet flag, CSV/JSON only output." + ) + <*> Opt.option + pingMode + ( Opt.long "mode" + <> Opt.helpDoc + ( Just $ + Pretty.hang 2 $ + "Mode, either ping, tip or query:" + <> Pretty.softline + <> "ping - send pings via keep-alive protocol (node-to-node only)," + <> Pretty.softline + <> "tip - query tip via chain-sync protocol (node-to-node / node-to-client)," + <> Pretty.softline + <> "query - query handshake parameters (node-to-node / node-to-client)." + ) + <> Opt.value Ping.PingMode + <> Opt.metavar "MODE" + ) + <*> Opt.option + Opt.str + ( Opt.long "srv-prefix" + <> Opt.help "Prefix that will be added to an SRV service name" + <> Opt.value "_cardano._tcp" + <> Opt.metavar "SRV_PREFIX" + <> Opt.showDefault + ) + <*> Opt.option + colorMode + ( Opt.long "color" + <> Opt.help "Colorized output: auto, never or always." + <> Opt.value Ping.ColorAuto + <> Opt.metavar "COLOR" + <> Opt.showDefaultWith + ( \case + Ping.ColorAuto -> "auto" + Ping.ColorNever -> "never" + Ping.ColorAlways -> "always" + ) + ) + <*> Opt.flag + Ping.FullHash + Ping.ShortHash + ( Opt.long "short-hash" + <> Opt.help "show short tip's hash" + ) + where + pingMode :: Opt.ReadM Ping.PingMode + pingMode = + Opt.eitherReader $ \case + "tip" -> Right Ping.TipMode + "ping" -> Right Ping.PingMode + "query" -> Right Ping.QueryMode + _ -> Left "unexpected string" + + colorMode :: Opt.ReadM Ping.ColorMode + colorMode = + Opt.eitherReader $ \case + "auto" -> Right Ping.ColorAuto + "never" -> Right Ping.ColorNever + "always" -> Right Ping.ColorAlways + _ -> Left "expected auto, never or always" + +-- | A copy of @Cardano.Network.Ping.argParser@. +pPingAddresses :: Opt.Parser [Ping.Address (Ping.Unresolved Ping.SRVOrFilePathUnresolved)] +pPingAddresses = + some pAddress + where + pAddress :: Opt.Parser (Ping.Address (Ping.Unresolved Ping.SRVOrFilePathUnresolved)) + pAddress = + Opt.argument + ( uncurry Ping.IP <$> readIPv4AndPort + <|> uncurry Ping.IP <$> readIPv6AndPort + <|> readDomainNameOrFilePath + ) + ( Opt.help + "List of IP/DNS/SRV address and ports or UNIX socket paths, e.g. 127.0.0.1:3001 [::1]:3001 example.org:3001." + <> Opt.metavar "ADDRS" + ) + + -- note: `Read` instances for `IP`, `IPv4`, `IPv6` expect no trailing + -- characters after the address, thus we need to find the split position + -- first. + + -- parse IPv4 address and port in a form `127.0.0.1:3001` + readIPv4AndPort :: Opt.ReadM (IP, Word) + readIPv4AndPort = + Opt.eitherReader $ \s -> + case splitWith ':' s of + Nothing -> Left s + Just (addrStr, portStr) -> + maybe (Left s) Right $ + (,) + <$> readMaybe addrStr + <*> readMaybe portStr + + -- parse IPv6 address and port in a form `[::1]:3001` + readIPv6AndPort :: Opt.ReadM (IP, Word) + readIPv6AndPort = + Opt.eitherReader $ \s -> + case s of + ('[' : s') -> + case splitWith ']' s' of + Just (addrStr, ':' : portStr) -> + maybe (Left s) Right $ + (,) + <$> readMaybe addrStr + <*> readMaybe portStr + _ -> Left s + _ -> Left s + + readDomainNameOrFilePath + :: Opt.ReadM (Ping.Address (Ping.Unresolved Ping.SRVOrFilePathUnresolved)) + readDomainNameOrFilePath = Opt.eitherReader $ Right . Ping.mkAddress + + splitWith :: Char -> String -> Maybe (String, String) + splitWith c = go "" + where + go _ [] = Nothing + go acc (a : as) + | a == c = Just (reverse acc, as) + | otherwise = go (a : acc) as diff --git a/cardano-cli/test/cardano-cli-test/Test/Cli/Ping.hs b/cardano-cli/test/cardano-cli-test/Test/Cli/Ping.hs new file mode 100644 index 0000000000..2c57c79add --- /dev/null +++ b/cardano-cli/test/cardano-cli-test/Test/Cli/Ping.hs @@ -0,0 +1,148 @@ +-- | @cardano-cli ping@'s parser is a local mirror of +-- @Cardano.Network.Ping.cmdlineParser@ from @cardano-diffusion:ping@, which +-- it replaces (see 'Cardano.CLI.EraIndependent.Ping.Option.pPing'). These +-- tests pin the library parser's behaviour: defaults, option readers, +-- address parsing and rejected command lines. +module Test.Cli.Ping + ( hprop_ping_parser_options + , hprop_ping_parser_addresses + , hprop_ping_parser_failures + ) +where + +import Cardano.CLI.EraIndependent.Ping.Command (PingCmd (..)) +import Cardano.CLI.EraIndependent.Ping.Option (pPing) +import Cardano.Network.Ping qualified as Ping + +import Data.Maybe (isNothing) +import Data.Word (Word32) +import Options.Applicative qualified as Opt + +import Test.Cardano.CLI.Util (watchdogProp) + +import Hedgehog (Property, annotateShow, assert, (===)) +import Hedgehog.Extras (propertyOnce) + +-- | 'Ping.PingOpts' and 'Ping.HashType' have no 'Eq' or 'Show' instances, +-- so parse results are compared (and reported) through this projection. +data ProjectedOpts = ProjectedOpts + { count :: Word32 + , magic :: Word32 + , json :: Ping.LogFormat + , quiet :: Bool + , mode :: Ping.PingMode + , srvPrefix :: String + , color :: Ping.ColorMode + , shortHash :: Bool + } + deriving (Eq, Show) + +projectOpts :: Ping.PingOpts -> ProjectedOpts +projectOpts opts = + ProjectedOpts + { count = Ping.pingOptsCount opts + , magic = Ping.unNetworkMagic (Ping.pingOptsMagic opts) + , json = Ping.pingOptsJson opts + , quiet = Ping.pingOptsQuiet opts + , mode = Ping.pingOptsMode opts + , srvPrefix = Ping.pingOptsSRVPrefix opts + , color = Ping.pingOptsColor opts + , shortHash = + case Ping.pingOptsHashType opts of + Ping.ShortHash -> True + Ping.FullHash -> False + } + +parsePing :: [String] -> Maybe (ProjectedOpts, [String]) +parsePing args = do + cmd <- + Opt.getParseResult $ + Opt.execParserPure Opt.defaultPrefs (Opt.info pPing mempty) args + pure (projectOpts (pingOpts cmd), show <$> pingAddresses cmd) + +defaultOpts :: ProjectedOpts +defaultOpts = + ProjectedOpts + { count = maxBound + , magic = 764824073 -- mainnet magic + , json = Ping.AsText + , quiet = False + , mode = Ping.PingMode + , srvPrefix = "_cardano._tcp" + , color = Ping.ColorAuto + , shortHash = False + } + +-- | Execute me with: +-- @cabal test cardano-cli-test --test-options '-p "/ping parser options/"'@ +hprop_ping_parser_options :: Property +hprop_ping_parser_options = watchdogProp . propertyOnce $ do + parseOpts [] === Just defaultOpts + parseOpts ["--count", "7"] === Just defaultOpts{count = 7} + parseOpts ["-c", "7"] === Just defaultOpts{count = 7} + parseOpts ["--network-magic", "2"] === Just defaultOpts{magic = 2} + parseOpts ["-m", "2"] === Just defaultOpts{magic = 2} + parseOpts ["--json"] === Just defaultOpts{json = Ping.AsJSON} + parseOpts ["-j"] === Just defaultOpts{json = Ping.AsJSON} + parseOpts ["--quiet"] === Just defaultOpts{quiet = True} + parseOpts ["-q"] === Just defaultOpts{quiet = True} + parseOpts ["--mode", "ping"] === Just defaultOpts{mode = Ping.PingMode} + parseOpts ["--mode", "tip"] === Just defaultOpts{mode = Ping.TipMode} + parseOpts ["--mode", "query"] === Just defaultOpts{mode = Ping.QueryMode} + parseOpts ["--srv-prefix", "_test._tcp"] === Just defaultOpts{srvPrefix = "_test._tcp"} + parseOpts ["--color", "auto"] === Just defaultOpts{color = Ping.ColorAuto} + parseOpts ["--color", "never"] === Just defaultOpts{color = Ping.ColorNever} + parseOpts ["--color", "always"] === Just defaultOpts{color = Ping.ColorAlways} + parseOpts ["--short-hash"] === Just defaultOpts{shortHash = True} + where + parseOpts args = fst <$> parsePing (args <> ["127.0.0.1:3001"]) + +-- | Execute me with: +-- @cabal test cardano-cli-test --test-options '-p "/ping parser addresses/"'@ +hprop_ping_parser_addresses :: Property +hprop_ping_parser_addresses = watchdogProp . propertyOnce $ do + -- IP literals with a port parse to `IP` addresses + parseAddresses ["127.0.0.1:3001"] === Just ["IP 127.0.0.1 3001"] + parseAddresses ["[::1]:3001"] === Just ["IP ::1 3001"] + -- anything with a colon, slash or without a dot may be a domain with + -- a port or a file path, resolved at runtime + parseAddresses ["example.org:3001"] === Just ["FilePathOrDomain \"example.org:3001\""] + parseAddresses ["/tmp/node.socket"] === Just ["FilePathOrDomain \"/tmp/node.socket\""] + parseAddresses ["socket"] === Just ["FilePathOrDomain \"socket\""] + -- a dotted name without a port is looked up as an SRV record first + parseAddresses ["example.org"] === Just ["SRV \"example.org\""] + parseAddresses ["node.sock"] === Just ["SRV \"node.sock\""] + -- multiple addresses are accepted + parseAddresses ["127.0.0.1:3001", "example.org", "[::1]:3001"] + === Just ["IP 127.0.0.1 3001", "SRV \"example.org\"", "IP ::1 3001"] + where + parseAddresses args = snd <$> parsePing args + +-- | Execute me with: +-- @cabal test cardano-cli-test --test-options '-p "/ping parser failures/"'@ +hprop_ping_parser_failures :: Property +hprop_ping_parser_failures = watchdogProp . propertyOnce $ do + mapM_ + rejected + [ -- at least one address is required + [] + , ["--count", "7"] + , -- invalid option values + ["--mode", "bogus", "127.0.0.1:3001"] + , ["--color", "bogus", "127.0.0.1:3001"] + , ["--count", "bogus", "127.0.0.1:3001"] + , -- the pre-11.2 interface is gone + ["--host", "relay.iohk.example"] + , ["--unixsock", "node.socket"] + , ["-u", "node.socket"] + , ["--port", "3001", "127.0.0.1:3001"] + , ["--magic", "42", "127.0.0.1:3001"] + , ["--tip", "127.0.0.1:3001"] + , ["-t", "127.0.0.1:3001"] + , ["--query-versions", "127.0.0.1:3001"] + , ["-Q", "127.0.0.1:3001"] + ] + where + rejected args = do + annotateShow args + assert $ isNothing (parsePing args)