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

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

module Cardano.Node.Run
  ( runNode
#ifdef UNIX
  , checkVRFFilePermissions
#endif
  ) where

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

import qualified Control.Concurrent.Async as Async
#ifdef UNIX
import           Control.Monad.Trans.Except.Extra (left)
#endif
import           Control.Tracer
import           Data.Text (breakOn, pack, take)
import qualified Data.Text as Text
import           Data.Version (showVersion)
import           GHC.Clock (getMonotonicTimeNSec)
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)
#endif

import           Cardano.BM.Data.Aggregated (Measurable (..))
import           Paths_cardano_node (version)
import           Cardano.BM.Data.LogItem (LOContent (..), PrivacyAnnotation (..), mkLOMeta)
import           Cardano.BM.Data.Tracer (ToLogObject (..), TracingVerbosity (..))
import           Cardano.BM.Data.Transformers (setHostname)
import           Cardano.BM.Trace

import qualified Cardano.Crypto.Libsodium as Crypto

import           Cardano.Config.Git.Rev (gitRev)
import           Cardano.Node.Configuration.Logging (LoggingLayer (..), Severity (..),
                     createLoggingLayer, shutdownLoggingLayer)
import           Cardano.Node.Configuration.POM (NodeConfiguration (..),
                     PartialNodeConfiguration (..), defaultPartialNodeConfiguration,
                     makeNodeConfiguration, ncProtocol, parseNodeConfigurationFP)
import           Cardano.Node.Types
import           Cardano.Tracing.Config (TraceOptions (..), TraceSelection (..))

import           Ouroboros.Consensus.Block (BlockProtocol)
import qualified Ouroboros.Consensus.Cardano as Consensus
import qualified Ouroboros.Consensus.Config as Consensus
import           Ouroboros.Consensus.Config.SupportsNode (ConfigSupportsNode (..))
import           Ouroboros.Consensus.Fragment.InFuture (defaultClockSkew)
import           Ouroboros.Consensus.Node (DiffusionArguments (..), DiffusionTracers (..),
                     DnsSubscriptionTarget (..), IPSubscriptionTarget (..), NodeArgs (..),
                     RunNode, RunNodeArgs (..))
import qualified Ouroboros.Consensus.Node as Node (getChainDB, run)
import           Ouroboros.Consensus.Node.NetworkProtocolVersion
import           Ouroboros.Consensus.Node.ProtocolInfo
import           Ouroboros.Consensus.Util.Orphans ()
import           Ouroboros.Network.BlockFetch (BlockFetchConfiguration (..))
import           Ouroboros.Network.Magic (NetworkMagic (..))
import           Ouroboros.Network.NodeToNode (AcceptedConnectionsLimit (..), DiffusionMode)

import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB
import           Ouroboros.Consensus.Storage.ImmutableDB (ValidationPolicy (..))
import           Ouroboros.Consensus.Storage.VolatileDB (BlockValidationPolicy (..))

import           Cardano.Node.Configuration.Socket (SocketOrSocketInfo (..),
                     gatherConfiguredSockets, getSocketOrSocketInfoAddr)
import           Cardano.Node.Configuration.Topology
import           Cardano.Node.Handlers.Shutdown
import           Cardano.Node.Protocol (SomeConsensusProtocol (..), mkConsensusProtocol,
                     renderProtocolInstantiationError)
import           Cardano.Tracing.Kernel
import           Cardano.Tracing.Peer
import           Cardano.Tracing.Tracers

{- HLINT ignore "Use fewer imports" -}

runNode
  :: PartialNodeConfiguration
  -> IO ()
runNode :: PartialNodeConfiguration -> IO ()
runNode PartialNodeConfiguration
cmdPc = do
    -- TODO: Remove sodiumInit: https://github.com/input-output-hk/cardano-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'

#ifdef UNIX
    case ProtocolFilepaths -> Maybe String
shelleyVRFFile (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 ()
#endif

    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 -> ExceptT ConfigError IO LoggingLayer
createLoggingLayer
                     (String -> Text
Text.pack (Version -> String
showVersion Version
version))
                     NodeConfiguration
nc

    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

    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 :: Consensus.Protocol IO blk (BlockProtocol blk)) <-
      case Either ProtocolInstantiationError SomeConsensusProtocol
