{-# LANGUAGE LambdaCase #-}

{- HLINT ignore "Move brackets to avoid $" -}

module Cardano.CLI.Run.Ping
  ( PingClientCmdError (..)
  , renderPingClientCmdError
  , runPingCmd
  )
where

import           Cardano.Api

import           Cardano.CLI.Commands.Ping
import qualified Cardano.Network.Ping as CNP

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.Tracer (Tracer (..))
import qualified Data.List as L
import qualified Data.List as List
import           Network.Socket (AddrInfo)
import qualified Network.Socket as Socket
import qualified System.Exit as IO
import qualified System.IO as IO

data PingClientCmdError
  = PingClientCmdError [(AddrInfo, SomeException)]
  | PingClientMisconfigurationError String

maybeHostEndPoint :: EndPoint -> Maybe String
maybeHostEndPoint :: EndPoint -> Maybe String
maybeHostEndPoint = \case
  HostEndPoint String
host -> String -> Maybe String
forall a. a -> Maybe a
Just String
host
  UnixSockEndPoint String
_ -> Maybe String
forall a. Maybe a
Nothing

maybeUnixSockEndPoint :: EndPoint -> Maybe String
maybeUnixSockEndPoint :: EndPoint -> Maybe String
maybeUnixSockEndPoint = \case
  HostEndPoint String
_ -> Maybe String
forall a. Maybe a
Nothing
  UnixSockEndPoint String
sock -> String -> Maybe String
forall a. a -> Maybe a
Just String
sock

pingClient
  :: Tracer IO CNP.LogMsg -> Tracer IO String -> PingCmd -> [CNP.NodeVersion] -> AddrInfo -> IO ()
pingClient :: Tracer IO LogMsg
-> Tracer IO String
-> PingCmd
-> [NodeVersion]
-> AddrInfo
-> IO ()
pingClient Tracer IO LogMsg
stdout Tracer IO String
stderr PingCmd
cmd = Tracer IO LogMsg
-> Tracer IO String
-> PingOpts
-> [NodeVersion]
-> AddrInfo
-> IO ()
CNP.pingClient Tracer IO LogMsg
stdout Tracer IO String
stderr PingOpts
opts
 where
  opts :: PingOpts
opts =
    CNP.PingOpts
      { pingOptsQuiet :: Bool
CNP.pingOptsQuiet = PingCmd -> Bool
pingCmdQuiet PingCmd
cmd
      , pingOptsJson :: Bool
CNP.pingOptsJson = PingCmd -> Bool
pingCmdJson PingCmd
cmd
      , pingOptsCount :: Word32
CNP.pingOptsCount = PingCmd -> Word32
pingCmdCount PingCmd
cmd
      , pingOptsHost :: Maybe String
CNP.pingOptsHost = EndPoint -> Maybe String
maybeHostEndPoint (PingCmd -> EndPoint
pingCmdEndPoint PingCmd
cmd)
      , pingOptsUnixSock :: Maybe String
CNP.pingOptsUnixSock = EndPoint -> Maybe String
maybeUnixSockEndPoint (PingCmd -> EndPoint
pingCmdEndPoint PingCmd
cmd)
      , pingOptsPort :: String
CNP.pingOptsPort = PingCmd -> String
pingCmdPort PingCmd
cmd
      , pingOptsMagic :: Word32
CNP.pingOptsMagic = PingCmd -> Word32
pingCmdMagic PingCmd
cmd
      , pingOptsHandshakeQuery :: Bool
CNP.pingOptsHandshakeQuery = PingCmd -> Bool
pingOptsHandshakeQuery PingCmd
cmd
      , pingOptsGetTip :: Bool
CNP.pingOptsGetTip = PingCmd -> Bool
pingOptsGetTip PingCmd
cmd
      }

runPingCmd :: PingCmd -> ExceptT PingClientCmdError IO ()
runPingCmd :: PingCmd -> ExceptT PingClientCmdError IO ()
runPingCmd PingCmd
options
  | Just String
err <- PingCmd -> Maybe String
getConfigurationError PingCmd
options =
      PingClientCmdError -> ExceptT PingClientCmdError IO ()
forall a. PingClientCmdError -> ExceptT PingClientCmdError IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PingClientCmdError -> ExceptT PingClientCmdError IO ())
-> PingClientCmdError -> ExceptT PingClientCmdError IO ()
forall a b. (a -> b) -> a -> b
$ String -> PingClientCmdError
PingClientMisconfigurationError String
err
runPingCmd PingCmd
options = do
  let hints :: AddrInfo
hints = AddrInfo
Socket.defaultHints{Socket.addrSocketType = Socket.Stream}

  StrictTMVar IO LogMsg
