{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}

#if !defined(mingw32_HOST_OS)
#define UNIX
#endif

module Bcc.Node.Run
  ( runNode
  , checkVRFFilePermissions
  ) where

import           Bcc.Prelude hiding (ByteString, atomically, take, trace)
import           Prelude (String)

import qualified Control.Concurrent.Async as Async
import           Control.Monad.Trans.Except.Extra (left)
import           Control.Tracer
import           Data.Text (breakOn, pack, take)
import qualified Data.Text as Text
import           Data.Time.Clock (getCurrentTime)
import           Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)
import           Data.Version (showVersion)
import           Network.HostName (getHostName)
import           Network.Socket (AddrInfo, Socket)
import           System.Directory (canonicalizePath, createDirectoryIfMissing, makeAbsolute)
import           System.Environment (lookupEnv)
#ifdef UNIX
import           System.Posix.Files
import           System.Posix.Types (FileMode)
#else
import           System.Win32.File
#endif

import           Bcc.BM.Data.LogItem (LOContent (..), LogObject (..), PrivacyAnnotation (..),
                   mkLOMeta)
import           Bcc.BM.Data.Tracer (ToLogObject (..), TracingVerbosity (..))
import           Bcc.BM.Data.Transformers (setHostname)
import           Bcc.BM.Trace
import           Paths_bcc_node (version)

import qualified Bcc.Crypto.Libsodium as Crypto

import           Bcc.Node.Configuration.Logging (LoggingLayer (..), Severity (..),
                   createLoggingLayer, nodeBasicInfo, shutdownLoggingLayer)
import           Bcc.Node.Configuration.POM (NodeConfiguration (..),
                   PartialNodeConfiguration (..), defaultPartialNodeConfiguration,
                   makeNodeConfiguration, parseNodeConfigurationFP)
import           Bcc.Node.Types
import           Bcc.Tracing.Config (TraceOptions (..), TraceSelection (..))
import           Bcc.Tracing.Constraints (TraceConstraints)
import           Bcc.Tracing.Metrics (HasKESInfo (..), HasKESMetricsData (..))

import qualified Shardagnostic.Consensus.Config as Consensus
import           Shardagnostic.Consensus.Config.SupportsNode (getNetworkMagic)
import           Shardagnostic.Consensus.Node (DiffusionArguments (..), DiffusionTracers (..),
                   DnsSubscriptionTarget (..), IPSubscriptionTarget (..), RunNode, RunNodeArgs (..),
                   StdRunNodeArgs (..))
import qualified Shardagnostic.Consensus.Node as Node (getChainDB, run)
import           Shardagnostic.Consensus.Node.ProtocolInfo
import           Shardagnostic.Consensus.Util.Orphans ()
import           Shardagnostic.Network.NodeToNode (AcceptedConnectionsLimit (..), DiffusionMode)

import           Bcc.Api
import qualified Bcc.Api.Protocol.Types as Protocol

import           Bcc.Node.Configuration.Socket (SocketOrSocketInfo (..),
                   gatherConfiguredSockets, getSocketOrSocketInfoAddr, renderSocketConfigError)
import           Bcc.Node.Configuration.Topology
import           Bcc.Node.Handlers.Shutdown
import           Bcc.Node.Protocol (mkConsensusProtocol)
import           Bcc.Node.Protocol.Types
import           Bcc.Tracing.Kernel
import           Bcc.Tracing.Peer
import           Bcc.Tracing.Tracers

{- HLINT ignore "Use fewer imports" -}

runNode
  :: PartialNodeConfiguration
  -> IO ()
runNode :: PartialNodeConfiguration -> IO ()
runNode PartialNodeConfiguration
cmdPc = do
    -- TODO: Remove sodiumInit: https://github.com/The-Blockchain-Company/bcc-base/issues/175
    IO ()
Crypto.sodiumInit

    PartialNodeConfiguration
configYamlPc <- Maybe ConfigYamlFilePath -> IO PartialNodeConfiguration
parseNodeConfigurationFP (Maybe ConfigYamlFilePath -> IO PartialNodeConfiguration)
-> (Last ConfigYamlFilePath -> Maybe ConfigYamlFilePath)
-> Last ConfigYamlFilePath
-> IO PartialNodeConfiguration
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Last ConfigYamlFilePath -> Maybe ConfigYamlFilePath
forall a. Last a -> Maybe a
getLast (Last ConfigYamlFilePath -> IO PartialNodeConfiguration)
-> Last ConfigYamlFilePath -> IO PartialNodeConfiguration
forall a b. (a -> b) -> a -> b
$ PartialNodeConfiguration -> Last ConfigYamlFilePath
pncConfigFile PartialNodeConfiguration
cmdPc

    NodeConfiguration
nc <- case PartialNodeConfiguration -> Either String NodeConfiguration
makeNodeConfiguration (PartialNodeConfiguration -> Either String NodeConfiguration)
-> PartialNodeConfiguration -> Either String NodeConfiguration
forall a b. (a -> b) -> a -> b
$ PartialNodeConfiguration
defaultPartialNodeConfiguration PartialNodeConfiguration
-> PartialNodeConfiguration -> PartialNodeConfiguration
forall a. Semigroup a => a -> a -> a
<> PartialNodeConfiguration
configYamlPc PartialNodeConfiguration
-> PartialNodeConfiguration -> PartialNodeConfiguration
forall a. Semigroup a => a -> a -> a
<> PartialNodeConfiguration
cmdPc of
            Left String
err -> Text -> IO NodeConfiguration
forall a. HasCallStack => Text -> a
panic (Text -> IO NodeConfiguration) -> Text -> IO NodeConfiguration
forall a b. (a -> b) -> a -> b
$ Text
"Error in creating the NodeConfiguration: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack String
err
            Right NodeConfiguration
nc' -> NodeConfiguration -> IO NodeConfiguration
forall (m :: * -> *) a. Monad m => a -> m a
return NodeConfiguration
nc'

    case ProtocolFilepaths -> Maybe String
sophieVRFFile (ProtocolFilepaths -> Maybe String)
-> ProtocolFilepaths -> Maybe String
forall a b. (a -> b) -> a -> b
$ NodeConfiguration -> ProtocolFilepaths
ncProtocolFiles NodeConfiguration
nc of
      Just String
vrfFp -> do Either VRFPrivateKeyFilePermissionError ()
vrf <- ExceptT VRFPrivateKeyFilePermissionError IO ()
-> IO (Either VRFPrivateKeyFilePermissionError ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT VRFPrivateKeyFilePermissionError IO ()
 -> IO (Either VRFPrivateKeyFilePermissionError ()))
-> ExceptT VRFPrivateKeyFilePermissionError IO ()
-> IO (Either VRFPrivateKeyFilePermissionError ())
forall a b. (a -> b) -> a -> b
$ String -> ExceptT VRFPrivateKeyFilePermissionError IO ()
checkVRFFilePermissions String
vrfFp
                       case Either VRFPrivateKeyFilePermissionError ()
vrf of
                         Left VRFPrivateKeyFilePermissionError
err ->
                           Text -> IO ()
putTextLn (VRFPrivateKeyFilePermissionError -> Text
renderVRFPrivateKeyFilePermissionError VRFPrivateKeyFilePermissionError
err) IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
forall a. IO a
exitFailure
                         Right () ->
                           () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Maybe String
Nothing -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

    Either ProtocolInstantiationError SomeConsensusProtocol
eitherSomeProtocol <- ExceptT ProtocolInstantiationError IO SomeConsensusProtocol
-> IO (Either ProtocolInstantiationError SomeConsensusProtocol)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT ProtocolInstantiationError IO SomeConsensusProtocol
 -> IO (Either ProtocolInstantiationError SomeConsensusProtocol))
-> ExceptT ProtocolInstantiationError IO SomeConsensusProtocol
-> IO (Either ProtocolInstantiationError SomeConsensusProtocol)
forall a b. (a -> b) -> a -> b
$ NodeConfiguration
-> ExceptT ProtocolInstantiationError IO SomeConsensusProtocol
mkConsensusProtocol NodeConfiguration
nc

    SomeConsensusProtocol
p :: SomeConsensusProtocol <-
      case Either ProtocolInstantiationError SomeConsensusProtocol
eitherSomeProtocol of
        Left ProtocolInstantiationError
err -> String -> IO ()
forall a (m :: * -> *). (Print a, MonadIO m) => a -> m ()
putStrLn (ProtocolInstantiationError -> String
forall e. Error e => e -> String
displayError ProtocolInstantiationError
err) IO () -> IO SomeConsensusProtocol -> IO SomeConsensusProtocol
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO SomeConsensusProtocol
forall a. IO a
exitFailure
        Right SomeConsensusProtocol