eitherSomeProtocol of
        Left ProtocolInstantiationError
err -> Text -> IO ()
putTextLn (ProtocolInstantiationError -> Text
renderProtocolInstantiationError 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 Protocol IO blk (BlockProtocol blk)
p) -> SomeConsensusProtocol -> IO SomeConsensusProtocol
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SomeConsensusProtocol -> IO SomeConsensusProtocol)
-> SomeConsensusProtocol -> IO SomeConsensusProtocol
forall a b. (a -> b) -> a -> b
$ Protocol IO blk (BlockProtocol blk) -> SomeConsensusProtocol
forall blk.
SomeConsensusProtocolConstraints blk =>
Protocol IO blk (BlockProtocol blk) -> SomeConsensusProtocol
SomeConsensusProtocol Protocol IO blk (BlockProtocol blk)
p

    Async ()
upTimeThread <- IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
Async.async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ Trace IO Text -> Word64 -> IO ()
traceNodeUpTime (Text -> Trace IO Text -> Trace IO Text
forall (m :: * -> *) a. Text -> Trace m a -> Trace m a
appendName Text
"metrics" Trace IO Text
trace) (Word64 -> IO ()) -> IO Word64 -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO Word64
getMonotonicTimeNSec

    -- This IORef contains node kernel structure which holds node kernel.
    -- Used for ledger queries and peer connection status.
    NodeKernelData blk
nodeKernelData :: NodeKernelData blk <- IO (NodeKernelData blk)
forall blk. IO (NodeKernelData blk)
mkNodeKernelData

    Tracers RemoteConnectionId LocalConnectionId blk
tracers <- TraceOptions
-> Trace IO Text
-> NodeKernelData blk
-> IO (Tracers RemoteConnectionId LocalConnectionId blk)
forall peer localPeer blk.
(RunNode blk, HasKESMetricsData blk, TraceConstraints blk,
 Show peer, Eq peer, Show localPeer) =>
TraceOptions
-> Trace IO Text
-> NodeKernelData blk
-> IO (Tracers peer localPeer blk)
mkTracers (NodeConfiguration -> TraceOptions
ncTraceConfig NodeConfiguration
nc) Trace IO Text
trace NodeKernelData blk
nodeKernelData

    Async ()
peersThread <- IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
Async.async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ Trace IO Text -> NodeKernelData blk -> IO ()
forall blk. Trace IO Text -> NodeKernelData blk -> IO ()
handlePeersListSimple Trace IO Text
trace NodeKernelData blk
nodeKernelData
    Protocol IO blk (BlockProtocol blk)
-> Trace IO Text
-> Tracers RemoteConnectionId LocalConnectionId blk
-> NodeConfiguration
-> (NodeKernel IO RemoteConnectionId LocalConnectionId blk
    -> IO ())
-> IO ()
forall blk.
RunNode blk =>
Protocol IO blk (BlockProtocol blk)
-> Trace IO Text
-> Tracers RemoteConnectionId LocalConnectionId blk
-> NodeConfiguration
-> (NodeKernel IO RemoteConnectionId LocalConnectionId blk
    -> IO ())
-> IO ()
handleSimpleNode Protocol IO blk (BlockProtocol blk)
p 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)
    Async () -> IO ()
forall a. Async a -> IO ()
Async.uninterruptibleCancel Async ()
upTimeThread
    Async () -> IO ()
forall a. Async a -> IO ()
Async.uninterruptibleCancel Async ()
peersThread

    LoggingLayer -> IO ()
shutdownLoggingLayer LoggingLayer
loggingLayer

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 @CARDANO_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
"CARDANO_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

-- | The node sends its real up time, every second.
traceNodeUpTime
  :: Trace IO Text
  -> Word64
  -> IO ()
traceNodeUpTime :: Trace IO Text -> Word64 -> IO ()
traceNodeUpTime Trace IO Text
tr Word64
nodeLaunchTime = do
  Word64
