{-# 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
runNode
:: PartialNodeConfiguration
-> IO ()
runNode :: PartialNodeConfiguration -> IO ()
runNode PartialNodeConfiguration
cmdPc = do
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
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 "
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
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
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 ())
-> 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"
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
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
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)
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)
-> Maybe (SocketOrSocketInfo Socket AddrInfo)
-> SocketOrSocketInfo Socket SocketPath
-> 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
{ 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
, 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