registration: validate relays using cardano-diffusion:ping

cabal.project

@@ -161,8 +161,8 @@ source-repository-package
 source-repository-package
   type: git
   location: https://github.com/IntersectMBO/ouroboros-network.git
-  tag: 613f8a13cc1c11b2568a627d6eb900058e355d30
-  --sha256: sha256-G5oVYskwZTc0EeFlQHE41xIjmFhMYV7VmX48kNGuc/c=
+  tag: b47dbc2c29108e593cc47524cffb75008b88fe90
+  --sha256: sha256-7TwcI1/m6aEBmiGYPXKHbIWlxzRja4qFyqr+apcR9p4=
   subdir:
     ./cardano-diffusion
     ./monoidal-synchronisation

cardano-cli/src/Cardano/CLI/Compatible/StakePool/Run.hs

@@ -6,13 +6,18 @@
 
 module Cardano.CLI.Compatible.StakePool.Run
   ( runCompatibleStakePoolCmds
+  , stakePoolRelayToAddr
   )
 where
 
+import Control.Tracer (nullTracer, (>$<))
+import Data.IP (IP (..))
+import Data.ByteString.Char8 qualified as BSC
+
 import Cardano.Api
 import Cardano.Api.Compatible.Certificate
 import Cardano.Api.Experimental qualified as Exp
-import Cardano.Api.Experimental.Certificate (StakePoolParameters (..), toShelleyPoolParams)
+import Cardano.Api.Experimental.Certificate (StakePoolParameters (..), StakePoolRelay (..), toShelleyPoolParams)
 
 import Cardano.CLI.Compatible.Exception
 import Cardano.CLI.Compatible.StakePool.Command
@@ -24,6 +29,8 @@ import Cardano.CLI.Type.Common
 import Cardano.CLI.Type.Error.StakePoolCmdError
 import Cardano.CLI.Type.Key (readVerificationKeyOrFile)
 
+import Cardano.Network.Ping qualified as Ping
+
 import Control.Monad
 
 runCompatibleStakePoolCmds
@@ -53,6 +60,32 @@ runStakePoolRegistrationCertificateCmd
     , outFile
     } =
     shelleyBasedEraConstraints sbe $ do
+
+      let pingOpts =
+            Ping.PingOpts {
+              Ping.pingOptsCount     = 1,
+              Ping.pingOptsMagic     = toNetworkMagic network,
+              Ping.pingOptsJson      = Ping.AsText,
+              Ping.pingOptsQuiet     = True,
+              Ping.pingOptsSRVPrefix = "_cardano._tcp",
+              Ping.pingOptsColor     = Ping.ColorNever,
+              Ping.pingOptsMode      = Ping.TipMode
+            }
+      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
+          (concatMap stakePoolRelayToAddr relays)
+
+      unless (null pingErrs) $
+        throwCliError (StakePoolCmdRelayPingErrors pingErrs)
+
       -- Pool verification key
       stakePoolVerKey <- getVerificationKeyFromStakePoolVerificationKeySource poolVerificationKeyOrFile
       let stakePoolId' = anyStakePoolVerificationKeyHash stakePoolVerKey
@@ -100,3 +133,18 @@ runStakePoolRegistrationCertificateCmd
    where
     registrationCertDesc :: TextEnvelopeDescr
     registrationCertDesc = "Stake Pool Registration Certificate"
+
+
+stakePoolRelayToAddr
+  :: StakePoolRelay
+  -> [Ping.Address (Ping.Unresolved Ping.SRVOrFilePathUnresolved)]
+stakePoolRelayToAddr (StakePoolRelayIp (Just ipv4) Nothing (Just port)) = [Ping.IP (IPv4 ipv4) (fromIntegral port)]
+stakePoolRelayToAddr (StakePoolRelayIp Nothing (Just ipv6) (Just port)) = [Ping.IP (IPv6 ipv6) (fromIntegral port)]
+stakePoolRelayToAddr (StakePoolRelayIp (Just ipv4) (Just ipv6) (Just port))  = [Ping.IP (IPv6 ipv6) (fromIntegral port), Ping.IP (IPv4 ipv4) (fromIntegral port)]
+-- the pSingHostAddress parser always includes a port number
+stakePoolRelayToAddr (StakePoolRelayIp _ _ Nothing) = error "unexpected happend"
+-- the pSingHostAddress parser always includes at least one ip address
+stakePoolRelayToAddr (StakePoolRelayIp Nothing Nothing _) = error "unexpected happend"
+stakePoolRelayToAddr (StakePoolRelayDnsARecord dns (Just port)) = [Ping.mkAddress (BSC.unpack dns ++ ":" ++ show port)]
+stakePoolRelayToAddr (StakePoolRelayDnsARecord dns Nothing) = [Ping.mkAddress (BSC.unpack dns)]
+stakePoolRelayToAddr (StakePoolRelayDnsSrvRecord srv) = [Ping.mkAddress (BSC.unpack srv)]