p -> SomeConsensusProtocol -> IO SomeConsensusProtocol
forall (f :: * -> *) a. Applicative f => a -> f a
pure SomeConsensusProtocol
p

    Either ConfigError LoggingLayer
eLoggingLayer <- ExceptT ConfigError IO LoggingLayer
-> IO (Either ConfigError LoggingLayer)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT ConfigError IO LoggingLayer
 -> IO (Either ConfigError LoggingLayer))
-> ExceptT ConfigError IO LoggingLayer
-> IO (Either ConfigError LoggingLayer)
forall a b. (a -> b) -> a -> b
$ Text
-> NodeConfiguration
-> SomeConsensusProtocol
-> ExceptT ConfigError IO LoggingLayer
createLoggingLayer
                     (String -> Text
Text.pack (Version -> String
showVersion Version
version))
                     NodeConfiguration
nc
                     SomeConsensusProtocol
p

    LoggingLayer
loggingLayer <- case Either ConfigError LoggingLayer
eLoggingLayer of
                      Left ConfigError
err  -> Text -> IO ()
putTextLn (ConfigError -> Text
forall a b. (Show a, ConvertText String b) => a -> b
show ConfigError
err) IO () -> IO LoggingLayer -> IO LoggingLayer
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO LoggingLayer
forall a. IO a
exitFailure
                      Right LoggingLayer
res -> LoggingLayer -> IO LoggingLayer
forall (m :: * -> *) a. Monad m => a -> m a
return LoggingLayer
res

    !Trace IO Text
trace <- LoggingLayer -> IO (Trace IO Text)
setupTrace LoggingLayer
loggingLayer
    let tracer :: Tracer IO String
tracer = (String -> Text) -> Tracer IO Text -> Tracer IO String
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap String -> Text
pack (Tracer IO Text -> Tracer IO String)
-> Tracer IO Text -> Tracer IO String
forall a b. (a -> b) -> a -> b
$ Trace IO Text -> Tracer IO Text
forall (m :: * -> *) a b.
(ToLogObject m, ToObject a, Transformable a m b) =>
Trace m a -> Tracer m b
toLogObject Trace IO Text
trace

    NodeConfiguration -> Tracer IO String -> IO ()
logTracingVerbosity NodeConfiguration
nc Tracer IO String
tracer

    let handleNodeWithTracers
          :: ( HasKESMetricsData blk
             , HasKESInfo blk
             , TraceConstraints blk
             , Protocol.Protocol IO blk
             )
          => Protocol.ProtocolInfoArgs IO blk
          -> IO ()
        handleNodeWithTracers :: ProtocolInfoArgs IO blk -> IO ()
handleNodeWithTracers ProtocolInfoArgs IO blk
runP = do
          -- This IORef contains node kernel structure which holds node kernel.
          -- Used for ledger queries and peer connection status.
          NodeKernelData blk
nodeKernelData <- IO (NodeKernelData blk)
forall blk. IO (NodeKernelData blk)
mkNodeKernelData
          let ProtocolInfo { pInfoConfig :: forall (m :: * -> *) b. ProtocolInfo m b -> TopLevelConfig b
pInfoConfig = TopLevelConfig blk
cfg } = ProtocolInfoArgs IO blk -> ProtocolInfo IO blk
forall (m :: * -> *) blk.
Protocol m blk =>
ProtocolInfoArgs m blk -> ProtocolInfo m blk
Protocol.protocolInfo ProtocolInfoArgs IO blk
runP
          Tracers RemoteConnectionId LocalConnectionId blk
tracers <- BlockConfig blk
-> TraceOptions
-> Trace IO Text
-> NodeKernelData blk
-> Maybe EKGDirect
-> IO (Tracers RemoteConnectionId LocalConnectionId blk)
forall peer localPeer blk.
(RunNode blk, HasKESMetricsData blk, HasKESInfo blk,
 TraceConstraints blk, Show peer, Eq peer, ToObject peer,
 Show localPeer, ToObject localPeer) =>
BlockConfig blk
-> TraceOptions
-> Trace IO Text
-> NodeKernelData blk
-> Maybe EKGDirect
-> IO (Tracers peer localPeer blk)
mkTracers
                       (TopLevelConfig blk -> BlockConfig blk
forall blk. TopLevelConfig blk -> BlockConfig blk
Consensus.configBlock TopLevelConfig blk
cfg)
                       (NodeConfiguration -> TraceOptions
ncTraceConfig NodeConfiguration
nc)
                       Trace IO Text
trace
                       NodeKernelData blk
nodeKernelData
                       (LoggingLayer -> Maybe EKGDirect
llEKGDirect LoggingLayer
loggingLayer)
          IO () -> (Async () -> IO ()) -> IO ()
forall a b. IO a -> (Async a -> IO b) -> IO b
Async.withAsync (Trace IO Text -> NodeKernelData blk -> IO ()
forall blk. Trace IO Text -> NodeKernelData blk -> IO ()
handlePeersListSimple Trace IO Text
trace NodeKernelData blk
nodeKernelData)
              ((Async () -> IO ()) -> IO ()) -> (Async () -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Async ()
_peerLogingThread ->
                -- We ignore peer loging thread if it dies, but it will be killed
                -- when 'handleSimpleNode' terminates.
                SomeConsensusProtocol
-> ProtocolInfoArgs IO blk
-> Trace IO Text
-> Tracers RemoteConnectionId LocalConnectionId blk
-> NodeConfiguration
-> (NodeKernel IO RemoteConnectionId LocalConnectionId blk
    -> IO ())
-> IO ()
forall blk.
(RunNode blk, Protocol IO blk) =>
SomeConsensusProtocol
-> ProtocolInfoArgs IO blk
-> Trace IO Text
-> Tracers RemoteConnectionId LocalConnectionId blk
-> NodeConfiguration
-> (NodeKernel IO RemoteConnectionId LocalConnectionId blk
    -> IO ())
-> IO ()
handleSimpleNode SomeConsensusProtocol
p ProtocolInfoArgs IO blk
runP Trace IO Text
trace Tracers RemoteConnectionId LocalConnectionId blk
tracers NodeConfiguration
nc (NodeKernelData blk
-> NodeKernel IO RemoteConnectionId LocalConnectionId blk -> IO ()
forall blk.
NodeKernelData blk
-> NodeKernel IO RemoteConnectionId LocalConnectionId blk -> IO ()
setNodeKernel NodeKernelData blk
nodeKernelData)
                IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`finally`
                LoggingLayer -> IO ()
shutdownLoggingLayer LoggingLayer
loggingLayer

    case SomeConsensusProtocol
p of
      SomeConsensusProtocol BlockType blk
_ ProtocolInfoArgs IO blk
runP -> ProtocolInfoArgs IO blk -> IO ()
forall blk.
(HasKESMetricsData blk, HasKESInfo blk, TraceConstraints blk,
 Protocol IO blk) =>
ProtocolInfoArgs IO blk -> IO ()
handleNodeWithTracers ProtocolInfoArgs IO blk
runP

logTracingVerbosity :: NodeConfiguration -> Tracer IO String -> IO ()
logTracingVerbosity :: NodeConfiguration -> Tracer IO String -> IO ()
logTracingVerbosity NodeConfiguration
nc Tracer IO String
tracer =
  case NodeConfiguration -> TraceOptions
ncTraceConfig NodeConfiguration
nc of
    TraceOptions
TracingOff -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    TracingOn TraceSelection
traceConf ->
      case TraceSelection -> TracingVerbosity
traceVerbosity TraceSelection
traceConf of
        TracingVerbosity
NormalVerbosity -> Tracer IO String -> String -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO String
tracer String
"tracing verbosity = normal verbosity "
        TracingVerbosity
MinimalVerbosity -> Tracer IO String -> String -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO String
tracer String
"tracing verbosity = minimal verbosity "
        TracingVerbosity
MaximalVerbosity -> Tracer IO String -> String -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO String
tracer String
"tracing verbosity = maximal verbosity "

-- | Add the application name and unqualified hostname to the logging
-- layer basic trace.
--
-- If the @BCC_NODE_LOGGING_HOSTNAME@ environment variable is set,
-- it overrides the system hostname. This is useful when running a
-- local test cluster with all nodes on the same host.
setupTrace
  :: LoggingLayer
  -> IO (Trace IO Text)
setupTrace :: LoggingLayer -> IO (Trace IO Text)
setupTrace LoggingLayer
loggingLayer = do
    Text
hn <- IO Text -> (String -> IO Text) -> Maybe String -> IO Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO Text
hostname (Text -> IO Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> IO Text) -> (String -> Text) -> String -> IO Text
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> Text
pack) (Maybe String -> IO Text) -> IO (Maybe String) -> IO Text
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> IO (Maybe String)
lookupEnv String
"BCC_NODE_LOGGING_HOSTNAME"
    Trace IO Text -> IO (Trace IO Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Trace IO Text -> IO (Trace IO Text))
