{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}

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

import Cardano.Api

import Cardano.CLI.Compatible.Exception
import Cardano.CLI.EraIndependent.Ping.Command
import Cardano.Network.Ping qualified as CNP

import Control.Concurrent.Class.MonadSTM.Strict (StrictTMVar)
import Control.Concurrent.Class.MonadSTM.Strict qualified 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 Data.List qualified as L
import Data.List qualified as List
import Network.Socket (AddrInfo)
import Network.Socket qualified as Socket
import System.Exit qualified as IO
import System.IO qualified as IO

data PingClientCmdError
  = PingClientCmdError [(AddrInfo, SomeException)]
  | PingClientMisconfigurationError String
  deriving Int -> PingClientCmdError -> ShowS
[PingClientCmdError] -> ShowS
PingClientCmdError -> String
(Int -> PingClientCmdError -> ShowS)
-> (PingClientCmdError -> String)
-> ([PingClientCmdError] -> ShowS)
-> Show PingClientCmdError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PingClientCmdError -> ShowS
showsPrec :: Int -> PingClientCmdError -> ShowS
$cshow :: PingClientCmdError -> String
show :: PingClientCmdError -> String
$cshowList :: [PingClientCmdError] -> ShowS
showList :: [PingClientCmdError] -> ShowS
Show

instance Error PingClientCmdError where
  prettyError :: forall ann. PingClientCmdError -> Doc ann
prettyError = PingClientCmdError -> Doc ann
forall ann. PingClientCmdError -> Doc ann
renderPingClientCmdError

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 -> CIO e ()
runPingCmd :: forall e. PingCmd -> CIO e ()
runPingCmd PingCmd
options
  | Just String
err <- PingCmd -> Maybe String
getConfigurationError PingCmd
options =
      PingClientCmdError -> RIO e ()
forall e (m :: * -> *) a.
(HasCallStack, Show e, Typeable e, Error e, MonadIO m) =>
e -> m a
throwCliError (PingClientCmdError -> RIO e ()) -> PingClientCmdError -> RIO e ()
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}

  msgQueue <- IO (StrictTMVar IO LogMsg) -> RIO e (StrictTMVar IO LogMsg)
forall a. IO a -> RIO e 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.
  (addresses, versions) <- case pingCmdEndPoint options of
    HostEndPoint String
host -> do
      addrs <- IO [AddrInfo] -> RIO e [AddrInfo]
forall a. IO a -> RIO e a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [AddrInfo] -> RIO e [AddrInfo])
-> IO [AddrInfo] -> RIO e [AddrInfo]
forall a b. (a -> b) -> a -> b
$ Maybe AddrInfo -> Maybe String -> Maybe String -> IO [AddrInfo]
forall (t :: * -> *).
GetAddrInfo t =>
Maybe AddrInfo -> Maybe String -> Maybe String -> IO (t 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))
      return (addrs, CNP.supportedNodeToNodeVersions $ pingCmdMagic 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]) -> RIO e ([AddrInfo], [NodeVersion])
forall a. a -> RIO e 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
  laid <-
    liftIO . async $
      CNP.logger msgQueue (pingCmdJson options) (pingOptsHandshakeQuery options) (pingOptsGetTip 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) = L.foldl' partition ([], []) res

  -- Report any errors
  case (es, addrs) of
    ([], [AddrInfo]
_) -> IO () -> RIO e ()
forall a. IO a -> RIO e a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
forall a. IO a
IO.exitSuccess
    ([(AddrInfo, SomeException)]
_, []) -> PingClientCmdError -> RIO e ()
forall e (m :: * -> *) a.
(HasCallStack, Show e, Typeable e, Error e, MonadIO m) =>
e -> m a
throwCliError (PingClientCmdError -> RIO e ()) -> PingClientCmdError -> RIO e ()
forall a b. (a -> b) -> a -> b
$ [(AddrInfo, SomeException)] -> PingClientCmdError
PingClientCmdError [(AddrInfo, SomeException)]
es
    ([(AddrInfo, SomeException)]
_, [AddrInfo]
_) -> do
      Bool -> RIO e () -> RIO e ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (PingCmd -> Bool
pingCmdQuiet PingCmd
options) (RIO e () -> RIO e ()) -> RIO e () -> RIO e ()
forall a b. (a -> b) -> a -> b
$ ((AddrInfo, SomeException) -> RIO e ())
-> [(AddrInfo, SomeException)] -> RIO e ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (IO () -> RIO e ()
forall a. IO a -> RIO e a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO e ())
-> ((AddrInfo, SomeException) -> IO ())
-> (AddrInfo, SomeException)
-> RIO e ()
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 () -> RIO e ()
forall a. IO a -> RIO e 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