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)