-> Trace IO Text -> IO (Trace IO Text)
forall a b. (a -> b) -> a -> b
$
        Text -> Trace IO Text -> Trace IO Text
forall (m :: * -> *) a. Text -> Trace m a -> Trace m a
setHostname Text
hn (Trace IO Text -> Trace IO Text) -> Trace IO Text -> Trace IO Text
forall a b. (a -> b) -> a -> b
$
        LoggingLayer -> Text -> Trace IO Text -> Trace IO Text
LoggingLayer
-> forall (m :: * -> *) a. Show a => Text -> Trace m a -> Trace m a
llAppendName LoggingLayer
loggingLayer Text
"node" (LoggingLayer -> forall (m :: * -> *). MonadIO m => Trace m Text
llBasicTrace LoggingLayer
loggingLayer)
  where
    hostname :: IO Text
hostname = do
      Text
hn0 <- String -> Text
pack (String -> Text) -> IO String -> IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO String
getHostName
      Text -> IO Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> IO Text) -> Text -> IO Text
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
take Int
8 (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ (Text, Text) -> Text
forall a b. (a, b) -> a
fst ((Text, Text) -> Text) -> (Text, Text) -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text -> (Text, Text)
breakOn Text
"." Text
hn0

handlePeersListSimple
  :: Trace IO Text
  -> NodeKernelData blk
  -> IO ()
handlePeersListSimple :: Trace IO Text -> NodeKernelData blk -> IO ()
handlePeersListSimple Trace IO Text
tr NodeKernelData blk
nodeKern = IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  NodeKernelData blk -> IO [Peer blk]
forall blk. NodeKernelData blk -> IO [Peer blk]
getCurrentPeers NodeKernelData blk
nodeKern IO [Peer blk] -> ([Peer blk] -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Trace IO Text -> [Peer blk] -> IO ()
forall blk. Trace IO Text -> [Peer blk] -> IO ()
tracePeers Trace IO Text
tr
  Int -> IO ()
threadDelay Int
2000000 -- 2 seconds.

-- | Sets up a simple node, which will run the chain sync protocol and block
-- fetch protocol, and, if core, will also look at the mempool when trying to
-- create a new block.

handleSimpleNode
  :: forall blk
  . ( RunNode blk
    , Protocol.Protocol IO blk
    )
  => SomeConsensusProtocol
  -> Protocol.ProtocolInfoArgs IO blk
  -> Trace IO Text
  -> Tracers RemoteConnectionId LocalConnectionId blk
  -> NodeConfiguration
  -> (NodeKernel IO RemoteConnectionId LocalConnectionId blk -> IO ())
  -- ^ Called on the 'NodeKernel' after creating it, but before the network
  -- layer is initialised.  This implies this function must not block,
  -- otherwise the node won't actually start.
  -> IO ()
handleSimpleNode :: SomeConsensusProtocol
-> ProtocolInfoArgs IO blk
-> Trace IO Text
-> Tracers RemoteConnectionId LocalConnectionId blk
-> NodeConfiguration
-> (NodeKernel IO RemoteConnectionId LocalConnectionId blk
    -> IO ())
-> IO ()
handleSimpleNode SomeConsensusProtocol
scp ProtocolInfoArgs IO blk
runP Trace IO Text
trace Tracers RemoteConnectionId LocalConnectionId blk
nodeTracers NodeConfiguration
nc NodeKernel IO RemoteConnectionId LocalConnectionId blk -> IO ()
onKernel = do
  LOMeta
meta <- Severity -> PrivacyAnnotation -> IO LOMeta
forall (m :: * -> *).
MonadIO m =>
Severity -> PrivacyAnnotation -> m LOMeta
mkLOMeta Severity
Notice PrivacyAnnotation
Public

  let pInfo :: ProtocolInfo IO blk
pInfo = ProtocolInfoArgs IO blk -> ProtocolInfo IO blk
forall (m :: * -> *) blk.
Protocol m blk =>
ProtocolInfoArgs m blk -> ProtocolInfo m blk
Protocol.protocolInfo ProtocolInfoArgs IO blk
runP
      tracer :: Tracer IO Text
tracer = Trace IO Text -> Tracer IO Text
forall (m :: * -> *) a b.
(ToLogObject m, ToObject a, Transformable a m b) =>
Trace m a -> Tracer m b
toLogObject Trace IO Text
trace

  NodeConfiguration -> Trace IO Text -> Tracer IO Text -> IO ()
createTracers NodeConfiguration
nc Trace IO Text
trace Tracer IO Text
tracer

  (Maybe (SocketOrSocketInfo Socket AddrInfo)
publicIPv4SocketOrAddr, Maybe (SocketOrSocketInfo Socket AddrInfo)
publicIPv6SocketOrAddr, Maybe (SocketOrSocketInfo Socket SocketPath)
localSocketOrPath) <- do
    Either
  SocketConfigError
  (Maybe (SocketOrSocketInfo Socket AddrInfo),
   Maybe (SocketOrSocketInfo Socket AddrInfo),
   Maybe (SocketOrSocketInfo Socket SocketPath))
result <- ExceptT
  SocketConfigError
  IO
  (Maybe (SocketOrSocketInfo Socket AddrInfo),
   Maybe (SocketOrSocketInfo Socket AddrInfo),
   Maybe (SocketOrSocketInfo Socket SocketPath))
-> IO
     (Either
        SocketConfigError
        (Maybe (SocketOrSocketInfo Socket AddrInfo),
         Maybe (SocketOrSocketInfo Socket AddrInfo),
         Maybe (SocketOrSocketInfo Socket SocketPath)))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (NodeConfiguration
-> ExceptT
     SocketConfigError
     IO
     (Maybe (SocketOrSocketInfo Socket AddrInfo),
      Maybe (SocketOrSocketInfo Socket AddrInfo),
      Maybe (SocketOrSocketInfo Socket SocketPath))
gatherConfiguredSockets NodeConfiguration
nc)
    case Either
  SocketConfigError
  (Maybe (SocketOrSocketInfo Socket AddrInfo),
   Maybe (SocketOrSocketInfo Socket AddrInfo),
   Maybe (SocketOrSocketInfo Socket SocketPath))
result of
      Right (Maybe (SocketOrSocketInfo Socket AddrInfo),
 Maybe (SocketOrSocketInfo Socket AddrInfo),
 Maybe (SocketOrSocketInfo Socket SocketPath))
triplet -> (Maybe (SocketOrSocketInfo Socket AddrInfo),
 Maybe (SocketOrSocketInfo Socket AddrInfo),
 Maybe (SocketOrSocketInfo Socket SocketPath))
-> IO
     (Maybe (SocketOrSocketInfo Socket AddrInfo),
      Maybe (SocketOrSocketInfo Socket AddrInfo),
      Maybe (SocketOrSocketInfo Socket SocketPath))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (SocketOrSocketInfo Socket AddrInfo),
 Maybe (SocketOrSocketInfo Socket AddrInfo),
 Maybe (SocketOrSocketInfo Socket SocketPath))
triplet
      Left SocketConfigError
error -> do
        Trace IO Text -> (LOMeta, LOContent Text) -> IO ()
forall (m :: * -> *) a.
MonadIO m =>
Trace m a -> (LOMeta, LOContent a) -> m ()
traceNamedObject
          (Text -> Trace IO Text -> Trace IO Text
forall (m :: * -> *) a. Text -> Trace m a -> Trace m a
appendName Text
"error" Trace IO Text
trace)
          (LOMeta
meta, Text -> LOContent Text
forall a. a -> LOContent a
LogMessage (String -> Text
Text.pack (SocketConfigError -> String
renderSocketConfigError SocketConfigError
error)))
        SocketConfigError
-> IO
     (Maybe (SocketOrSocketInfo Socket AddrInfo),
      Maybe (SocketOrSocketInfo Socket AddrInfo),
      Maybe (SocketOrSocketInfo Socket SocketPath))
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO SocketConfigError
error

  String
dbPath <- NodeConfiguration -> IO String
canonDbPath NodeConfiguration
nc

  Either Text NetworkTopology
eitherTopology <- NodeConfiguration -> IO (Either Text NetworkTopology)
readTopologyFile NodeConfiguration
nc
  NetworkTopology
nt <- (Text -> IO NetworkTopology)
-> (NetworkTopology -> IO NetworkTopology)
-> Either Text NetworkTopology
-> IO NetworkTopology
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\Text
err -> Text -> IO NetworkTopology
forall a. HasCallStack => Text -> a
panic (Text -> IO NetworkTopology) -> Text -> IO NetworkTopology
forall a b. (a -> b) -> a -> b
$ Text
"Bcc.Node.Run.handleSimpleNode.readTopologyFile: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
err) NetworkTopology -> IO NetworkTopology
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either Text NetworkTopology
eitherTopology

  let diffusionTracers :: DiffusionTracers
      diffusionTracers :: DiffusionTracers
