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

module Cardano.CLI.EraBased.StakePool.Internal.Relay
  ( validateStakePoolRelays
  , stakePoolRelayToAddr
  )
where

import Cardano.Api
import Cardano.Api.Experimental.Certificate (StakePoolRelay (..))

import Cardano.CLI.Compatible.Exception
import Cardano.CLI.Type.Error.StakePoolCmdError
import Cardano.Network.Ping qualified as Ping

import Control.Monad
import Control.Tracer (nullTracer, (>$<))
import Data.ByteString.Char8 qualified as BSC
import Data.IP (IP (IPv4, IPv6))

-- | Check that every relay is reachable, by connecting to it with
-- 'Ping.pingClients''. Fails with the collected errors if any relay cannot be
-- reached. This requires network access to the relays.
validateStakePoolRelays :: NetworkId -> [StakePoolRelay] -> CIO e ()
validateStakePoolRelays :: forall e. NetworkId -> [StakePoolRelay] -> CIO e ()
validateStakePoolRelays NetworkId
network [StakePoolRelay]
relays = do
  relayAddrs <- [[Address (Unresolved SRVOrFilePathUnresolved)]]
-> [Address (Unresolved SRVOrFilePathUnresolved)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Address (Unresolved SRVOrFilePathUnresolved)]]
 -> [Address (Unresolved SRVOrFilePathUnresolved)])