now <- IO Word64
getMonotonicTimeNSec
  let upTimeInNs :: Word64
upTimeInNs = Word64
now Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
nodeLaunchTime
  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 Trace IO Text
tr (LOMeta
meta, Text -> Measurable -> LOContent Text
forall a. Text -> Measurable -> LOContent a
LogValue Text
"upTime" (Word64 -> Measurable
Nanoseconds Word64
upTimeInNs))
  Int -> IO ()
threadDelay Int
1000000
  Trace IO Text -> Word64 -> IO ()
traceNodeUpTime Trace IO Text
tr Word64
nodeLaunchTime

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
  => Consensus.Protocol IO blk (BlockProtocol 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 :: Protocol IO blk (BlockProtocol blk)
-> Trace IO Text
-> Tracers RemoteConnectionId LocalConnectionId blk
-> NodeConfiguration
-> (NodeKernel IO RemoteConnectionId LocalConnectionId blk
    -> IO ())
-> IO ()
handleSimpleNode Protocol IO blk (BlockProtocol blk)
p Trace IO Text
trace Tracers RemoteConnectionId LocalConnectionId blk
nodeTracers NodeConfiguration
nc NodeKernel IO RemoteConnectionId LocalConnectionId blk -> IO ()
onKernel = do

  let pInfo :: ProtocolInfo IO blk
pInfo@ProtocolInfo{ pInfoConfig :: forall (m :: * -> *) b. ProtocolInfo m b -> TopLevelConfig b
pInfoConfig = TopLevelConfig blk
cfg } = Protocol IO blk (BlockProtocol blk) -> ProtocolInfo IO blk
forall (m :: * -> *) blk p.
IOLike m =>
Protocol m blk p -> ProtocolInfo m blk
Consensus.protocolInfo Protocol IO blk (BlockProtocol blk)
p
      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 -> TopLevelConfig blk -> IO ()
createTracers NodeConfiguration
nc Trace IO Text
trace Tracer IO Text
tracer TopLevelConfig blk
cfg

  (Maybe (SocketOrSocketInfo Socket AddrInfo)
publicIPv4SocketOrAddr
    , Maybe (SocketOrSocketInfo Socket AddrInfo)
publicIPv6SocketOrAddr
    , SocketOrSocketInfo Socket SocketPath
localSocketOrPath) <- (SocketConfigError
 -> IO
      (Maybe (SocketOrSocketInfo Socket AddrInfo),
       Maybe (SocketOrSocketInfo Socket AddrInfo),
       SocketOrSocketInfo Socket SocketPath))
-> ((Maybe (SocketOrSocketInfo Socket AddrInfo),
     Maybe (SocketOrSocketInfo Socket AddrInfo),
     SocketOrSocketInfo Socket SocketPath)
    -> IO
         (Maybe (SocketOrSocketInfo Socket AddrInfo),
          Maybe (SocketOrSocketInfo Socket AddrInfo),
          SocketOrSocketInfo Socket SocketPath))
-> Either
     SocketConfigError
     (Maybe (SocketOrSocketInfo Socket AddrInfo),
      Maybe (SocketOrSocketInfo Socket AddrInfo),
      SocketOrSocketInfo Socket SocketPath)
-> IO
     (Maybe (SocketOrSocketInfo Socket AddrInfo),
      Maybe (SocketOrSocketInfo Socket AddrInfo),
      SocketOrSocketInfo Socket SocketPath)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either SocketConfigError
-> IO
     (Maybe (SocketOrSocketInfo Socket AddrInfo),
      Maybe (SocketOrSocketInfo Socket AddrInfo),
      SocketOrSocketInfo Socket SocketPath)
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (Maybe (SocketOrSocketInfo Socket AddrInfo),
 Maybe (SocketOrSocketInfo Socket AddrInfo),
 SocketOrSocketInfo Socket SocketPath)
-> IO
     (Maybe (SocketOrSocketInfo Socket AddrInfo),
      Maybe (SocketOrSocketInfo Socket AddrInfo),
      SocketOrSocketInfo Socket SocketPath)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either
   SocketConfigError
   (Maybe (SocketOrSocketInfo Socket AddrInfo),
    Maybe (SocketOrSocketInfo Socket AddrInfo),
    SocketOrSocketInfo Socket SocketPath)
 -> IO
      (Maybe (SocketOrSocketInfo Socket AddrInfo),
       Maybe (SocketOrSocketInfo Socket AddrInfo),
       SocketOrSocketInfo Socket SocketPath))