diffusionTracers = Tracers RemoteConnectionId LocalConnectionId blk
-> DiffusionTracers
createDiffusionTracers Tracers RemoteConnectionId LocalConnectionId blk
nodeTracers

      ([NodeIPAddress]
ipProducerAddrs, [(NodeDnsAddress, Int)]
dnsProducerAddrs) = NetworkTopology -> ([NodeIPAddress], [(NodeDnsAddress, Int)])
producerAddresses NetworkTopology
nt

      dnsProducers :: [DnsSubscriptionTarget]
      dnsProducers :: [DnsSubscriptionTarget]
dnsProducers = (NodeDnsAddress -> Int -> DnsSubscriptionTarget)
-> (NodeDnsAddress, Int) -> DnsSubscriptionTarget
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry NodeDnsAddress -> Int -> DnsSubscriptionTarget
dnsSubscriptionTarget ((NodeDnsAddress, Int) -> DnsSubscriptionTarget)
-> [(NodeDnsAddress, Int)] -> [DnsSubscriptionTarget]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`map` [(NodeDnsAddress, Int)]
dnsProducerAddrs

      ipProducers :: IPSubscriptionTarget
      ipProducers :: IPSubscriptionTarget
ipProducers = [NodeIPAddress] -> IPSubscriptionTarget
ipSubscriptionTargets [NodeIPAddress]
ipProducerAddrs

      diffusionArguments :: DiffusionArguments
      diffusionArguments :: DiffusionArguments
diffusionArguments =
        Maybe (SocketOrSocketInfo Socket AddrInfo)
-> Maybe (SocketOrSocketInfo Socket AddrInfo)
-> Maybe (SocketOrSocketInfo Socket SocketPath)
-> DiffusionMode
-> IPSubscriptionTarget
-> [DnsSubscriptionTarget]
-> DiffusionArguments
createDiffusionArguments
          Maybe (SocketOrSocketInfo Socket AddrInfo)
publicIPv4SocketOrAddr
          Maybe (SocketOrSocketInfo Socket AddrInfo)
publicIPv6SocketOrAddr
          Maybe (SocketOrSocketInfo Socket SocketPath)
localSocketOrPath
          (NodeConfiguration -> DiffusionMode
ncDiffusionMode NodeConfiguration
nc)
          IPSubscriptionTarget
ipProducers
          [DnsSubscriptionTarget]
dnsProducers

  Maybe (SocketOrSocketInfo SockAddr SockAddr)
ipv4 <- (SocketOrSocketInfo Socket AddrInfo
 -> IO (SocketOrSocketInfo SockAddr SockAddr))
-> Maybe (SocketOrSocketInfo Socket AddrInfo)
-> IO (Maybe (SocketOrSocketInfo SockAddr SockAddr))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse SocketOrSocketInfo Socket AddrInfo
-> IO (SocketOrSocketInfo SockAddr SockAddr)
getSocketOrSocketInfoAddr Maybe (SocketOrSocketInfo Socket AddrInfo)
publicIPv4SocketOrAddr
  Maybe (SocketOrSocketInfo SockAddr SockAddr)
ipv6 <- (SocketOrSocketInfo Socket AddrInfo
 -> IO (SocketOrSocketInfo SockAddr SockAddr))
-> Maybe (SocketOrSocketInfo Socket AddrInfo)
-> IO (Maybe (SocketOrSocketInfo SockAddr SockAddr))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse SocketOrSocketInfo Socket AddrInfo
-> IO (SocketOrSocketInfo SockAddr SockAddr)
getSocketOrSocketInfoAddr Maybe (SocketOrSocketInfo Socket AddrInfo)
publicIPv6SocketOrAddr

  Trace IO Text -> (LOMeta, LOContent Text) -> IO ()
forall (m :: * -> *) a.
MonadIO m =>
Trace m a -> (LOMeta, LOContent a) -> m ()
traceNamedObject
    (Text -> Trace IO Text -> Trace IO Text
forall (m :: * -> *) a. Text -> Trace m a -> Trace m a
appendName Text
"addresses" Trace IO Text
trace)
    (LOMeta
meta, Text -> LOContent Text
forall a. a -> LOContent a
LogMessage (Text -> LOContent Text)
-> ([SocketOrSocketInfo SockAddr SockAddr] -> Text)
-> [SocketOrSocketInfo SockAddr SockAddr]
-> LOContent Text
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> Text
Text.pack (String -> Text)
-> ([SocketOrSocketInfo SockAddr SockAddr] -> String)
-> [SocketOrSocketInfo SockAddr SockAddr]
-> Text
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. [SocketOrSocketInfo SockAddr SockAddr] -> String
forall a b. (Show a, ConvertText String b) => a -> b
show ([SocketOrSocketInfo SockAddr SockAddr] -> LOContent Text)
-> [SocketOrSocketInfo SockAddr SockAddr] -> LOContent Text
forall a b. (a -> b) -> a -> b
$ [Maybe (SocketOrSocketInfo SockAddr SockAddr)]
-> [SocketOrSocketInfo SockAddr SockAddr]
forall a. [Maybe a] -> [a]
catMaybes [Maybe (SocketOrSocketInfo SockAddr SockAddr)
ipv4, Maybe (SocketOrSocketInfo SockAddr SockAddr)
ipv6])
  Trace IO Text -> (LOMeta, LOContent Text) -> IO ()
forall (m :: * -> *) a.
MonadIO m =>
Trace m a -> (LOMeta, LOContent a) -> m ()
traceNamedObject
    (Text -> Trace IO Text -> Trace IO Text
forall (m :: * -> *) a. Text -> Trace m a -> Trace m a
appendName Text
"diffusion-mode" Trace IO Text
trace)
    (LOMeta
meta, Text -> LOContent Text
forall a. a -> LOContent a
LogMessage (Text -> LOContent Text)
-> (NodeConfiguration -> Text)
-> NodeConfiguration
-> LOContent Text
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> Text
Text.pack (String -> Text)
-> (NodeConfiguration -> String) -> NodeConfiguration -> Text
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. DiffusionMode -> String
forall a b. (Show a, ConvertText String b) => a -> b
show (DiffusionMode -> String)
-> (NodeConfiguration -> DiffusionMode)
-> NodeConfiguration
-> String
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. NodeConfiguration -> DiffusionMode
ncDiffusionMode (NodeConfiguration -> LOContent Text)
-> NodeConfiguration -> LOContent Text
forall a b. (a -> b) -> a -> b
$ NodeConfiguration
nc)
  Trace IO Text -> (LOMeta, LOContent Text) -> IO ()
forall (m :: * -> *) a.
MonadIO m =>
Trace m a -> (LOMeta, LOContent a) -> m ()
traceNamedObject
    (Text -> Trace IO Text -> Trace IO Text
forall (m :: * -> *) a. Text -> Trace m a -> Trace m a
appendName Text
"dns-producers" Trace IO Text
trace)
    (LOMeta
meta, Text -> LOContent Text
forall a. a -> LOContent a
LogMessage (Text -> LOContent Text)
-> ([DnsSubscriptionTarget] -> Text)
-> [DnsSubscriptionTarget]
-> LOContent Text
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> Text
Text.pack (String -> Text)
-> ([DnsSubscriptionTarget] -> String)
-> [DnsSubscriptionTarget]
-> Text
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. [DnsSubscriptionTarget] -> String
forall a b. (Show a, ConvertText String b) => a -> b
show ([DnsSubscriptionTarget] -> LOContent Text)
-> [DnsSubscriptionTarget] -> LOContent Text
forall a b. (a -> b) -> a -> b
$ [DnsSubscriptionTarget]
dnsProducers)
  Trace IO Text -> (LOMeta, LOContent Text) -> IO ()