-> RIO e [[Address (Unresolved SRVOrFilePathUnresolved)]]
-> RIO e [Address (Unresolved SRVOrFilePathUnresolved)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (StakePoolRelay
 -> RIO e [Address (Unresolved SRVOrFilePathUnresolved)])
-> [StakePoolRelay]
-> RIO e [[Address (Unresolved SRVOrFilePathUnresolved)]]
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 StakePoolRelay
-> RIO e [Address (Unresolved SRVOrFilePathUnresolved)]
StakePoolRelay
-> CIO e [Address (Unresolved SRVOrFilePathUnresolved)]
forall e.
StakePoolRelay
-> CIO e [Address (Unresolved SRVOrFilePathUnresolved)]
stakePoolRelayToAddr [StakePoolRelay]
relays

  -- Skip the ping when there are no relays to check: 'Ping.pingClients'' builds a
  -- DNS resolver from /etc/resolv.conf before it looks at its address list, so it
  -- fails outright on hosts without one.
  unless (null relayAddrs) $ do
    let pingOpts =
          Ping.PingOpts
            { pingOptsCount :: Word32
Ping.pingOptsCount = Word32
1
            , pingOptsMagic :: NetworkMagic
Ping.pingOptsMagic = NetworkId -> NetworkMagic
toNetworkMagic NetworkId
network
            , pingOptsJson :: LogFormat
Ping.pingOptsJson = LogFormat
Ping.AsText
            , pingOptsQuiet :: Bool
Ping.pingOptsQuiet = Bool
True
            , pingOptsSRVPrefix :: String
Ping.pingOptsSRVPrefix = String
"_cardano._tcp"
            , pingOptsColor :: ColorMode
Ping.pingOptsColor = ColorMode
Ping.ColorNever
            , pingOptsMode :: PingMode
Ping.pingOptsMode = PingMode
Ping.TipMode
            , pingOptsHashType :: HashType
Ping.pingOptsHashType = HashType
Ping.FullHash
            }

    pingErrs <- liftIO $ do
      stderr <- Ping.mkStdErrTracer
      headerTracer <- Ping.mkHeaderTracer pingOpts stderr
      Ping.pingClients'
        (Ping.format Ping.AsText >$< stderr)
        nullTracer
        headerTracer
        (Ping.toText >$< stderr)
        pingOpts
        Ping.AddressIsNotAFilePath
        relayAddrs

    unless (null pingErrs) $
      throwCliError (StakePoolCmdRelayPingErrors pingErrs)

stakePoolRelayToAddr
  :: StakePoolRelay
  -> CIO e [Ping.Address (Ping.Unresolved Ping.SRVOrFilePathUnresolved)]
stakePoolRelayToAddr :: forall e.
StakePoolRelay
-> CIO e [Address (Unresolved SRVOrFilePathUnresolved)]
stakePoolRelayToAddr = \case
  StakePoolRelayIp (Just IPv4
ipv4) Maybe IPv6
Nothing (Just PortNumber
port) ->
    [Address (Unresolved SRVOrFilePathUnresolved)]
-> RIO e [Address (Unresolved SRVOrFilePathUnresolved)]
forall a. a -> RIO e a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [IP -> Word -> Address (Unresolved SRVOrFilePathUnresolved)
forall (stage :: Stage). IP -> Word -> Address stage
Ping.IP (IPv4 -> IP
IPv4 IPv4
ipv4) (PortNumber -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral PortNumber
port)]
  StakePoolRelayIp Maybe IPv4
Nothing (Just IPv6
ipv6) (Just PortNumber
port) ->
    [Address (Unresolved SRVOrFilePathUnresolved)]
-> RIO e [Address (Unresolved SRVOrFilePathUnresolved)]
forall a. a -> RIO e a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [IP -> Word -> Address (Unresolved SRVOrFilePathUnresolved)
forall (stage :: Stage). IP -> Word -> Address stage
Ping.IP (IPv6 -> IP
IPv6 IPv6
ipv6) (PortNumber -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral PortNumber
port)]
  StakePoolRelayIp (Just IPv4
ipv4) (Just IPv6
ipv6) (Just PortNumber
port) ->
    [Address (Unresolved SRVOrFilePathUnresolved)]
-> RIO e [Address (Unresolved SRVOrFilePathUnresolved)]
forall a. a -> RIO e a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [IP -> Word -> Address (Unresolved SRVOrFilePathUnresolved)
forall (stage :: Stage). IP -> Word -> Address stage
Ping.IP (IPv6 -> IP
IPv6 IPv6
ipv6) (PortNumber -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral PortNumber
port), IP -> Word -> Address (Unresolved SRVOrFilePathUnresolved)
forall (stage :: Stage). IP -> Word -> Address stage
Ping.IP (IPv4 -> IP
IPv4 IPv4
ipv4) (PortNumber -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral PortNumber
port)]
  -- 'pSingleHostAddress' always parses a port number, so this is unreachable from
  -- the command line.
  relay :: StakePoolRelay
relay@(StakePoolRelayIp Maybe IPv4
_ Maybe IPv6
_ Maybe PortNumber
Nothing) ->
    StakePoolCmdError
-> RIO e [Address (Unresolved SRVOrFilePathUnresolved)]
forall e (m :: * -> *) a.
(HasCallStack, Show e, Typeable e, Error e, MonadIO m) =>
e -> m a
throwCliError (StakePoolRelay -> StakePoolCmdError
StakePoolCmdInvalidRelayError StakePoolRelay
relay)
  -- 'pSingleHostAddress' always parses at least one IP address, so this is
  -- unreachable from the command line.
  relay :: StakePoolRelay
relay@(StakePoolRelayIp Maybe IPv4
Nothing Maybe IPv6
Nothing Maybe PortNumber
_) ->
    StakePoolCmdError
-> RIO e [Address (Unresolved SRVOrFilePathUnresolved)]
forall e (m :: * -> *) a.
(HasCallStack, Show e, Typeable e, Error e, MonadIO m) =>
e -> m a
throwCliError (StakePoolRelay -> StakePoolCmdError
StakePoolCmdInvalidRelayError StakePoolRelay
relay)
  StakePoolRelayDnsARecord ByteString
dns (Just PortNumber
port) ->
    [Address (Unresolved SRVOrFilePathUnresolved)]
-> RIO e [Address (Unresolved SRVOrFilePathUnresolved)]
forall a. a -> RIO e a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [String -> Address (Unresolved SRVOrFilePathUnresolved)
Ping.mkAddress (ByteString -> String
BSC.unpack ByteString
dns String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ PortNumber -> String
forall a. Show a => a -> String
show PortNumber
port)]
  StakePoolRelayDnsARecord ByteString
dns Maybe PortNumber
Nothing ->
    [Address (Unresolved SRVOrFilePathUnresolved)]
-> RIO e [Address (Unresolved SRVOrFilePathUnresolved)]
forall a. a -> RIO e a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [String -> Address (Unresolved SRVOrFilePathUnresolved)
Ping.mkAddress (ByteString -> String
BSC.unpack ByteString
dns)]
  StakePoolRelayDnsSrvRecord ByteString
srv ->
    [Address (Unresolved SRVOrFilePathUnresolved)]
-> RIO e [Address (Unresolved SRVOrFilePathUnresolved)]
forall a. a -> RIO e a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [String -> Address (Unresolved SRVOrFilePathUnresolved)
Ping.mkAddress (ByteString -> String
BSC.unpack ByteString
srv)]