-> IO
     (Either
        SocketConfigError
        (Maybe (SocketOrSocketInfo Socket AddrInfo),
         Maybe (SocketOrSocketInfo Socket AddrInfo),
         SocketOrSocketInfo Socket SocketPath))
-> IO
     (Maybe (SocketOrSocketInfo Socket AddrInfo),
      Maybe (SocketOrSocketInfo Socket AddrInfo),
      SocketOrSocketInfo Socket SocketPath)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
                           ExceptT
  SocketConfigError
  IO
  (Maybe (SocketOrSocketInfo Socket AddrInfo),
   Maybe (SocketOrSocketInfo Socket AddrInfo),
   SocketOrSocketInfo Socket SocketPath)
-> IO
     (Either
        SocketConfigError
        (Maybe (SocketOrSocketInfo Socket AddrInfo),
         Maybe (SocketOrSocketInfo Socket AddrInfo),
         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),
      SocketOrSocketInfo Socket SocketPath)
gatherConfiguredSockets NodeConfiguration
nc)

  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
"Cardano.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)
-> SocketOrSocketInfo Socket SocketPath
-> DiffusionMode
-> IPSubscriptionTarget
-> [DnsSubscriptionTarget]
-> DiffusionArguments
createDiffusionArguments
          Maybe (SocketOrSocketInfo Socket AddrInfo)
publicIPv4SocketOrAddr
          Maybe (SocketOrSocketInfo Socket AddrInfo)
publicIPv6SocketOrAddr
          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

  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
"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 blk -> IO ()
forall blk. RunNode blk => RunNodeArgs blk -> IO ()
Node.run
     RunNodeArgs :: forall blk.
Tracers IO RemoteConnectionId LocalConnectionId blk
-> Tracers IO RemoteConnectionId blk DeserialiseFailure
-> Tracers IO LocalConnectionId blk DeserialiseFailure
-> Tracer IO (TraceEvent blk)
-> DiffusionTracers
-> DiffusionArguments
-> NetworkMagic
-> String
-> ProtocolInfo IO blk
-> (ChainDbArgs Identity IO blk -> ChainDbArgs Identity IO blk)
-> (NodeArgs IO RemoteConnectionId LocalConnectionId blk
    -> NodeArgs IO RemoteConnectionId LocalConnectionId blk)
-> Map NodeToNodeVersion (BlockNodeToNodeVersion blk)
-> Map NodeToClientVersion (BlockNodeToClientVersion blk)
-> (ResourceRegistry IO
    -> NodeKernel IO RemoteConnectionId LocalConnectionId blk -> IO ())
-> ClockSkew
-> RunNodeArgs 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,
       rnTraceDB :: Tracer IO (TraceEvent blk)
rnTraceDB              = 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,
       rnTraceDiffusion :: DiffusionTracers
rnTraceDiffusion       = DiffusionTracers
diffusionTracers,
       rnDiffusionArguments :: DiffusionArguments
rnDiffusionArguments   = DiffusionArguments
diffusionArguments,
       rnNetworkMagic :: NetworkMagic
rnNetworkMagic         = BlockConfig blk -> NetworkMagic
forall blk.
ConfigSupportsNode blk =>
BlockConfig blk -> NetworkMagic
getNetworkMagic (TopLevelConfig blk -> BlockConfig blk
forall blk. TopLevelConfig blk -> BlockConfig blk
Consensus.configBlock TopLevelConfig blk
cfg),
       rnDatabasePath :: String
rnDatabasePath         = String
dbPath,
       rnProtocolInfo :: ProtocolInfo IO blk
rnProtocolInfo         = ProtocolInfo IO blk
pInfo,
       rnCustomiseChainDbArgs :: ChainDbArgs Identity IO blk -> ChainDbArgs Identity IO blk