forall (m :: * -> *) a.
MonadIO m =>
Trace m a -> (LOMeta, LOContent a) -> m ()
traceNamedObject
    (Text -> Trace IO Text -> Trace IO Text
forall (m :: * -> *) a. Text -> Trace m a -> Trace m a
appendName Text
"ip-producers" Trace IO Text
trace)
    (LOMeta
meta, Text -> LOContent Text
forall a. a -> LOContent a
LogMessage (Text -> LOContent Text)
-> (IPSubscriptionTarget -> Text)
-> IPSubscriptionTarget
-> LOContent Text
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> Text
Text.pack (String -> Text)
-> (IPSubscriptionTarget -> String) -> IPSubscriptionTarget -> Text
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. IPSubscriptionTarget -> String
forall a b. (Show a, ConvertText String b) => a -> b
show (IPSubscriptionTarget -> LOContent Text)
-> IPSubscriptionTarget -> LOContent Text
forall a b. (a -> b) -> a -> b
$ IPSubscriptionTarget
ipProducers)

  NodeConfiguration
-> Trace IO Text -> (ShutdownFDs -> IO ()) -> IO ()
withShutdownHandling NodeConfiguration
nc Trace IO Text
trace ((ShutdownFDs -> IO ()) -> IO ())
-> (ShutdownFDs -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ShutdownFDs
sfds ->
   RunNodeArgs IO SockAddr LocalAddress blk
-> StdRunNodeArgs IO blk -> IO ()
forall blk.
RunNode blk =>
RunNodeArgs IO SockAddr LocalAddress blk
-> StdRunNodeArgs IO blk -> IO ()
Node.run
     RunNodeArgs :: forall (m :: * -> *) addrNTN addrNTC blk.
Tracers m (ConnectionId addrNTN) (ConnectionId addrNTC) blk
-> Tracers m (ConnectionId addrNTN) blk DeserialiseFailure
-> Tracers m (ConnectionId addrNTC) blk DeserialiseFailure
-> ProtocolInfo m blk
-> (ResourceRegistry m
    -> NodeKernel m (ConnectionId addrNTN) (ConnectionId addrNTC) blk
    -> m ())
-> RunNodeArgs m addrNTN addrNTC blk
RunNodeArgs
       { rnTraceConsensus :: Tracers IO RemoteConnectionId LocalConnectionId blk
rnTraceConsensus = Tracers RemoteConnectionId LocalConnectionId blk
-> Tracers IO RemoteConnectionId LocalConnectionId blk
forall peer localPeer blk.
Tracers peer localPeer blk -> Tracers IO peer localPeer blk
consensusTracers Tracers RemoteConnectionId LocalConnectionId blk
nodeTracers
       , rnTraceNTN :: Tracers IO RemoteConnectionId blk DeserialiseFailure
rnTraceNTN       = Tracers RemoteConnectionId LocalConnectionId blk
-> Tracers IO RemoteConnectionId blk DeserialiseFailure
forall peer localPeer blk.
Tracers peer localPeer blk
-> Tracers IO peer blk DeserialiseFailure
nodeToNodeTracers Tracers RemoteConnectionId LocalConnectionId blk
nodeTracers
       , rnTraceNTC :: Tracers IO LocalConnectionId blk DeserialiseFailure
rnTraceNTC       = Tracers RemoteConnectionId LocalConnectionId blk
-> Tracers IO LocalConnectionId blk DeserialiseFailure
forall peer localPeer blk.
Tracers peer localPeer blk
-> Tracers IO localPeer blk DeserialiseFailure
nodeToClientTracers Tracers RemoteConnectionId LocalConnectionId blk
nodeTracers
       , rnProtocolInfo :: ProtocolInfo IO blk
rnProtocolInfo   = ProtocolInfo IO blk
pInfo
       , rnNodeKernelHook :: ResourceRegistry IO
-> NodeKernel IO RemoteConnectionId LocalConnectionId blk -> IO ()
rnNodeKernelHook = \ResourceRegistry IO
registry NodeKernel IO RemoteConnectionId LocalConnectionId blk
nodeKernel -> do
           NodeConfiguration
-> ShutdownFDs
-> Trace IO Text
-> ResourceRegistry IO
-> ChainDB IO blk
-> IO ()
forall blk.
NodeConfiguration
-> ShutdownFDs
-> Trace IO Text
-> ResourceRegistry IO
-> ChainDB IO blk
-> IO ()
maybeSpawnOnSlotSyncedShutdownHandler NodeConfiguration
nc ShutdownFDs
sfds Trace IO Text
trace ResourceRegistry IO
registry
             (NodeKernel IO RemoteConnectionId LocalConnectionId blk
-> ChainDB IO blk
forall (m :: * -> *) remotePeer localPeer blk.
NodeKernel m remotePeer localPeer blk -> ChainDB m blk
Node.getChainDB NodeKernel IO RemoteConnectionId LocalConnectionId blk
nodeKernel)
           NodeKernel IO RemoteConnectionId LocalConnectionId blk -> IO ()
onKernel NodeKernel IO RemoteConnectionId LocalConnectionId blk
nodeKernel
       }
     StdRunNodeArgs :: forall (m :: * -> *) blk.
Maybe Word
-> Maybe Word
-> Bool
-> SnapshotInterval
-> String
-> DiffusionArguments
-> DiffusionTracers
-> Bool
-> Tracer m (TraceEvent blk)
-> StdRunNodeArgs m blk
StdRunNodeArgs
       { srnBfcMaxConcurrencyBulkSync :: Maybe Word
srnBfcMaxConcurrencyBulkSync   = MaxConcurrencyBulkSync -> Word
unMaxConcurrencyBulkSync (MaxConcurrencyBulkSync -> Word)
-> Maybe MaxConcurrencyBulkSync -> Maybe Word
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NodeConfiguration -> Maybe MaxConcurrencyBulkSync
ncMaxConcurrencyBulkSync NodeConfiguration
nc
       , srnBfcMaxConcurrencyDeadline :: Maybe Word
srnBfcMaxConcurrencyDeadline   = MaxConcurrencyDeadline -> Word
unMaxConcurrencyDeadline (MaxConcurrencyDeadline -> Word)
-> Maybe MaxConcurrencyDeadline -> Maybe Word
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NodeConfiguration -> Maybe MaxConcurrencyDeadline
ncMaxConcurrencyDeadline NodeConfiguration
nc
       , srnChainDbValidateOverride :: Bool
srnChainDbValidateOverride     = NodeConfiguration -> Bool
ncValidateDB NodeConfiguration
nc
       , srnSnapshotInterval :: SnapshotInterval
srnSnapshotInterval            = NodeConfiguration -> SnapshotInterval
ncSnapshotInterval NodeConfiguration
nc
       , srnDatabasePath :: String
srnDatabasePath                = String
dbPath
       , srnDiffusionArguments :: DiffusionArguments
srnDiffusionArguments          = DiffusionArguments
diffusionArguments
       , srnDiffusionTracers :: DiffusionTracers
srnDiffusionTracers            = DiffusionTracers
diffusionTracers
       , srnEnableInDevelopmentVersions :: Bool
srnEnableInDevelopmentVersions = NodeConfiguration -> Bool
ncTestEnableDevelopmentNetworkProtocols NodeConfiguration
nc
       , srnTraceChainDB :: Tracer IO (TraceEvent blk)
srnTraceChainDB                = Tracers RemoteConnectionId LocalConnectionId blk
-> Tracer IO (TraceEvent blk)
forall peer localPeer blk.
Tracers peer localPeer blk -> Tracer IO (TraceEvent blk)
chainDBTracer Tracers RemoteConnectionId LocalConnectionId blk
nodeTracers
       }
 where
  createDiffusionTracers :: Tracers RemoteConnectionId LocalConnectionId blk
                         -> DiffusionTracers
  createDiffusionTracers :: Tracers RemoteConnectionId LocalConnectionId blk
-> DiffusionTracers
createDiffusionTracers Tracers RemoteConnectionId LocalConnectionId blk
nodeTracers' = DiffusionTracers :: Tracer IO (WithIPList (SubscriptionTrace SockAddr))
-> Tracer IO (WithDomainName (SubscriptionTrace SockAddr))
-> Tracer IO (WithDomainName DnsTrace)
-> Tracer IO (WithMuxBearer RemoteConnectionId MuxTrace)
-> Tracer IO (WithMuxBearer LocalConnectionId MuxTrace)
-> Tracer IO HandshakeTr
-> Tracer IO HandshakeTr
-> Tracer IO (WithAddr SockAddr ErrorPolicyTrace)
-> Tracer IO (WithAddr LocalAddress ErrorPolicyTrace)
-> Tracer IO AcceptConnectionsPolicyTrace
-> Tracer IO DiffusionInitializationTracer
-> Tracer IO TraceLedgerPeers
-> DiffusionTracers
DiffusionTracers
    { dtIpSubscriptionTracer :: Tracer IO (WithIPList (SubscriptionTrace SockAddr))
dtIpSubscriptionTracer = Tracers RemoteConnectionId LocalConnectionId blk
-> Tracer IO (WithIPList (SubscriptionTrace SockAddr))
forall peer localPeer blk.
Tracers peer localPeer blk
-> Tracer IO (WithIPList (SubscriptionTrace SockAddr))
ipSubscriptionTracer Tracers RemoteConnectionId LocalConnectionId blk
nodeTracers'
    , dtDnsSubscriptionTracer :: Tracer IO (WithDomainName (SubscriptionTrace SockAddr))
dtDnsSubscriptionTracer = Tracers RemoteConnectionId LocalConnectionId blk
-> Tracer IO (WithDomainName (SubscriptionTrace SockAddr))
forall peer localPeer blk.
Tracers peer localPeer blk
-> Tracer IO (WithDomainName (SubscriptionTrace SockAddr))
dnsSubscriptionTracer Tracers RemoteConnectionId LocalConnectionId blk
nodeTracers'
    , dtDnsResolverTracer :: Tracer IO (WithDomainName DnsTrace)
dtDnsResolverTracer = Tracers RemoteConnectionId LocalConnectionId blk
-> Tracer IO (WithDomainName DnsTrace)
forall peer localPeer blk.
Tracers peer localPeer blk -> Tracer IO (WithDomainName DnsTrace)
dnsResolverTracer Tracers RemoteConnectionId LocalConnectionId blk
nodeTracers'
    , dtErrorPolicyTracer :: Tracer IO (WithAddr SockAddr ErrorPolicyTrace)
dtErrorPolicyTracer = Tracers RemoteConnectionId LocalConnectionId blk
-> Tracer IO (WithAddr SockAddr ErrorPolicyTrace)
forall peer localPeer blk.
Tracers peer localPeer blk
-> Tracer IO (WithAddr SockAddr ErrorPolicyTrace)
errorPolicyTracer Tracers RemoteConnectionId LocalConnectionId blk
nodeTracers'
    , dtLocalErrorPolicyTracer :: Tracer IO (WithAddr LocalAddress ErrorPolicyTrace)
dtLocalErrorPolicyTracer = Tracers RemoteConnectionId LocalConnectionId blk
-> Tracer IO (WithAddr LocalAddress ErrorPolicyTrace)
forall peer localPeer blk.
Tracers peer localPeer blk
-> Tracer IO (WithAddr LocalAddress ErrorPolicyTrace)
localErrorPolicyTracer Tracers RemoteConnectionId LocalConnectionId blk
nodeTracers'
    , dtAcceptPolicyTracer :: Tracer IO AcceptConnectionsPolicyTrace
dtAcceptPolicyTracer = Tracers RemoteConnectionId LocalConnectionId blk
-> Tracer IO AcceptConnectionsPolicyTrace
forall peer localPeer blk.
Tracers peer localPeer blk
-> Tracer IO AcceptConnectionsPolicyTrace
acceptPolicyTracer Tracers RemoteConnectionId LocalConnectionId blk
nodeTracers'
    , dtMuxTracer :: Tracer IO (WithMuxBearer RemoteConnectionId MuxTrace)
dtMuxTracer = Tracers RemoteConnectionId LocalConnectionId blk
-> Tracer IO (WithMuxBearer RemoteConnectionId MuxTrace)
forall peer localPeer blk.
Tracers peer localPeer blk
-> Tracer IO (WithMuxBearer peer MuxTrace)
muxTracer Tracers RemoteConnectionId LocalConnectionId blk
nodeTracers'
    , dtMuxLocalTracer :: Tracer IO (WithMuxBearer LocalConnectionId MuxTrace)
dtMuxLocalTracer = Tracers RemoteConnectionId LocalConnectionId blk
-> Tracer IO (WithMuxBearer LocalConnectionId MuxTrace)
forall peer localPeer blk.
Tracers peer localPeer blk
-> Tracer IO (WithMuxBearer localPeer MuxTrace)
muxLocalTracer Tracers RemoteConnectionId LocalConnectionId blk
nodeTracers'
    , dtHandshakeTracer :: Tracer IO HandshakeTr
dtHandshakeTracer = Tracers RemoteConnectionId LocalConnectionId blk
-> Tracer IO HandshakeTr
forall peer localPeer blk.
Tracers peer localPeer blk -> Tracer IO HandshakeTr
handshakeTracer Tracers RemoteConnectionId LocalConnectionId blk
nodeTracers'
    , dtHandshakeLocalTracer :: Tracer IO HandshakeTr
dtHandshakeLocalTracer = Tracers RemoteConnectionId LocalConnectionId blk
-> Tracer IO HandshakeTr
forall peer localPeer blk.
Tracers peer localPeer blk -> Tracer IO HandshakeTr
localHandshakeTracer Tracers RemoteConnectionId LocalConnectionId blk
nodeTracers'
    , dtDiffusionInitializationTracer :: Tracer IO DiffusionInitializationTracer
dtDiffusionInitializationTracer = Tracers RemoteConnectionId LocalConnectionId blk
-> Tracer IO DiffusionInitializationTracer
forall peer localPeer blk.
Tracers peer localPeer blk
-> Tracer IO DiffusionInitializationTracer
diffusionInitializationTracer Tracers RemoteConnectionId LocalConnectionId blk
nodeTracers'
    , dtLedgerPeersTracer :: Tracer IO TraceLedgerPeers
dtLedgerPeersTracer = Tracer IO TraceLedgerPeers
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer -- TODO network team
    }

  createTracers
    :: NodeConfiguration
    -> Trace IO Text
    -> Tracer IO Text
    -> IO ()
  createTracers :: NodeConfiguration -> Trace IO Text -> Tracer IO Text -> IO ()
createTracers NodeConfiguration { Bool
ncValidateDB :: Bool
ncValidateDB :: NodeConfiguration -> Bool
ncValidateDB }
                Trace IO Text
tr Tracer IO Text
tracer = do
    let ProtocolInfo{ pInfoConfig :: forall (m :: * -> *) b. ProtocolInfo m b -> TopLevelConfig b
pInfoConfig = TopLevelConfig blk
cfg } = ProtocolInfoArgs IO blk -> ProtocolInfo IO blk
forall (m :: * -> *) blk.
Protocol m blk =>
ProtocolInfoArgs m blk -> ProtocolInfo m blk
Protocol.protocolInfo ProtocolInfoArgs IO blk
runP

    LOMeta
meta <- Severity -> PrivacyAnnotation -> IO LOMeta
forall (m :: * -> *).
MonadIO m =>
Severity -> PrivacyAnnotation -> m LOMeta
mkLOMeta Severity
Notice PrivacyAnnotation
Public
    Trace IO Text -> (LOMeta, LOContent Text) -> IO ()
forall (m :: * -> *) a.
MonadIO m =>
Trace m a -> (LOMeta, LOContent a) -> m ()
traceNamedObject (Text -> Trace IO Text -> Trace IO Text
forall (m :: * -> *) a. Text -> Trace m a -> Trace m a
appendName Text
"networkMagic" Trace IO Text
tr)
                     (LOMeta
meta, Text -> LOContent Text
forall a. a -> LOContent a
LogMessage (Text
"NetworkMagic " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word32 -> Text
forall a b. (Show a, ConvertText String b) => a -> b
show (NetworkMagic -> Word32
unNetworkMagic (NetworkMagic -> Word32)
-> (BlockConfig blk -> NetworkMagic) -> BlockConfig blk -> Word32
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. BlockConfig blk -> NetworkMagic
forall blk.
ConfigSupportsNode blk =>
BlockConfig blk -> NetworkMagic
getNetworkMagic (BlockConfig blk -> Word32) -> BlockConfig blk -> Word32
forall a b. (a -> b) -> a -> b
$ TopLevelConfig blk -> BlockConfig blk
forall blk. TopLevelConfig blk -> BlockConfig blk
Consensus.configBlock TopLevelConfig blk
cfg)))

    UTCTime
startTime <- IO UTCTime
getCurrentTime
    Trace IO Text -> [LogObject Text] -> IO ()
traceNodeBasicInfo Trace IO Text
tr ([LogObject Text] -> IO ()) -> IO [LogObject Text] -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< NodeConfiguration
-> SomeConsensusProtocol -> UTCTime -> IO [LogObject Text]
nodeBasicInfo NodeConfiguration
nc SomeConsensusProtocol
scp UTCTime
startTime
    Text -> Trace IO Text -> Int -> IO ()
traceCounter Text
"nodeStartTime" Trace IO Text
tr (POSIXTime -> Int
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (POSIXTime -> Int) -> POSIXTime -> Int
forall a b. (a -> b) -> a -> b
$ UTCTime -> POSIXTime
utcTimeToPOSIXSeconds UTCTime
startTime)

    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
ncValidateDB (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Tracer IO Text -> Text -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO Text
tracer Text
"Performing DB validation"

  traceNodeBasicInfo :: Trace IO Text -> [LogObject Text] -> IO ()
  traceNodeBasicInfo :: Trace IO Text -> [LogObject Text] -> IO ()
traceNodeBasicInfo Trace IO Text
tr [LogObject Text]
basicInfoItems =
    [LogObject Text] -> (LogObject Text -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [LogObject Text]
basicInfoItems ((LogObject Text -> IO ()) -> IO ())
-> (LogObject Text -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(LogObject Text
nm LOMeta
mt LOContent Text
content) ->
      Trace IO Text -> (LOMeta, LOContent Text) -> IO ()
forall (m :: * -> *) a.
MonadIO m =>
Trace m a -> (LOMeta, LOContent a) -> m ()
traceNamedObject (Text -> Trace IO Text -> Trace IO Text
forall (m :: * -> *) a. Text -> Trace m a -> Trace m a
appendName Text
nm Trace IO Text
tr) (LOMeta
mt, LOContent Text
content)

--------------------------------------------------------------------------------
-- Helper functions
--------------------------------------------------------------------------------

canonDbPath :: NodeConfiguration -> IO FilePath
canonDbPath :: NodeConfiguration -> IO String
canonDbPath NodeConfiguration{ncDatabaseFile :: NodeConfiguration -> DbFile
ncDatabaseFile = DbFile String
dbFp} = do
  String
fp <- String -> IO String
canonicalizePath (String -> IO String) -> IO String -> IO String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> IO String
makeAbsolute String
dbFp
  Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
fp
  String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
fp


-- | Make sure the VRF private key file is readable only
-- by the current process owner the node is running under.
checkVRFFilePermissions :: FilePath -> ExceptT VRFPrivateKeyFilePermissionError IO ()
#ifdef UNIX
checkVRFFilePermissions :: String -> ExceptT VRFPrivateKeyFilePermissionError IO ()
checkVRFFilePermissions String
vrfPrivKey = do
  FileStatus
fs <- IO FileStatus
-> ExceptT VRFPrivateKeyFilePermissionError IO FileStatus
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FileStatus
 -> ExceptT VRFPrivateKeyFilePermissionError IO FileStatus)
-> IO FileStatus
-> ExceptT VRFPrivateKeyFilePermissionError IO FileStatus
forall a b. (a -> b) -> a -> b
$ String -> IO FileStatus
getFileStatus String
vrfPrivKey
  let fm :: FileMode
fm = FileStatus -> FileMode
fileMode FileStatus
fs
  -- Check the the VRF private key file does not give read/write/exec permissions to others.
  Bool
-> ExceptT VRFPrivateKeyFilePermissionError IO ()
-> ExceptT VRFPrivateKeyFilePermissionError IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FileMode -> Bool
hasOtherPermissions FileMode
fm)
       (VRFPrivateKeyFilePermissionError
-> ExceptT VRFPrivateKeyFilePermissionError IO ()
forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left (VRFPrivateKeyFilePermissionError
 -> ExceptT VRFPrivateKeyFilePermissionError IO ())
-> VRFPrivateKeyFilePermissionError
-> ExceptT VRFPrivateKeyFilePermissionError IO ()
forall a b. (a -> b) -> a -> b
$ String -> VRFPrivateKeyFilePermissionError
OtherPermissionsExist String
vrfPrivKey)
  -- Check the the VRF private key file does not give read/write/exec permissions to any group.
  Bool
-> ExceptT VRFPrivateKeyFilePermissionError IO ()
-> ExceptT VRFPrivateKeyFilePermissionError IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FileMode -> Bool
hasGroupPermissions FileMode
fm)
       (VRFPrivateKeyFilePermissionError
-> ExceptT VRFPrivateKeyFilePermissionError IO ()
forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left (VRFPrivateKeyFilePermissionError
 -> ExceptT VRFPrivateKeyFilePermissionError IO ())
-> VRFPrivateKeyFilePermissionError
-> ExceptT VRFPrivateKeyFilePermissionError IO ()
forall a b. (a -> b) -> a -> b
$ String -> VRFPrivateKeyFilePermissionError
GroupPermissionsExist String
vrfPrivKey)
 where
  hasPermission :: FileMode -> FileMode -> Bool
  hasPermission :: FileMode -> FileMode -> Bool
hasPermission FileMode
fModeA FileMode
fModeB = FileMode
fModeA FileMode -> FileMode -> FileMode
`intersectFileModes` FileMode
fModeB FileMode -> FileMode -> Bool
forall a. Eq a => a -> a -> Bool
/= FileMode
nullFileMode

  hasOtherPermissions :: FileMode -> Bool
  hasOtherPermissions :: FileMode -> Bool
hasOtherPermissions FileMode
fm' = FileMode
fm' FileMode -> FileMode -> Bool
`hasPermission` FileMode
otherModes

  hasGroupPermissions :: FileMode -> Bool
  hasGroupPermissions :: FileMode -> Bool
hasGroupPermissions FileMode
fm' = FileMode
fm' FileMode -> FileMode -> Bool
`hasPermission` FileMode
groupModes
#else
checkVRFFilePermissions vrfPrivKey = do
  attribs <- liftIO $ getFileAttributes vrfPrivKey
  -- https://docs.microsoft.com/en-us/windows/win32/api/fileapi/nf-fileapi-createfilea
  -- https://docs.microsoft.com/en-us/windows/win32/fileio/file-access-rights-constants
  -- https://docs.microsoft.com/en-us/windows/win32/secauthz/standard-access-rights
  -- https://docs.microsoft.com/en-us/windows/win32/secauthz/generic-access-rights
  -- https://docs.microsoft.com/en-us/windows/win32/secauthz/access-mask
  when (attribs `hasPermission` genericPermissions)
       (left $ GenericPermissionsExist vrfPrivKey)
 where
  genericPermissions = gENERIC_ALL .|. gENERIC_READ .|. gENERIC_WRITE .|. gENERIC_EXECUTE
  hasPermission fModeA fModeB = fModeA .&. fModeB /= gENERIC_NONE
#endif

createDiffusionArguments
  :: Maybe (SocketOrSocketInfo Socket AddrInfo)
   -- ^ Either a socket bound to IPv4 address provided by systemd or IPv4
   -- address to bind to for NodeToNode communication.
  -> Maybe (SocketOrSocketInfo Socket AddrInfo)
   -- ^ Either a socket bound to IPv6 address provided by systemd or IPv6
   -- address to bind to for NodeToNode communication.
  -> Maybe (SocketOrSocketInfo Socket SocketPath)
  -- ^ Either a SOCKET_UNIX socket provided by systemd or a path for
  -- NodeToClient communication.
  -> DiffusionMode
  -> IPSubscriptionTarget
  -> [DnsSubscriptionTarget]
  -> DiffusionArguments
createDiffusionArguments :: Maybe (SocketOrSocketInfo Socket AddrInfo)
-> Maybe (SocketOrSocketInfo Socket AddrInfo)
-> Maybe (SocketOrSocketInfo Socket SocketPath)
-> DiffusionMode
-> IPSubscriptionTarget
-> [DnsSubscriptionTarget]
-> DiffusionArguments
createDiffusionArguments Maybe (SocketOrSocketInfo Socket AddrInfo)
publicIPv4SocketsOrAddrs
                         Maybe (SocketOrSocketInfo Socket AddrInfo)
publicIPv6SocketsOrAddrs
                         Maybe (SocketOrSocketInfo Socket SocketPath)
mLocalSocketOrPath
                         DiffusionMode
diffusionMode
                         IPSubscriptionTarget
ipProducers [DnsSubscriptionTarget]
dnsProducers
                         =
  DiffusionArguments :: Maybe (Either Socket AddrInfo)
-> Maybe (Either Socket AddrInfo)
-> Maybe (Either Socket String)
-> IPSubscriptionTarget
-> [DnsSubscriptionTarget]
-> AcceptedConnectionsLimit
-> DiffusionMode
-> DiffusionArguments
DiffusionArguments
    -- This is not elegant, but it will change once `coot/connection-manager` is
    -- merged into `shardagnostic-networ`.
    { daIPv4Address :: Maybe (Either Socket AddrInfo)
daIPv4Address = SocketOrSocketInfo Socket AddrInfo -> Either Socket AddrInfo
forall a b. SocketOrSocketInfo a b -> Either a b
eitherSocketOrSocketInfo (SocketOrSocketInfo Socket AddrInfo -> Either Socket AddrInfo)
-> Maybe (SocketOrSocketInfo Socket AddrInfo)
-> Maybe (Either Socket AddrInfo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (SocketOrSocketInfo Socket AddrInfo)
publicIPv4SocketsOrAddrs
    , daIPv6Address :: Maybe (Either Socket AddrInfo)
daIPv6Address = SocketOrSocketInfo Socket AddrInfo -> Either Socket AddrInfo
forall a b. SocketOrSocketInfo a b -> Either a b
eitherSocketOrSocketInfo (SocketOrSocketInfo Socket AddrInfo -> Either Socket AddrInfo)
-> Maybe (SocketOrSocketInfo Socket AddrInfo)
-> Maybe (Either Socket AddrInfo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (SocketOrSocketInfo Socket AddrInfo)
publicIPv6SocketsOrAddrs
    , daLocalAddress :: Maybe (Either Socket String)
daLocalAddress = Maybe (SocketOrSocketInfo Socket SocketPath)
mLocalSocketOrPath Maybe (SocketOrSocketInfo Socket SocketPath)
-> (SocketOrSocketInfo Socket SocketPath
    -> Maybe (Either Socket String))
-> Maybe (Either Socket String)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either Socket String -> Maybe (Either Socket String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Socket String -> Maybe (Either Socket String))
-> (SocketOrSocketInfo Socket SocketPath -> Either Socket String)
-> SocketOrSocketInfo Socket SocketPath
-> Maybe (Either Socket String)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (SocketPath -> String)
-> Either Socket SocketPath -> Either Socket String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SocketPath -> String
unSocketPath
                                                     (Either Socket SocketPath -> Either Socket String)
-> (SocketOrSocketInfo Socket SocketPath
    -> Either Socket SocketPath)
-> SocketOrSocketInfo Socket SocketPath
-> Either Socket String
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. SocketOrSocketInfo Socket SocketPath -> Either Socket SocketPath
forall a b. SocketOrSocketInfo a b -> Either a b
eitherSocketOrSocketInfo
    , daIpProducers :: IPSubscriptionTarget
daIpProducers  = IPSubscriptionTarget
ipProducers
    , daDnsProducers :: [DnsSubscriptionTarget]
daDnsProducers = [DnsSubscriptionTarget]
dnsProducers
    -- TODO: these limits are arbitrary at the moment;
    -- issue: https://github.com/The-Blockchain-Company/shardagnostic-network/issues/1836
    , daAcceptedConnectionsLimit :: AcceptedConnectionsLimit
daAcceptedConnectionsLimit = AcceptedConnectionsLimit :: Word32 -> Word32 -> DiffTime -> AcceptedConnectionsLimit
AcceptedConnectionsLimit {
        acceptedConnectionsHardLimit :: Word32
acceptedConnectionsHardLimit = Word32
512
      , acceptedConnectionsSoftLimit :: Word32
acceptedConnectionsSoftLimit = Word32
384
      , acceptedConnectionsDelay :: DiffTime
acceptedConnectionsDelay     = DiffTime
5
      }
    , daDiffusionMode :: DiffusionMode
daDiffusionMode = DiffusionMode
diffusionMode
    }
  where
    eitherSocketOrSocketInfo :: SocketOrSocketInfo a b -> Either a b
    eitherSocketOrSocketInfo :: SocketOrSocketInfo a b -> Either a b
eitherSocketOrSocketInfo (ActualSocket a
a) = a -> Either a b
forall a b. a -> Either a b
Left a
a
    eitherSocketOrSocketInfo (SocketInfo b
b)   = b -> Either a b
forall a b. b -> Either a b
Right b
b

dnsSubscriptionTarget :: NodeDnsAddress -> Int -> DnsSubscriptionTarget
dnsSubscriptionTarget :: NodeDnsAddress -> Int -> DnsSubscriptionTarget
dnsSubscriptionTarget NodeDnsAddress
na Int
valency =
  DnsSubscriptionTarget :: Domain -> PortNumber -> Int -> DnsSubscriptionTarget
DnsSubscriptionTarget { dstDomain :: Domain
dstDomain  = NodeHostDnsAddress -> Domain
nodeHostDnsAddressToDomain (NodeDnsAddress -> NodeHostDnsAddress
forall addr. NodeAddress' addr -> addr
naHostAddress NodeDnsAddress
na)
                        , dstPort :: PortNumber
dstPort    = NodeDnsAddress -> PortNumber
forall addr. NodeAddress' addr -> PortNumber
naPort NodeDnsAddress
na
                        , dstValency :: Int
dstValency = Int
valency
                        }

ipSubscriptionTargets :: [NodeIPAddress] -> IPSubscriptionTarget
ipSubscriptionTargets :: [NodeIPAddress] -> IPSubscriptionTarget
ipSubscriptionTargets [NodeIPAddress]
ipProdAddrs =
  let ips :: [SockAddr]
ips = NodeIPAddress -> SockAddr
nodeAddressToSockAddr (NodeIPAddress -> SockAddr) -> [NodeIPAddress] -> [SockAddr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [NodeIPAddress]
ipProdAddrs
  in IPSubscriptionTarget :: [SockAddr] -> Int -> IPSubscriptionTarget
IPSubscriptionTarget { ispIps :: [SockAddr]
ispIps = [SockAddr]
ips
                          , ispValency :: Int
ispValency = [SockAddr] -> Int
forall a. HasLength a => a -> Int
length [SockAddr]
ips
                          }


producerAddresses
  :: NetworkTopology
  -> ( [NodeIPAddress]
     , [(NodeDnsAddress, Int)])
producerAddresses :: NetworkTopology -> ([NodeIPAddress], [(NodeDnsAddress, Int)])
producerAddresses NetworkTopology
nt =
  case NetworkTopology
nt of
    RealNodeTopology [RemoteAddress]
producers' ->
        [Either NodeIPAddress (NodeDnsAddress, Int)]
-> ([NodeIPAddress], [(NodeDnsAddress, Int)])
forall a b. [Either a b] -> ([a], [b])
partitionEithers
      ([Either NodeIPAddress (NodeDnsAddress, Int)]
 -> ([NodeIPAddress], [(NodeDnsAddress, Int)]))
-> ([RemoteAddress]
    -> [Either NodeIPAddress (NodeDnsAddress, Int)])
-> [RemoteAddress]
-> ([NodeIPAddress], [(NodeDnsAddress, Int)])
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (RemoteAddress
 -> Maybe (Either NodeIPAddress (NodeDnsAddress, Int)))
-> [RemoteAddress] -> [Either NodeIPAddress (NodeDnsAddress, Int)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe RemoteAddress -> Maybe (Either NodeIPAddress (NodeDnsAddress, Int))
remoteAddressToNodeAddress
      ([RemoteAddress] -> ([NodeIPAddress], [(NodeDnsAddress, Int)]))
-> [RemoteAddress] -> ([NodeIPAddress], [(NodeDnsAddress, Int)])
forall a b. (a -> b) -> a -> b
$ [RemoteAddress]
producers'
    MockNodeTopology [NodeSetup]
nodeSetup ->
        [Either NodeIPAddress (NodeDnsAddress, Int)]
-> ([NodeIPAddress], [(NodeDnsAddress, Int)])
forall a b. [Either a b] -> ([a], [b])
partitionEithers
      ([Either NodeIPAddress (NodeDnsAddress, Int)]
 -> ([NodeIPAddress], [(NodeDnsAddress, Int)]))
-> ([NodeSetup] -> [Either NodeIPAddress (NodeDnsAddress, Int)])
-> [NodeSetup]
-> ([NodeIPAddress], [(NodeDnsAddress, Int)])
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (RemoteAddress
 -> Maybe (Either NodeIPAddress (NodeDnsAddress, Int)))
-> [RemoteAddress] -> [Either NodeIPAddress (NodeDnsAddress, Int)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe RemoteAddress -> Maybe (Either NodeIPAddress (NodeDnsAddress, Int))
remoteAddressToNodeAddress
      ([RemoteAddress] -> [Either NodeIPAddress (NodeDnsAddress, Int)])
-> ([NodeSetup] -> [RemoteAddress])
-> [NodeSetup]
-> [Either NodeIPAddress (NodeDnsAddress, Int)]
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (NodeSetup -> [RemoteAddress]) -> [NodeSetup] -> [RemoteAddress]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap NodeSetup -> [RemoteAddress]
producers
      ([NodeSetup] -> ([NodeIPAddress], [(NodeDnsAddress, Int)]))
-> [NodeSetup] -> ([NodeIPAddress], [(NodeDnsAddress, Int)])
forall a b. (a -> b) -> a -> b
$ [NodeSetup]
nodeSetup