msgQueue <- IO (StrictTMVar IO LogMsg)
-> ExceptT PingClientCmdError IO (StrictTMVar IO LogMsg)
forall a. IO a -> ExceptT PingClientCmdError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (StrictTMVar IO LogMsg)
forall (m :: * -> *) a. MonadSTM m => m (StrictTMVar m a)
STM.newEmptyTMVarIO

  -- 'addresses' are all the endpoints to connect to and 'versions' are the node protocol versions
  -- to ping with.
  ([AddrInfo]
addresses, [NodeVersion]
versions) <- case PingCmd -> EndPoint
pingCmdEndPoint PingCmd
options of
    HostEndPoint String
host -> do
      [AddrInfo]
addrs <- IO [AddrInfo] -> ExceptT PingClientCmdError IO [AddrInfo]
forall a. IO a -> ExceptT PingClientCmdError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [AddrInfo] -> ExceptT PingClientCmdError IO [AddrInfo])
-> IO [AddrInfo] -> ExceptT PingClientCmdError IO [AddrInfo]
forall a b. (a -> b) -> a -> b
$ Maybe AddrInfo -> Maybe String -> Maybe String -> IO [AddrInfo]
Socket.getAddrInfo (AddrInfo -> Maybe AddrInfo
forall a. a -> Maybe a
Just AddrInfo
hints) (String -> Maybe String
forall a. a -> Maybe a
Just String
host) (String -> Maybe String
forall a. a -> Maybe a
Just (PingCmd -> String
pingCmdPort PingCmd
options))
      ([AddrInfo], [NodeVersion])
-> ExceptT PingClientCmdError IO ([AddrInfo], [NodeVersion])
forall a. a -> ExceptT PingClientCmdError IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([AddrInfo]
addrs, Word32 -> [NodeVersion]
CNP.supportedNodeToNodeVersions (Word32 -> [NodeVersion]) -> Word32 -> [NodeVersion]
forall a b. (a -> b) -> a -> b
$ PingCmd -> Word32
pingCmdMagic PingCmd
options)
    UnixSockEndPoint String
fname -> do
      let addr :: AddrInfo
addr =
            [AddrInfoFlag]
-> Family
-> SocketType
-> ProtocolNumber
-> SockAddr
-> Maybe String
-> AddrInfo
Socket.AddrInfo
              []
              Family
Socket.AF_UNIX
              SocketType
Socket.Stream
              ProtocolNumber
Socket.defaultProtocol
              (String -> SockAddr
Socket.SockAddrUnix String
fname)
              Maybe String
forall a. Maybe a
Nothing
      ([AddrInfo], [NodeVersion])
-> ExceptT PingClientCmdError IO ([AddrInfo], [NodeVersion])
forall a. a -> ExceptT PingClientCmdError IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([AddrInfo
addr], Word32 -> [NodeVersion]
CNP.supportedNodeToClientVersions (Word32 -> [NodeVersion]) -> Word32 -> [NodeVersion]
forall a b. (a -> b) -> a -> b
$ PingCmd -> Word32
pingCmdMagic PingCmd
options)

  -- Logger async thread handle
  Async ()
laid <-
    IO (Async ()) -> ExceptT PingClientCmdError IO (Async ())
