Replace cardano-diffusion's ping parser with a local flag-based parser

.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 command line interface is restored to exactly the pre-11.2 one — `--host`, `--unixsock`, `--port`, `--magic`, `--json`, `--quiet`, `--query-versions` and `--tip`, with `-h` again meaning `--host` — replacing the positional `ADDRS` argument and the `--mode`, `--srv-prefix`, `--color` and `--short-hash` options of the never-published 11.2.0.0 interface.

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
 

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

cardano-cli/src/Cardano/CLI/EraIndependent/Ping/Command.hs

@@ -1,12 +1,65 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE TypeApplications #-}
+
 module Cardano.CLI.EraIndependent.Ping.Command
-  ( PingCmd (..)
-  , Address
+  ( EndPoint (..)
+  , PingCmd (..)
+  , endPointToAddress
+  , getConfigurationError
   )
 where
 
-import Cardano.Network.Ping
+import Cardano.Network.Ping qualified as Ping
+
+import Data.IP (IP)
+import Text.Read (readMaybe)
+
+-- | The endpoint to ping, as given on the command line.
+data EndPoint
+  = HostEndPoint String
+  | UnixSockEndPoint String
+  deriving (Eq, Show)
 
 data PingCmd = PingCmd
-  { pingOpts :: PingOpts
-  , pingAddresses :: [Address (Unresolved SRVOrFilePathUnresolved)]
+  { pingOpts :: !Ping.PingOpts
+  , pingEndPoint :: !EndPoint
+  , pingPort :: !Word
   }
+
+-- | Same restriction as the pre-11.2 ping implementation: a unix socket
+-- speaks node-to-client, over which the keep-alive protocol (the default
+-- ping mode) does not run; 'Ping.pingClients' would silently do nothing.
+getConfigurationError :: PingCmd -> Maybe String
+getConfigurationError
+  PingCmd
+    { pingOpts = opts
+    , pingEndPoint = endPoint
+    } =
+    case endPoint of
+      UnixSockEndPoint{}
+        | Ping.pingOptsMode opts == Ping.PingMode ->
+            Just "Unix sockets only support queries for available versions or a tip."
+      _ -> Nothing
+
+-- | Convert the command line endpoint into a ping 'Ping.Address'.
+--
+-- 'Ping.mkAddress' only distinguishes SRV records from domain names/file
+-- paths, so IP literals are detected here and built with the 'Ping.IP'
+-- constructor directly, which spares a futile DNS lookup at runtime.
+endPointToAddress
+  :: Word
+  -- ^ port
+  -> EndPoint
+  -> Ping.Address (Ping.Unresolved Ping.SRVOrFilePathUnresolved)
+endPointToAddress port = \case
+  HostEndPoint host
+    -- an IPv4/IPv6 literal, e.g. 127.0.0.1 or ::1
+    | Just ip <- readMaybe @IP host -> Ping.IP ip port
+    -- a domain name: with the port attached, mkAddress classifies it as
+    -- a domain name (or file path) rather than an SRV record
+    | otherwise -> Ping.mkAddress (host <> ":" <> show port)
+  UnixSockEndPoint path
+    | '/' `elem` path -> Ping.mkAddress path
+    -- mkAddress would mistake a bare file name such as file.socket for
+    -- a domain name
+    | otherwise -> Ping.mkAddress ("./" <> path)

cardano-cli/src/Cardano/CLI/EraIndependent/Ping/Option.hs

@@ -2,16 +2,22 @@
 
 module Cardano.CLI.EraIndependent.Ping.Option
   ( parsePingCmd
+  , pPing
   )
 where
 
 import Cardano.CLI.Command (ClientCommand (CliPingCommand))
+import Cardano.CLI.EraBased.Common.Option (integralReader)
 import Cardano.CLI.EraIndependent.Ping.Command
 import Cardano.Network.Ping qualified as Ping
 
 import Control.Applicative
+import Data.IP (IP)
+import Data.Maybe (isJust)
+import Data.Word (Word32)
 import Options.Applicative qualified as Opt
 import Prettyprinter qualified as PP
+import Text.Read (readMaybe)
 
 parsePingCmd :: Opt.Mod Opt.CommandFields ClientCommand
 parsePingCmd =
@@ -24,5 +30,141 @@ parsePingCmd =
             , PP.pretty @String "It negotiates a handshake and keeps sending keep alive messages."
             ]
 
+pHost :: Opt.Parser String
+pHost =
+  Opt.option readHost $
+    mconcat
+      [ Opt.long "host"
+      , Opt.short 'h'
+      , Opt.metavar "HOST"
+      , Opt.help "Hostname/IP, e.g. relay.iohk.example."
+      ]
+ where
+  -- The port is given via --port. host:port forms never worked (they were
+  -- passed verbatim to getAddrInfo, which failed on them), so reject them
+  -- up front rather than let them fail confusingly at resolution time.
+  -- IPv6 literals such as ::1 legitimately contain colons.
+  readHost =
+    Opt.eitherReader $ \s ->
+      if ':' `notElem` s || isJust (readMaybe @IP s)
+        then Right s
+        else Left "HOST must not include a port, use --port instead"
+
+pUnixSocket :: Opt.Parser String
+pUnixSocket =
+  Opt.strOption $
+    mconcat
+      [ Opt.long "unixsock"
+      , Opt.short 'u'
+      , Opt.metavar "SOCKET"
+      , Opt.help "Unix socket, e.g. file.socket."
+      ]
+
+pEndPoint :: Opt.Parser EndPoint
+pEndPoint = fmap HostEndPoint pHost <|> fmap UnixSockEndPoint pUnixSocket
+
 pPing :: Opt.Parser PingCmd
-pPing = uncurry PingCmd <$> Ping.cmdlineParser
+pPing =
+  mkPingCmd
+    <$> ( Opt.option integralReader $
+            mconcat
+              [ Opt.long "count"
+              , Opt.short 'c'
+              , Opt.metavar "COUNT"
+              , Opt.help $
+                  mconcat
+                    [ "Stop after sending count requests and receiving count responses.  "
+                    , "If this option is not specified, ping will operate until interrupted.  "
+                    ]
+              , Opt.value maxBound
+              ]
+        )
+    <*> pEndPoint
+    <*> ( Opt.option integralReader $
+            mconcat
+              [ Opt.long "port"
+              , Opt.short 'p'
+              , Opt.metavar "PORT"
+              , Opt.help "Port number, e.g. 1234."
+              , Opt.value 3001
+              ]
+        )
+    <*> ( Opt.option (Ping.NetworkMagic <$> integralReader) $
+            mconcat
+              [ Opt.long "magic"
+              , Opt.short 'm'
+              , Opt.metavar "MAGIC"
+              , Opt.help "Network magic."
+              , Opt.value Ping.mainnetMagic
+              ]
+        )
+    <*> ( Opt.flag Ping.AsText Ping.AsJSON $
+            mconcat
+              [ Opt.long "json"
+              , Opt.short 'j'
+              , Opt.help "JSON output flag."
+              ]
+        )
+    <*> ( Opt.switch $
+            mconcat
+              [ Opt.long "quiet"
+              , Opt.short 'q'
+              , Opt.help "Quiet flag, CSV/JSON only output"
+              ]
+        )
+    <*> ( Opt.switch $
+            mconcat
+              [ Opt.long "query-versions"
+              , Opt.short 'Q'
+              , Opt.help
+                  "Query the supported protocol versions using the handshake protocol and terminate the connection."
+              ]
+        )
+    <*> ( Opt.switch $
+            mconcat
+              [ Opt.long "tip"
+              , Opt.short 't'
+              , Opt.help "Request tip then exit."
+              ]
+        )
+
+mkPingCmd
+  :: Word32
+  -- ^ count
+  -> EndPoint
+  -> Word
+  -- ^ port
+  -> Ping.NetworkMagic
+  -> Ping.LogFormat
+  -> Bool
+  -- ^ quiet
+  -> Bool
+  -- ^ query handshake versions
+  -> Bool
+  -- ^ request tip
+  -> PingCmd
+mkPingCmd count endPoint port magic json quiet query tip =
+  PingCmd
+    { pingOpts =
+        Ping.PingOpts
+          { Ping.pingOptsCount = count
+          , Ping.pingOptsMagic = magic
+          , Ping.pingOptsJson = json
+          , Ping.pingOptsQuiet = quiet
+          , Ping.pingOptsMode = mode
+          , -- The remaining ping library options are not exposed on the
+            -- command line, which is kept identical to the pre-11.2 one.
+            Ping.pingOptsSRVPrefix = "_cardano._tcp"
+          , Ping.pingOptsColor = Ping.ColorNever
+          , Ping.pingOptsHashType = Ping.FullHash
+          }
+    , pingEndPoint = endPoint
+    , pingPort = port
+    }
+ where
+  -- --query-versions takes precedence over --tip, matching the behaviour of
+  -- the old cardano-ping implementation
+  mode
+    | query = Ping.QueryMode
+    | tip = Ping.TipMode
+    | otherwise = Ping.PingMode

cardano-cli/src/Cardano/CLI/EraIndependent/Ping/Run.hs

@@ -2,16 +2,26 @@
 {-# LANGUAGE RankNTypes #-}
 
 module Cardano.CLI.EraIndependent.Ping.Run
-  ( runPingCmd
+  ( PingClientCmdError (..)
+  , runPingCmd
   )
 where
 
 import Cardano.Api
 
-import Cardano.CLI.Compatible.Exception (CIO)
+import Cardano.CLI.Compatible.Exception (CIO, throwCliError)
 import Cardano.CLI.EraIndependent.Ping.Command
 import Cardano.Network.Ping qualified as Ping
 
+newtype PingClientCmdError = PingClientMisconfigurationError String
+  deriving Show
+
+instance Error PingClientCmdError where
+  prettyError (PingClientMisconfigurationError err) = pretty err
+
 runPingCmd :: PingCmd -> CIO e ()
-runPingCmd PingCmd{pingOpts, pingAddresses} =
-  liftIO $ Ping.pingClients pingOpts pingAddresses
+runPingCmd cmd@PingCmd{pingOpts, pingEndPoint, pingPort} = do
+  case getConfigurationError cmd of
+    Just err -> throwCliError $ PingClientMisconfigurationError err
+    Nothing -> pure ()
+  liftIO $ Ping.pingClients pingOpts [endPointToAddress pingPort pingEndPoint]

cardano-cli/test/cardano-cli-golden/files/golden/help.cli

@@ -6145,14 +6145,13 @@ Usage: cardano-cli pretty-print-cbor --filepath FILEPATH
   Pretty print a CBOR file.
 
 Usage: cardano-cli ping [-c|--count COUNT]
-                          [-m|--network-magic MAGIC]
+                          ((-h|--host HOST) | (-u|--unixsock SOCKET))
+                          [-p|--port PORT]
+                          [-m|--magic MAGIC]
                           [-j|--json]
                           [-q|--quiet]
-                          [--mode MODE]
-                          [--srv-prefix SRV_PREFIX]
-                          [--color COLOR]
-                          [--short-hash]
-                          ADDRS
+                          [-Q|--query-versions]
+                          [-t|--tip]
 
 
   Ping a cardano node either using node-to-node or node-to-client protocol. It negotiates a handshake and keeps sending keep alive messages.

cardano-cli/test/cardano-cli-golden/files/golden/help/ping.cli

@@ -1,33 +1,26 @@
 Usage: cardano-cli ping [-c|--count COUNT]
-                          [-m|--network-magic MAGIC]
+                          ((-h|--host HOST) | (-u|--unixsock SOCKET))
+                          [-p|--port PORT]
+                          [-m|--magic MAGIC]
                           [-j|--json]
                           [-q|--quiet]
-                          [--mode MODE]
-                          [--srv-prefix SRV_PREFIX]
-                          [--color COLOR]
-                          [--short-hash]
-                          ADDRS
+                          [-Q|--query-versions]
+                          [-t|--tip]
 
 
   Ping a cardano node either using node-to-node or node-to-client protocol. It negotiates a handshake and keeps sending keep alive messages.
 
 Available options:
   -c,--count COUNT         Stop after sending count requests and receiving count
                            responses. If this option is not specified, ping will
-                           operate until interrupted. (default: 4294967295)
-  -m,--network-magic MAGIC Network magic. (default: 764824073)
+                           operate until interrupted.
+  -h,--host HOST           Hostname/IP, e.g. relay.iohk.example.
+  -u,--unixsock SOCKET     Unix socket, e.g. file.socket.
+  -p,--port PORT           Port number, e.g. 1234.
+  -m,--magic MAGIC         Network magic.
   -j,--json                JSON output flag.
-  -q,--quiet               Quiet flag, CSV/JSON only output.
-  --mode MODE              Mode, either ping, tip or query:
-                             ping  - send pings via keep-alive protocol (node-to-node only),
-                             tip   - query tip via chain-sync protocol (node-to-node / node-to-client),
-                             query - query handshake parameters (node-to-node / node-to-client).
-  --srv-prefix SRV_PREFIX  Prefix that will be added to an SRV service name
-                           (default: "_cardano._tcp")
-  --color COLOR            Colorized output: auto, never or always.
-                           (default: auto)
-  --short-hash             show short tip's hash
-  ADDRS                    List of IP/DNS/SRV address and ports or UNIX socket
-                           paths, e.g. 127.0.0.1:3001 [::1]:3001
-                           example.org:3001.
+  -q,--quiet               Quiet flag, CSV/JSON only output
+  -Q,--query-versions      Query the supported protocol versions using the
+                           handshake protocol and terminate the connection.
+  -t,--tip                 Request tip then exit.
   -h,--help                Show this help text