cardano-cli/src/Cardano/CLI/EraBased/Common/Option.hs

@@ -2627,7 +2627,7 @@ pMultiHostName =
 
 pSingleHostName :: Parser StakePoolRelay
 pSingleHostName =
-  StakePoolRelayDnsARecord <$> pDNSName <*> optional pPort
+  StakePoolRelayDnsARecord <$> pDNSName <*> (Just <$> pPort)
  where
   pDNSName :: Parser ByteString
   pDNSName =

cardano-cli/src/Cardano/CLI/EraBased/StakePool/Run.hs

@@ -27,6 +27,7 @@ import Cardano.Api.Experimental.Certificate
 import Cardano.Api.Ledger qualified as L
 
 import Cardano.CLI.Compatible.Exception
+import Cardano.CLI.Compatible.StakePool.Run (stakePoolRelayToAddr)
 import Cardano.CLI.EraBased.StakePool.Command
 import Cardano.CLI.EraBased.StakePool.Command qualified as Cmd
 import Cardano.CLI.EraBased.StakePool.Internal.Metadata (carryHashChecks)
@@ -42,6 +43,10 @@ import Cardano.CLI.Type.Error.HashCmdError (FetchURLError (..))
 import Cardano.CLI.Type.Error.StakePoolCmdError
 import Cardano.CLI.Type.Key (readVerificationKeyOrFile)
 
+import Cardano.Network.Ping qualified as Ping
+
+import Control.Tracer (nullTracer, (>$<))
+import Control.Monad (unless)
 import Data.ByteString.Char8 qualified as BS
 import Data.ByteString.Lazy qualified as LBS
 import Data.Function ((&))
@@ -86,6 +91,31 @@ runStakePoolRegistrationCertificateCmd
     , outFile
     } =
     obtainCommonConstraints era $ do
+      let pingOpts =
+            Ping.PingOpts {
+              Ping.pingOptsCount     = 1,
+              Ping.pingOptsMagic     = toNetworkMagic network,
+              Ping.pingOptsJson      = Ping.AsText,
+              Ping.pingOptsQuiet     = True,
+              Ping.pingOptsSRVPrefix = "_cardano._tcp",
+              Ping.pingOptsColor     = Ping.ColorNever,
+              Ping.pingOptsMode      = Ping.TipMode
+            }
+      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
+          (concatMap stakePoolRelayToAddr relays)
+
+      unless (null pingErrs) $
+        throwCliError (StakePoolCmdRelayPingErrors pingErrs)
+
       -- Pool verification key
       stakePoolVerKey <- getVerificationKeyFromStakePoolVerificationKeySource poolVerificationKeyOrFile
       let stakePoolId' = anyStakePoolVerificationKeyHash stakePoolVerKey

cardano-cli/src/Cardano/CLI/Type/Error/StakePoolCmdError.hs

@@ -8,6 +8,9 @@ module Cardano.CLI.Type.Error.StakePoolCmdError
   )
 where
 
+import Control.Exception (displayException)
+import Prettyprinter qualified as PP
+
 import Cardano.Api
 import Cardano.Api.Experimental.Certificate
   ( Hash (StakePoolMetadataHash)
@@ -17,6 +20,8 @@ import Cardano.Api.Experimental.Certificate
 
 import Cardano.CLI.Type.Error.HashCmdError (FetchURLError)
 
+import Cardano.Network.Ping (PingException)
+
 data StakePoolCmdError
   = StakePoolCmdReadFileError !(FileError TextEnvelopeError)
   | StakePoolCmdWriteFileError !(FileError ())
@@ -27,6 +32,7 @@ data StakePoolCmdError
       !(Hash StakePoolMetadata)
       -- ^ Actual hash
   | StakePoolCmdFetchURLError !FetchURLError
+  | StakePoolCmdRelayPingErrors ![PingException]
   deriving Show
 
 instance Error StakePoolCmdError where
@@ -47,3 +53,7 @@ instance Error StakePoolCmdError where
             <+> pretty (show actualHash)
     StakePoolCmdFetchURLError fetchErr ->
       "Error fetching stake pool metadata: " <> prettyException fetchErr
+    StakePoolCmdRelayPingErrors errs ->
+      PP.vsep ["Errors validating stake pool relays:"
+              , PP.indent 2 $ PP.vsep (PP.pretty . displayException <$> errs)
+              ]