forall a. IO a -> ExceptT PingClientCmdError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Async ()) -> ExceptT PingClientCmdError IO (Async ()))
-> (IO () -> IO (Async ()))
-> IO ()
-> ExceptT PingClientCmdError IO (Async ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO (Async ())
IO () -> IO (Async IO ())
forall a. IO a -> IO (Async IO a)
forall (m :: * -> *) a. MonadAsync m => m a -> m (Async m a)
async (IO () -> ExceptT PingClientCmdError IO (Async ()))
-> IO () -> ExceptT PingClientCmdError IO (Async ())
forall a b. (a -> b) -> a -> b
$
      StrictTMVar IO LogMsg -> Bool -> Bool -> Bool -> IO ()
CNP.logger StrictTMVar IO LogMsg
msgQueue (PingCmd -> Bool
pingCmdJson PingCmd
options) (PingCmd -> Bool
pingOptsHandshakeQuery PingCmd
options) (PingCmd -> Bool
pingOptsGetTip PingCmd
options)

  -- Ping client thread handles
  [Async ()]
caids <-
    [AddrInfo]
-> (AddrInfo -> ExceptT PingClientCmdError IO (Async ()))
-> ExceptT PingClientCmdError IO [Async ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [AddrInfo]
addresses ((AddrInfo -> ExceptT PingClientCmdError IO (Async ()))
 -> ExceptT PingClientCmdError IO [Async ()])
-> (AddrInfo -> ExceptT PingClientCmdError IO (Async ()))
-> ExceptT PingClientCmdError IO [Async ()]
forall a b. (a -> b) -> a -> b
$
      IO (Async ()) -> ExceptT PingClientCmdError IO (Async ())
forall a. IO a -> ExceptT PingClientCmdError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Async ()) -> ExceptT PingClientCmdError IO (Async ()))
-> (AddrInfo -> IO (Async ()))
-> AddrInfo
-> ExceptT PingClientCmdError IO (Async ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO (Async ())
IO () -> IO (Async IO ())
forall a. IO a -> IO (Async IO a)
forall (m :: * -> *) a. MonadAsync m => m a -> m (Async m a)
async (IO () -> IO (Async ()))
-> (AddrInfo -> IO ()) -> AddrInfo -> IO (Async ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tracer IO LogMsg
-> Tracer IO String
-> PingCmd
-> [NodeVersion]
-> AddrInfo
-> IO ()
pingClient ((LogMsg -> IO ()) -> Tracer IO LogMsg
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer ((LogMsg -> IO ()) -> Tracer IO LogMsg)
-> (LogMsg -> IO ()) -> Tracer IO LogMsg
forall a b. (a -> b) -> a -> b
$ StrictTMVar IO LogMsg -> LogMsg -> IO ()
doLog StrictTMVar IO LogMsg
msgQueue) ((String -> IO ()) -> Tracer IO String
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer String -> IO ()
doErrLog) PingCmd
options [NodeVersion]
versions
  [(AddrInfo, Either SomeException ())]
res <- [AddrInfo]
-> [Either SomeException ()]
-> [(AddrInfo, Either SomeException ())]
forall a b. [a] -> [b] -> [(a, b)]
L.zip [AddrInfo]
addresses ([Either SomeException ()]
 -> [(AddrInfo, Either SomeException ())])
-> ExceptT PingClientCmdError IO [Either SomeException ()]
-> ExceptT
     PingClientCmdError IO [(AddrInfo, Either SomeException ())]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Async ()
 -> ExceptT PingClientCmdError IO (Either SomeException ()))
-> [Async ()]
-> ExceptT PingClientCmdError IO [Either SomeException ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (IO (Either SomeException ())
-> ExceptT PingClientCmdError IO (Either SomeException ())
forall a. IO a -> ExceptT PingClientCmdError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either SomeException ())
 -> ExceptT PingClientCmdError IO (Either SomeException ()))
-> (Async () -> IO (Either SomeException ()))
-> Async ()
-> ExceptT PingClientCmdError IO (Either SomeException ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Async () -> IO (Either SomeException ())
Async IO () -> IO (Either SomeException ())
forall a. Async IO a -> IO (Either SomeException a)
forall (m :: * -> *) a.
MonadAsync m =>
Async m a -> m (Either SomeException a)
waitCatch) [Async ()]
caids
  IO () -> ExceptT PingClientCmdError IO ()
forall a. IO a -> ExceptT PingClientCmdError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT PingClientCmdError IO ())
-> IO () -> ExceptT PingClientCmdError IO ()
forall a b. (a -> b) -> a -> b
$ StrictTMVar IO LogMsg -> LogMsg -> IO ()
doLog StrictTMVar IO LogMsg
msgQueue LogMsg
CNP.LogEnd
  IO () -> ExceptT PingClientCmdError IO ()
forall a. IO a -> ExceptT PingClientCmdError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT PingClientCmdError IO ())
-> IO () -> ExceptT PingClientCmdError IO ()
forall a b. (a -> b) -> a -> b
$ Async IO () -> IO ()
forall a. Async IO a -> IO a
forall (m :: * -> *) a. MonadAsync m => Async m a -> m a
wait Async ()
Async IO ()
laid

  -- Collect errors 'es' from failed pings and 'addrs' from successful pings.
  let ([(AddrInfo, SomeException)]
es, [AddrInfo]
addrs) = (([(AddrInfo, SomeException)], [AddrInfo])
 -> (AddrInfo, Either SomeException ())
 -> ([(AddrInfo, SomeException)], [AddrInfo]))
-> ([(AddrInfo, SomeException)], [AddrInfo])
-> [(AddrInfo, Either SomeException ())]
-> ([(AddrInfo, SomeException)], [AddrInfo])
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl' ([(AddrInfo, SomeException)], [AddrInfo])
-> (AddrInfo, Either SomeException ())
-> ([(AddrInfo, SomeException)], [AddrInfo])
partition ([], []) [(AddrInfo, Either SomeException ())]
res

  -- Report any errors
  case ([(AddrInfo, SomeException)]
es, [AddrInfo]
addrs) of
    ([], [AddrInfo]
_) -> IO () -> ExceptT PingClientCmdError IO ()
forall a. IO a -> ExceptT PingClientCmdError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
forall a. IO a
IO.exitSuccess
    ([(AddrInfo, SomeException)]
_, []) -> PingClientCmdError -> ExceptT PingClientCmdError IO ()
forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left (PingClientCmdError -> ExceptT PingClientCmdError IO ())
-> PingClientCmdError -> ExceptT PingClientCmdError IO ()
forall a b. (a -> b) -> a -> b
$ [(AddrInfo, SomeException)] -> PingClientCmdError
PingClientCmdError [(AddrInfo, SomeException)]
es
    ([(AddrInfo, SomeException)]
_, [AddrInfo]
_) -> do
      Bool