rnCustomiseChainDbArgs = Bool -> ChainDbArgs Identity IO blk -> ChainDbArgs Identity IO blk
customiseChainDbArgs (Bool
 -> ChainDbArgs Identity IO blk -> ChainDbArgs Identity IO blk)
-> Bool
-> ChainDbArgs Identity IO blk
-> ChainDbArgs Identity IO blk
forall a b. (a -> b) -> a -> b
$ NodeConfiguration -> Bool
ncValidateDB NodeConfiguration
nc,
       rnCustomiseNodeArgs :: NodeArgs IO RemoteConnectionId LocalConnectionId blk
-> NodeArgs IO RemoteConnectionId LocalConnectionId blk
rnCustomiseNodeArgs    = Maybe MaxConcurrencyBulkSync
-> Maybe MaxConcurrencyDeadline
-> NodeArgs IO RemoteConnectionId LocalConnectionId blk
-> NodeArgs IO RemoteConnectionId LocalConnectionId blk
customiseNodeArgs (NodeConfiguration -> Maybe MaxConcurrencyBulkSync
ncMaxConcurrencyBulkSync NodeConfiguration
nc)
                                  (NodeConfiguration -> Maybe MaxConcurrencyDeadline
ncMaxConcurrencyDeadline NodeConfiguration
nc),
       rnNodeToNodeVersions :: Map NodeToNodeVersion (BlockNodeToNodeVersion blk)
rnNodeToNodeVersions   = Proxy blk -> Map NodeToNodeVersion (BlockNodeToNodeVersion blk)
forall blk.
SupportedNetworkProtocolVersion blk =>
Proxy blk -> Map NodeToNodeVersion (BlockNodeToNodeVersion blk)
supportedNodeToNodeVersions (Proxy blk
forall k (t :: k). Proxy t
Proxy @blk),
       rnNodeToClientVersions :: Map NodeToClientVersion (BlockNodeToClientVersion blk)
rnNodeToClientVersions = Proxy blk -> Map NodeToClientVersion (BlockNodeToClientVersion blk)
forall blk.
SupportedNetworkProtocolVersion blk =>
Proxy blk -> Map NodeToClientVersion (BlockNodeToClientVersion blk)
supportedNodeToClientVersions (Proxy blk
forall k (t :: k). Proxy t
Proxy @blk),
       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,
       rnMaxClockSkew :: ClockSkew
rnMaxClockSkew         = ClockSkew
defaultClockSkew
    }
 where
  customiseNodeArgs :: Maybe MaxConcurrencyBulkSync
                    -> Maybe MaxConcurrencyDeadline
                    -> NodeArgs IO RemoteConnectionId LocalConnectionId blk
                    -> NodeArgs IO RemoteConnectionId LocalConnectionId blk
  customiseNodeArgs :: Maybe MaxConcurrencyBulkSync
-> Maybe MaxConcurrencyDeadline
-> NodeArgs IO RemoteConnectionId LocalConnectionId blk
-> NodeArgs IO RemoteConnectionId LocalConnectionId blk
customiseNodeArgs Maybe MaxConcurrencyBulkSync
bulk_m Maybe MaxConcurrencyDeadline
deadline_m args :: NodeArgs IO RemoteConnectionId LocalConnectionId blk
args@NodeArgs{ BlockFetchConfiguration
$sel:blockFetchConfiguration:NodeArgs :: forall (m :: * -> *) remotePeer localPeer blk.
NodeArgs m remotePeer localPeer blk -> BlockFetchConfiguration
blockFetchConfiguration :: BlockFetchConfiguration
blockFetchConfiguration } = NodeArgs IO RemoteConnectionId LocalConnectionId blk
args {
      $sel:blockFetchConfiguration:NodeArgs :: BlockFetchConfiguration
blockFetchConfiguration = BlockFetchConfiguration
blockFetchConfiguration {
          bfcMaxConcurrencyBulkSync :: Word
bfcMaxConcurrencyBulkSync = Word
-> (MaxConcurrencyBulkSync -> Word)
-> Maybe MaxConcurrencyBulkSync
-> Word
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (BlockFetchConfiguration -> Word
bfcMaxConcurrencyBulkSync BlockFetchConfiguration
blockFetchConfiguration)
            MaxConcurrencyBulkSync -> Word
unMaxConcurrencyBulkSync Maybe MaxConcurrencyBulkSync
bulk_m
        , bfcMaxConcurrencyDeadline :: Word
bfcMaxConcurrencyDeadline = Word
-> (MaxConcurrencyDeadline -> Word)
-> Maybe MaxConcurrencyDeadline
-> Word
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (BlockFetchConfiguration -> Word
bfcMaxConcurrencyDeadline BlockFetchConfiguration
blockFetchConfiguration)
            MaxConcurrencyDeadline -> Word
unMaxConcurrencyDeadline Maybe MaxConcurrencyDeadline
deadline_m
        }
      }

  customiseChainDbArgs :: Bool
                       -> ChainDB.ChainDbArgs Identity IO blk
                       -> ChainDB.ChainDbArgs Identity IO blk
  customiseChainDbArgs :: Bool -> ChainDbArgs Identity IO blk -> ChainDbArgs Identity IO blk
