-
Notifications
You must be signed in to change notification settings - Fork 721
/
Ping.hs
206 lines (181 loc) · 6.94 KB
/
Ping.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeApplications #-}
{- HLINT ignore "Move brackets to avoid $" -}
module Cardano.CLI.Ping
( 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
, pingCmdQuery :: !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
, CNP.pingOptsHandshakeQuery = pingCmdQuery cmd
}
runPingCmd :: PingCmd -> ExceptT PingClientCmdError IO ()
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) (pingCmdQuery options)
-- 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
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])
-> (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"
]
)
<*> ( Opt.switch $ mconcat
[ Opt.long "query"
, Opt.short 'q'
, Opt.help "Query flag."
]
)