-> ExceptT PingClientCmdError IO ()
-> ExceptT PingClientCmdError IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (PingCmd -> Bool
pingCmdQuiet PingCmd
options) (ExceptT PingClientCmdError IO ()
 -> ExceptT PingClientCmdError IO ())
-> ExceptT PingClientCmdError IO ()
-> ExceptT PingClientCmdError IO ()
forall a b. (a -> b) -> a -> b
$ ((AddrInfo, SomeException) -> ExceptT PingClientCmdError IO ())
-> [(AddrInfo, SomeException)] -> ExceptT PingClientCmdError IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (IO () -> ExceptT PingClientCmdError IO ()
forall a. IO a -> ExceptT PingClientCmdError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT PingClientCmdError IO ())
-> ((AddrInfo, SomeException) -> IO ())
-> (AddrInfo, SomeException)
-> ExceptT PingClientCmdError IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> (AddrInfo, SomeException) -> IO ()
forall a. Show a => Handle -> a -> IO ()
IO.hPrint Handle
IO.stderr) [(AddrInfo, SomeException)]
es
      IO () -> ExceptT PingClientCmdError IO ()
forall a. IO a -> ExceptT PingClientCmdError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
forall a. IO a
IO.exitSuccess
 where
  partition
    :: ([(AddrInfo, SomeException)], [AddrInfo])
    -> (AddrInfo, Either SomeException ())
    -> ([(AddrInfo, SomeException)], [AddrInfo])
  partition :: ([(AddrInfo, SomeException)], [AddrInfo])
-> (AddrInfo, Either SomeException ())
-> ([(AddrInfo, SomeException)], [AddrInfo])
partition ([(AddrInfo, SomeException)]
es, [AddrInfo]
as) (AddrInfo
a, Left SomeException
e) = ((AddrInfo
a, SomeException
e) (AddrInfo, SomeException)
-> [(AddrInfo, SomeException)] -> [(AddrInfo, SomeException)]
forall a. a -> [a] -> [a]
: [(AddrInfo, SomeException)]
es, [AddrInfo]
as)
  partition ([(AddrInfo, SomeException)]
es, [AddrInfo]
as) (AddrInfo
a, Right ()
_) = ([(AddrInfo, SomeException)]
es, AddrInfo
a AddrInfo -> [AddrInfo] -> [AddrInfo]
forall a. a -> [a] -> [a]
: [AddrInfo]
as)

  doLog :: StrictTMVar IO CNP.LogMsg -> CNP.LogMsg -> IO ()
  doLog :: StrictTMVar IO LogMsg -> LogMsg -> IO ()
doLog StrictTMVar IO LogMsg
msgQueue LogMsg
msg = STM IO () -> IO ()
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
STM.atomically (STM IO () -> IO ()) -> STM IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ StrictTMVar IO LogMsg -> LogMsg -> STM IO ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTMVar m a -> a -> STM m ()
STM.putTMVar StrictTMVar IO LogMsg
msgQueue LogMsg
msg

  doErrLog :: String -> IO ()
  doErrLog :: String -> IO ()
doErrLog = Handle -> String -> IO ()
IO.hPutStrLn Handle
IO.stderr

renderPingClientCmdError :: PingClientCmdError -> Doc ann
renderPingClientCmdError :: forall ann. PingClientCmdError -> Doc ann
renderPingClientCmdError = \case
  PingClientCmdError [(AddrInfo, SomeException)]
es -> [Doc ann] -> Doc ann
forall a. Monoid a => [a] -> a
mconcat ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$ Doc ann -> [Doc ann] -> [Doc ann]
forall a. a -> [a] -> [a]
List.intersperse Doc ann
"\n" ([Doc ann] -> [Doc ann]) -> [Doc ann] -> [Doc ann]
forall a b. (a -> b) -> a -> b
$ (AddrInfo, SomeException) -> Doc ann
forall a ann. Show a => a -> Doc ann
pshow ((AddrInfo, SomeException) -> Doc ann)
-> [(AddrInfo, SomeException)] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(AddrInfo, SomeException)]
es
  PingClientMisconfigurationError String
err -> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
err