cardano-diffusion:ping integration

.changes/20260625_145525_cardano-cli_work_prepare_11_1.yml

@@ -0,0 +1,41 @@
+description: |-
+  new `cardano-cli ping` api
+
+  `cardano-cli ping` allows now to ping multiple servers, does domain name
+  resolution and supports SRV records (as specified in
+  https://cips.cardano.org/cip/CIP-0155)
+
+  Some examples:
+
+  Run a ping against two ip addresses, ipv4 & ipv6
+  ```bash
+  cardano-cli ping 127.0.0.1:3001 [::1]:3001
+  ```
+
+  Run a ping against a domain name:
+  ```bash
+  cardano-cli ping my.domain.com:3001
+  ```
+
+  Run a ping against an SRV domain.
+  According to CIP#0155 the SRV record needs to be registered at
+  `_cardano._tcp.srv.domain.com`
+  ```bash
+  cardano-cli ping srv.domain.com
+  ```
+
+  Run a ping against unix socket
+  ```bash
+  cardano-cli ping /var/run/cardano-node.socket
+  ```
+
+  `cardano-cli` ping has three modes of operation:
+
+  * ping mode: `--mode ping` (the default)
+  * tip mode  `--mode tip`
+  * query handshake parameters: `--mode query`
+kind:
+- breaking
+- feature
+pr: 1391
+project: cardano-cli

cabal.project

@@ -56,6 +56,9 @@ package text
 package formatting
   flags: +no-double-conversion
 
+package cardano-diffusion
+  flags: +optparse-applicative-fork
+
 tests: True
 test-show-details: direct
 
@@ -158,8 +161,8 @@ source-repository-package
 source-repository-package
   type: git
   location: https://github.com/IntersectMBO/ouroboros-network.git
-  tag: 8b4dcb898b64615f574a7fbdcf119f77c7fbc598
-  --sha256: sha256-t1tGV5uZwyKnSSCbaJJAteMYKnQYeO39hUUycMRuC2M=
+  tag: 613f8a13cc1c11b2568a627d6eb900058e355d30
+  --sha256: sha256-G5oVYskwZTc0EeFlQHE41xIjmFhMYV7VmX48kNGuc/c=
   subdir:
     ./cardano-diffusion
     ./monoidal-synchronisation

cardano-cli/cardano-cli.cabal

@@ -273,7 +273,6 @@ library
     http-client,
     http-client-tls,
     http-types,
-    io-classes,
     iproute,
     microlens,
     mmorph,

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

@@ -1,38 +1,12 @@
 module Cardano.CLI.EraIndependent.Ping.Command
-  ( EndPoint (..)
-  , PingCmd (..)
-  , getConfigurationError
+  ( PingCmd (..)
+  , Address
   )
 where
 
-import Data.Word
+import Cardano.Network.Ping
 
-data EndPoint
-  = HostEndPoint String
-  | UnixSockEndPoint String
-  deriving (Eq, Show)
-
-data PingCmd = PingCmd
-  { pingCmdCount :: !Word32
-  , pingCmdEndPoint :: !EndPoint
-  , pingCmdPort :: !String
-  , pingCmdMagic :: !Word32
-  , pingCmdJson :: !Bool
-  , pingCmdQuiet :: !Bool
-  , pingOptsHandshakeQuery :: !Bool
-  , pingOptsGetTip :: !Bool
+data PingCmd = PingCmd { 
+    pingOpts      :: PingOpts,
+    pingAddresses :: [Address (Unresolved SRVOrFilePathUnresolved)]
   }
-  deriving (Eq, Show)
-
-getConfigurationError :: PingCmd -> Maybe String
-getConfigurationError
-  PingCmd
-    { pingCmdEndPoint = endPoint
-    , pingOptsGetTip = getTip
-    , pingOptsHandshakeQuery = query
-    } =
-    case endPoint of
-      UnixSockEndPoint{}
-        | query || getTip -> Nothing
-        | otherwise -> Just "Unix sockets only support queries for available versions or a tip."
-      HostEndPoint{} -> Nothing

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

@@ -6,9 +6,8 @@ module Cardano.CLI.EraIndependent.Ping.Option
 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 CNP
+import Cardano.Network.Ping qualified as Ping
 
 import Control.Applicative
 import Options.Applicative qualified as Opt
@@ -25,90 +24,5 @@ parsePingCmd =
             , PP.pretty @String "It negotiates a handshake and keeps sending keep alive messages."
             ]
 
-pHost :: Opt.Parser String
-pHost =
-  Opt.strOption $
-    mconcat
-      [ Opt.long "host"
-      , Opt.short 'h'
-      , Opt.metavar "HOST"
-      , Opt.help "Hostname/IP, e.g. relay.iohk.example."
-      ]
-
-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 =
-  PingCmd
-    <$> ( 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.strOption $
-            mconcat
-              [ Opt.long "port"
-              , Opt.short 'p'
-              , Opt.metavar "PORT"
-              , Opt.help "Port number, e.g. 1234."
-              , Opt.value "3001"
-              ]
-        )
-    <*> ( Opt.option integralReader $
-            mconcat
-              [ Opt.long "magic"
-              , Opt.short 'm'
-              , Opt.metavar "MAGIC"
-              , Opt.help "Network magic."
-              , Opt.value (CNP.unNetworkMagic CNP.mainnetMagic)
-              ]
-        )
-    <*> ( Opt.switch $
-            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."
-              ]
-        )
+pPing = uncurry PingCmd <$> Ping.cmdlineParser

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

@@ -1,133 +1,18 @@
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE RankNTypes     #-}
 
 module Cardano.CLI.EraIndependent.Ping.Run
-  ( PingClientCmdError (..)
-  , renderPingClientCmdError
-  , runPingCmd
+  ( runPingCmd
   )
 where
 
 import Cardano.Api
 
-import Cardano.CLI.Compatible.Exception
+import Cardano.CLI.Compatible.Exception (CIO)
 import Cardano.CLI.EraIndependent.Ping.Command
-import Cardano.Network.Ping qualified as CNP
+import Cardano.Network.Ping qualified as Ping
 
-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)
-
-data PingClientCmdError
-  = PingClientCmdError [(AddrInfo, SomeException)]
-  | PingClientMisconfigurationError String
-  deriving Show
-
-instance Error PingClientCmdError where
-  prettyError = renderPingClientCmdError
 
 runPingCmd :: PingCmd -> CIO e ()
-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 ()
-    (es, []) -> throwCliError $ PingClientCmdError es
-    (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 =
-  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
-    }
-
--- | 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
+runPingCmd PingCmd { pingOpts, pingAddresses } =
+    liftIO $ Ping.pingClients pingOpts pingAddresses