customiseChainDbArgs Bool
runValid ChainDbArgs Identity IO blk
args
    | Bool
runValid
    = ChainDbArgs Identity IO blk
args
      { cdbImmutableDbValidation :: ValidationPolicy
ChainDB.cdbImmutableDbValidation = ValidationPolicy
ValidateAllChunks
      , cdbVolatileDbValidation :: BlockValidationPolicy
ChainDB.cdbVolatileDbValidation = BlockValidationPolicy
ValidateAll
      }
    | Bool
otherwise
    = ChainDbArgs Identity IO blk
args

  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
-> 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 = Tracer IO (WithMuxBearer LocalConnectionId MuxTrace)
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
    , 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'
    }

  createTracers
    :: NodeConfiguration
    -> Trace IO Text
    -> Tracer IO Text
    -> Consensus.TopLevelConfig blk
    -> IO ()
  createTracers :: NodeConfiguration
-> Trace IO Text -> Tracer IO Text -> TopLevelConfig blk -> IO ()
createTracers NodeConfiguration { Bool
ncValidateDB :: Bool
ncValidateDB :: NodeConfiguration -> Bool
ncValidateDB }
                Trace IO Text
tr Tracer IO Text
tracer TopLevelConfig blk
cfg = do

         Tracer IO Text -> Text -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO Text
tracer (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$
           Text
"System started at " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SystemStart -> Text
forall a b. (Show a, ConvertText String b) => a -> b
show (BlockConfig blk -> SystemStart
forall blk.
ConfigSupportsNode blk =>
BlockConfig blk -> SystemStart
getSystemStart (BlockConfig blk -> SystemStart) -> BlockConfig blk -> SystemStart
forall a b. (a -> b) -> a -> b
$ TopLevelConfig blk -> BlockConfig blk
forall blk. TopLevelConfig blk -> BlockConfig blk
Consensus.configBlock TopLevelConfig blk
cfg)

         LOMeta
meta <- Severity -> PrivacyAnnotation -> IO LOMeta
forall (m :: * -> *).
MonadIO m =>
Severity -> PrivacyAnnotation -> m LOMeta
mkLOMeta Severity
Notice PrivacyAnnotation
Public
         let rTr :: Trace IO Text
rTr = Text -> Trace IO Text -> Trace IO Text
forall (m :: * -> *) a. Text -> Trace m a -> Trace m a
appendName Text
"release" Trace IO Text
tr
             nTr :: Trace IO Text
nTr = Text -> Trace IO Text -> Trace IO Text
forall (m :: * -> *) a. Text -> Trace m a -> Trace m a
appendName Text
"networkMagic" Trace IO Text
tr
             vTr :: Trace IO Text
vTr = Text -> Trace IO Text -> Trace IO Text
forall (m :: * -> *) a. Text -> Trace m a -> Trace m a
appendName Text
"version" Trace IO Text
tr
             cTr :: Trace IO Text
cTr = Text -> Trace IO Text -> Trace IO Text
forall (m :: * -> *) a. Text -> Trace m a -> Trace m a
appendName Text
"commit"  Trace IO Text
tr
         Trace IO Text -> (LOMeta, LOContent Text) -> IO ()
forall (m :: * -> *) a.
MonadIO m =>
Trace m a -> (LOMeta, LOContent a) -> m ()
traceNamedObject Trace IO Text
rTr (LOMeta
meta, Text -> LOContent Text
forall a. a -> LOContent a
LogMessage (Text -> LOContent Text)
-> (Protocol -> Text) -> Protocol -> 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) -> (Protocol -> String) -> Protocol -> Text
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Protocol -> String
protocolName (Protocol -> LOContent Text) -> Protocol -> LOContent Text
forall a b. (a -> b) -> a -> b
$ NodeConfiguration -> Protocol
ncProtocol NodeConfiguration
nc)
         Trace IO Text -> (LOMeta, LOContent Text) -> IO ()
