New cardano-cli ping command. #4664
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,198 @@ | ||
| {-# LANGUAGE LambdaCase #-} | ||
| {-# LANGUAGE TypeApplications #-} | ||
|
|
||
| {- HLINT ignore "Move brackets to avoid $" -} | ||
|
|
||
| module Cardano.CLI.Ping | ||
Jimbo4350 marked this conversation as resolved.
Show resolved
Hide resolved
|
||
| ( PingCmd(..) | ||
| , PingClientCmdError(..) | ||
| , renderPingClientCmdError | ||
| , runPingCmd | ||
| , parsePingCmd | ||
| ) where | ||
|
|
||
| import Control.Applicative ((<|>)) | ||
| import Control.Concurrent.Class.MonadSTM.Strict (StrictTMVar) | ||
| import qualified Control.Concurrent.Class.MonadSTM.Strict as STM | ||
| import Control.Exception (SomeException) | ||
| import Control.Monad (forM, unless) | ||
| import Control.Monad.Class.MonadAsync (MonadAsync (async, wait, waitCatch)) | ||
| import Control.Monad.IO.Class (liftIO) | ||
| import Control.Monad.Trans.Except (ExceptT) | ||
| import Control.Monad.Trans.Except.Extra (left) | ||
| import Control.Tracer (Tracer (..)) | ||
| import Data.List (foldl') | ||
| import qualified Data.List as L | ||
| import Data.Text (Text) | ||
| import qualified Data.Text as T | ||
| import Data.Word (Word32) | ||
| import Network.Socket (AddrInfo) | ||
| import qualified Network.Socket as Socket | ||
| import qualified Options.Applicative as Opt | ||
| import qualified Prettyprinter as PP | ||
| import qualified System.Exit as IO | ||
| import qualified System.IO as IO | ||
|
|
||
| import qualified Cardano.Network.Ping as CNP | ||
|
|
||
| newtype PingClientCmdError = PingClientCmdError [(AddrInfo, SomeException)] | ||
|
|
||
| data EndPoint = HostEndPoint String | UnixSockEndPoint String deriving (Eq, Show) | ||
|
|
||
| maybeHostEndPoint :: EndPoint -> Maybe String | ||
| maybeHostEndPoint = \case | ||
| HostEndPoint host -> Just host | ||
| UnixSockEndPoint _ -> Nothing | ||
|
|
||
| maybeUnixSockEndPoint :: EndPoint -> Maybe String | ||
| maybeUnixSockEndPoint = \case | ||
| HostEndPoint _ -> Nothing | ||
| UnixSockEndPoint sock -> Just sock | ||
|
|
||
| data PingCmd = PingCmd | ||
| { pingCmdCount :: !Word32 | ||
| , pingCmdEndPoint :: !EndPoint | ||
| , pingCmdPort :: !String | ||
| , pingCmdMagic :: !Word32 | ||
| , pingCmdJson :: !Bool | ||
| , pingCmdQuiet :: !Bool | ||
| } deriving (Eq, Show) | ||
|
|
||
| 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 | ||
| } | ||
|
|
||
| runPingCmd :: PingCmd -> ExceptT PingClientCmdError IO () | ||
|
There was a problem hiding this comment. Can we add some comments to this code to make it clearer as to what is happening? There was a problem hiding this comment. Some comments added |
||
| 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 | ||
|
There was a problem hiding this comment. Some comments here would be useful |
||
| -- Ping client thread handles | ||
| caids <- forM addresses $ liftIO . async . pingClient (Tracer $ doLog msgQueue) (Tracer doErrLog) options versions | ||
| res <- L.zip addresses <$> mapM (liftIO . waitCatch) caids | ||
| liftIO $ doLog msgQueue CNP.LogEnd | ||
|
There was a problem hiding this comment.
There was a problem hiding this comment. Yeah. It logs JSON so the |
||
| liftIO $ wait laid | ||
|
|
||
| -- Collect errors 'es' from failed pings and 'addrs' from successful pings. | ||
| let (es, addrs) = foldl' partition ([],[]) res | ||
|
|
||
| -- Report any errors | ||
| case (es, addrs) of | ||
| ([], _) -> liftIO IO.exitSuccess | ||
| (_, []) -> left $ PingClientCmdError es | ||
| (_, _) -> do | ||
| unless (pingCmdQuiet options) $ mapM_ (liftIO . IO.hPrint IO.stderr) es | ||
| liftIO IO.exitSuccess | ||
|
|
||
| where | ||
| partition :: ([(AddrInfo, SomeException)], [AddrInfo]) | ||
|
There was a problem hiding this comment. Some comments here would be useful There was a problem hiding this comment. Do the comments in the function body suffice? |
||
| -> (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 -> Text | ||
| renderPingClientCmdError = \case | ||
| PingClientCmdError es -> T.intercalate "\n" $ T.pack . show <$> es | ||
|
|
||
| parsePingCmd :: Opt.Parser PingCmd | ||
| parsePingCmd = Opt.hsubparser $ mconcat | ||
| [ Opt.metavar "ping" | ||
| , Opt.command "ping" $ Opt.info pPing $ Opt.progDescDoc $ Just $ mconcat | ||
| [ PP.pretty @String "Ping a cardano node either using node-to-node or node-to-client protocol. " | ||
| , 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 Opt.auto $ 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 Opt.auto $ mconcat | ||
| [ Opt.long "magic" | ||
| , Opt.short 'm' | ||
| , Opt.metavar "MAGIC" | ||
| , Opt.help "Network magic." | ||
| , Opt.value 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" | ||
| ] | ||
| ) | ||
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Add this suggestion to a batch that can be applied as a single commit.
This suggestion is invalid because no changes were made to the code.
Suggestions cannot be applied while the pull request is closed.
Suggestions cannot be applied while viewing a subset of changes.
Only one suggestion per line can be applied in a batch.
Add this suggestion to a batch that can be applied as a single commit.
Applying suggestions on deleted lines is not supported.
You must change the existing code in this line in order to create a valid suggestion.
Outdated suggestions cannot be applied.
This suggestion has been applied or marked resolved.
Suggestions cannot be applied from pending reviews.
Suggestions cannot be applied on multi-line comments.
Suggestions cannot be applied while the pull request is queued to merge.
Suggestion cannot be applied right now. Please check back later.
There was a problem hiding this comment.
Choose a reason for hiding this comment
The reason will be displayed to describe this comment to others. Learn more.
In future lets do index state bumps in separate PRs so if it happens to break CI/Nix infrastructure we can deal with it separately.