forall (m :: * -> *) a.
MonadIO m =>
Trace m a -> (LOMeta, LOContent a) -> m ()
traceNamedObject Trace IO Text
nTr (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)))
         Trace IO Text -> (LOMeta, LOContent Text) -> IO ()
forall (m :: * -> *) a.
MonadIO m =>
Trace m a -> (LOMeta, LOContent a) -> m ()
traceNamedObject Trace IO Text
vTr (LOMeta
meta, Text -> LOContent Text
forall a. a -> LOContent a
LogMessage (Text -> LOContent Text)
-> (Version -> Text) -> Version -> 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
pack (String -> Text) -> (Version -> String) -> Version -> Text
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Version -> String
showVersion (Version -> LOContent Text) -> Version -> LOContent Text
forall a b. (a -> b) -> a -> b
$ Version
version)
         Trace IO Text -> (LOMeta, LOContent Text) -> IO ()
forall (m :: * -> *) a.
MonadIO m =>
Trace m a -> (LOMeta, LOContent a) -> m ()
traceNamedObject Trace IO Text
cTr (LOMeta
meta, Text -> LOContent Text
forall a. a -> LOContent a
LogMessage Text
gitRev)

         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"

--------------------------------------------------------------------------------
-- 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

#ifdef UNIX
-- | 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 ()
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
#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.
  -> 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)
-> SocketOrSocketInfo Socket SocketPath
-> DiffusionMode
-> IPSubscriptionTarget
-> [DnsSubscriptionTarget]
-> DiffusionArguments
createDiffusionArguments Maybe (SocketOrSocketInfo Socket AddrInfo)
publicIPv4SocketsOrAddrs
                         Maybe (SocketOrSocketInfo Socket AddrInfo)
publicIPv6SocketsOrAddrs
                         SocketOrSocketInfo Socket SocketPath
localSocketOrPath
                         DiffusionMode
diffusionMode
                         IPSubscriptionTarget
ipProducers [DnsSubscriptionTarget]
dnsProducers
                         =
  DiffusionArguments :: Maybe (Either Socket AddrInfo)
-> Maybe (Either Socket AddrInfo)
-> Either Socket String
-> IPSubscriptionTarget
-> [DnsSubscriptionTarget]
-> AcceptedConnectionsLimit
-> DiffusionMode
-> DiffusionArguments
DiffusionArguments
    -- This is not elegant, but it will change once `coot/connection-manager` is
    -- merged into `ouroboros-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 :: Either Socket String
daLocalAddress = (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
                     (SocketOrSocketInfo Socket SocketPath -> Either Socket String)
-> SocketOrSocketInfo Socket SocketPath -> Either Socket String
forall a b. (a -> b) -> a -> b
$ SocketOrSocketInfo Socket SocketPath
localSocketOrPath
    , daIpProducers :: IPSubscriptionTarget
daIpProducers  = IPSubscriptionTarget
ipProducers
    , daDnsProducers :: [DnsSubscriptionTarget]
daDnsProducers = [DnsSubscriptionTarget]
dnsProducers
    -- TODO: these limits are arbitrary at the moment;
    -- issue: https://github.com/input-output-hk/ouroboros-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