{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MonadComprehensions #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}

-- | Run the whole Node
--
-- Intended for qualified import.
module Ouroboros.Consensus.Node
  ( run
  , runWith

    -- * Standard arguments
  , StdRunNodeArgs (..)
  , stdBfcSaltIO
  , stdLowLevelRunNodeArgsIO
  , stdMkChainDbHasFS
  , stdRunDataDiffusion
  , stdVersionDataNTC
  , stdVersionDataNTN
  , stdWithCheckedDB

    -- * Exposed by 'run' et al
  , ChainDB.RelativeMountPoint (..)
  , ChainDB.TraceEvent (..)
  , ChainDbArgs (..)
  , HardForkBlockchainTimeArgs (..)
  , LastShutDownWasClean (..)
  , LowLevelRunNodeArgs (..)
  , MempoolCapacityBytesOverride (..)
  , NodeDatabasePaths (..)
  , NodeKernel (..)
  , NodeKernelArgs (..)
  , ProtocolInfo (..)
  , RunNode
  , RunNodeArgs (..)
  , SnapshotPolicyArgs (..)
  , Tracers
  , Tracers' (..)
  , pattern DoDiskSnapshotChecksum
  , pattern NoDoDiskSnapshotChecksum
  , ChainSyncIdleTimeout (..)

    -- * Internal helpers
  , mkNodeKernelArgs
  , nodeKernelArgsEnforceInvariants
  , openChainDB
  ) where

import qualified Cardano.Network.Diffusion as Cardano.Diffusion
import Cardano.Network.Diffusion.Configuration (ChainSyncIdleTimeout (..))
import qualified Cardano.Network.Diffusion.Policies as Cardano.Diffusion
import qualified Cardano.Network.LedgerPeerConsensusInterface as Cardano
import Cardano.Network.PeerSelection.Bootstrap (UseBootstrapPeers (..))
import Cardano.Network.PeerSelection.Churn (ChurnMode (..))
import qualified Codec.CBOR.Decoding as CBOR
import qualified Codec.CBOR.Encoding as CBOR
import Codec.Serialise (DeserialiseFailure)
import qualified Control.Concurrent.Class.MonadSTM.Strict as StrictSTM
import Control.DeepSeq (NFData)
import Control.Monad (forM_, when)
import Control.Monad.Class.MonadTime.SI (MonadTime)
import Control.Monad.Class.MonadTimer.SI (MonadTimer)
import Control.ResourceRegistry
import Control.Tracer (Tracer, contramap, traceWith)
import Data.ByteString.Lazy (ByteString)
import Data.Functor (void)
import Data.Functor.Contravariant (Predicate (..))
import Data.Hashable (Hashable)
import Data.Kind (Type)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe (fromMaybe, isNothing)
import Data.Time (NominalDiffTime)
import Data.Typeable (Typeable)
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.BlockchainTime hiding (getSystemStart)
import Ouroboros.Consensus.Config
import Ouroboros.Consensus.Config.SupportsNode
import Ouroboros.Consensus.Ledger.Basics (ValuesMK)
import Ouroboros.Consensus.Ledger.Extended (ExtLedgerState (..))
import Ouroboros.Consensus.MiniProtocol.ChainSync.Client.HistoricityCheck
  ( HistoricityCheck
  )
import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client.HistoricityCheck as HistoricityCheck
import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client.InFutureCheck as InFutureCheck
import qualified Ouroboros.Consensus.Network.NodeToClient as NTC
import qualified Ouroboros.Consensus.Network.NodeToNode as NTN
import Ouroboros.Consensus.Node.DbLock
import Ouroboros.Consensus.Node.DbMarker
import Ouroboros.Consensus.Node.ExitPolicy
import Ouroboros.Consensus.Node.GSM (GsmNodeKernelArgs (..))
import qualified Ouroboros.Consensus.Node.GSM as GSM
import Ouroboros.Consensus.Node.Genesis
  ( GenesisConfig (..)
  , GenesisNodeKernelArgs (..)
  , mkGenesisNodeKernelArgs
  )
import Ouroboros.Consensus.Node.InitStorage
import Ouroboros.Consensus.Node.NetworkProtocolVersion
import Ouroboros.Consensus.Node.ProtocolInfo
import Ouroboros.Consensus.Node.Recovery
import Ouroboros.Consensus.Node.RethrowPolicy
import Ouroboros.Consensus.Node.Run
import Ouroboros.Consensus.Node.Tracers
import Ouroboros.Consensus.NodeKernel
import Ouroboros.Consensus.Storage.ChainDB
  ( ChainDB
  , ChainDbArgs
  , TraceEvent
  )
import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB
import qualified Ouroboros.Consensus.Storage.ChainDB.Impl.Args as ChainDB
import Ouroboros.Consensus.Storage.LedgerDB.Args
import Ouroboros.Consensus.Storage.LedgerDB.Snapshots
import Ouroboros.Consensus.Util.Args
import Ouroboros.Consensus.Util.IOLike
import Ouroboros.Consensus.Util.Orphans ()
import Ouroboros.Consensus.Util.Time (secondsToNominalDiffTime)
import Ouroboros.Network.BlockFetch
  ( BlockFetchConfiguration (..)
  )
import qualified Ouroboros.Network.Diffusion as Diffusion
import qualified Ouroboros.Network.Diffusion.Configuration as Diffusion
import qualified Ouroboros.Network.Diffusion.Policies as Diffusion
import Ouroboros.Network.Magic
import Ouroboros.Network.NodeToClient
  ( ConnectionId
  , LocalAddress
  , NodeToClientVersionData (..)
  , combineVersions
  , simpleSingletonVersions
  )
import Ouroboros.Network.NodeToNode
  ( DiffusionMode (..)
  , ExceptionInHandler (..)
  , MiniProtocolParameters
  , NodeToNodeVersionData (..)
  , RemoteAddress
  , blockFetchPipeliningMax
  , defaultMiniProtocolParameters
  )
import Ouroboros.Network.PeerSelection.Governor.Types
  ( PublicPeerSelectionState
  )
import Ouroboros.Network.PeerSelection.LedgerPeers
  ( LedgerPeersConsensusInterface (..)
  )
import Ouroboros.Network.PeerSelection.PeerMetric
  ( PeerMetrics
  , newPeerMetric
  , reportMetric
  )
import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing)
import Ouroboros.Network.PeerSelection.PeerSharing.Codec
  ( decodeRemoteAddress
  , encodeRemoteAddress
  )
import Ouroboros.Network.Protocol.ChainSync.Codec (timeLimitsChainSync)
import Ouroboros.Network.RethrowPolicy
import qualified SafeWildCards
import System.Exit (ExitCode (..))
import System.FS.API (SomeHasFS (..))
import System.FS.API.Types (MountPoint (..))
import System.FS.IO (ioHasFS)
import System.FilePath ((</>))
import System.Random (StdGen, newStdGen, randomIO, split)

{-------------------------------------------------------------------------------
  The arguments to the Consensus Layer node functionality
-------------------------------------------------------------------------------}

-- How to add a new argument
--
-- 1) As a Consensus Layer maintainer, use your judgement to determine whether
-- the new argument belongs in 'RunNodeArgs' or 'LowLevelArgs'. Give it the type
-- that seems most " natural ", future-proof, and useful for the whole range of
-- invocations: our tests, our own benchmarks, deployment on @mainnet@, etc. The
-- major litmus test is: it only belongs in 'RunNodeArgs' if /every/ invocation
-- of our node code must specify it.
--
-- 2) If you add it to 'LowLevelArgs', you'll have type errors in
-- 'stdLowLevelRunNodeArgsIO'. To fix them, you'll need to either hard-code a
-- default value or else extend 'StdRunNodeArgs' with a new sufficient field.
--
-- 3) When extending either 'RunNodeArgs' or 'StdRunNodeArgs', the
-- @cardano-node@ will have to be updated, so consider the Node Team's
-- preferences when choosing the new field's type. As an oversimplification,
-- Consensus /owns/ 'RunNodeArgs' while Node /owns/ 'StdRunNodeArgs', but it's
-- always worth spending some effort to try to find a type that satisfies both
-- teams.

-- | Arguments expected from any invocation of 'runWith', whether by deployed
-- code, tests, etc.
type RunNodeArgs ::
  (Type -> Type) ->
  Type ->
  Type ->
  Type ->
  Type
data RunNodeArgs m addrNTN addrNTC blk = RunNodeArgs
  { forall (m :: * -> *) addrNTN addrNTC blk.
RunNodeArgs m addrNTN addrNTC blk
-> Tracers m (ConnectionId addrNTN) (ConnectionId addrNTC) blk
rnTraceConsensus :: Tracers m (ConnectionId addrNTN) (ConnectionId addrNTC) blk
  -- ^ Consensus tracers
  , forall (m :: * -> *) addrNTN addrNTC blk.
RunNodeArgs m addrNTN addrNTC blk
-> Tracers m addrNTN blk DeserialiseFailure
rnTraceNTN :: NTN.Tracers m addrNTN blk DeserialiseFailure
  -- ^ Protocol tracers for node-to-node communication
  , forall (m :: * -> *) addrNTN addrNTC blk.
RunNodeArgs m addrNTN addrNTC blk
-> Tracers m (ConnectionId addrNTC) blk DeserialiseFailure
rnTraceNTC :: NTC.Tracers m (ConnectionId addrNTC) blk DeserialiseFailure
  -- ^ Protocol tracers for node-to-client communication
  , forall (m :: * -> *) addrNTN addrNTC blk.
RunNodeArgs m addrNTN addrNTC blk -> ProtocolInfo blk
rnProtocolInfo :: ProtocolInfo blk
  -- ^ Protocol info
  , forall (m :: * -> *) addrNTN addrNTC blk.
RunNodeArgs m addrNTN addrNTC blk
-> ResourceRegistry m
-> NodeKernel m addrNTN (ConnectionId addrNTC) blk
-> m ()
rnNodeKernelHook ::
      ResourceRegistry m ->
      NodeKernel m addrNTN (ConnectionId addrNTC) blk ->
      m ()
  -- ^ Hook called after the initialisation of the 'NodeKernel'
  --
  -- Called on the 'NodeKernel' after creating it, but before the network
  -- layer is initialised.
  , forall (m :: * -> *) addrNTN addrNTC blk.
RunNodeArgs m addrNTN addrNTC blk -> PeerSharing
rnPeerSharing :: PeerSharing
  -- ^ Network PeerSharing miniprotocol willingness flag
  , forall (m :: * -> *) addrNTN addrNTC blk.
RunNodeArgs m addrNTN addrNTC blk -> STM m UseBootstrapPeers
rnGetUseBootstrapPeers :: STM m UseBootstrapPeers
  , forall (m :: * -> *) addrNTN addrNTC blk.
RunNodeArgs m addrNTN addrNTC blk -> GenesisConfig
rnGenesisConfig :: GenesisConfig
  }

-- | Arguments that usually only tests /directly/ specify.
--
-- A non-testing invocation probably wouldn't explicitly provide these values to
-- 'runWith'. The @cardano-node@, for example, instead calls the 'run'
-- abbreviation, which uses 'stdLowLevelRunNodeArgsIO' to indirectly specify
-- these low-level values from the higher-level 'StdRunNodeArgs'.
type LowLevelRunNodeArgs ::
  (Type -> Type) ->
  Type ->
  Type ->
  Type ->
  Type
data LowLevelRunNodeArgs m addrNTN addrNTC blk
  = LowLevelRunNodeArgs
  { forall (m :: * -> *) addrNTN addrNTC blk.
LowLevelRunNodeArgs m addrNTN addrNTC blk
-> forall a.
   (LastShutDownWasClean -> (ChainDB m blk -> m a -> m a) -> m a)
   -> m a
llrnWithCheckedDB ::
      forall a.
      ( LastShutDownWasClean ->
        (ChainDB m blk -> m a -> m a) ->
        m a
      ) ->
      m a
  -- ^ An action that will receive a marker indicating whether the previous
  -- shutdown was considered clean and a wrapper for installing a handler to
  -- create a clean file on exit if needed. See
  -- 'Ouroboros.Consensus.Node.Recovery.runWithCheckedDB'.
  , forall (m :: * -> *) addrNTN addrNTC blk.
LowLevelRunNodeArgs m addrNTN addrNTC blk
-> Incomplete ChainDbArgs m blk
llrnChainDbArgsDefaults :: Incomplete ChainDbArgs m blk
  -- ^ The " static " ChainDB arguments
  , forall (m :: * -> *) addrNTN addrNTC blk.
LowLevelRunNodeArgs m addrNTN addrNTC blk
-> RelativeMountPoint -> SomeHasFS m
llrnMkImmutableHasFS :: ChainDB.RelativeMountPoint -> SomeHasFS m
  -- ^ File-system on which the directory for the ImmutableDB will
  -- be created.
  , forall (m :: * -> *) addrNTN addrNTC blk.
LowLevelRunNodeArgs m addrNTN addrNTC blk
-> RelativeMountPoint -> SomeHasFS m
llrnMkVolatileHasFS :: ChainDB.RelativeMountPoint -> SomeHasFS m
  -- ^ File-system on which the directories for databases other than the ImmutableDB will
  -- be created.
  , forall (m :: * -> *) addrNTN addrNTC blk.
LowLevelRunNodeArgs m addrNTN addrNTC blk
-> Complete ChainDbArgs m blk -> Complete ChainDbArgs m blk
llrnCustomiseChainDbArgs ::
      Complete ChainDbArgs m blk ->
      Complete ChainDbArgs m blk
  -- ^ Customise the 'ChainDbArgs'. 'StdRunNodeArgs' will use this field to
  -- set various options that are exposed in @cardano-node@ configuration
  -- files.
  , forall (m :: * -> *) addrNTN addrNTC blk.
LowLevelRunNodeArgs m addrNTN addrNTC blk
-> NodeKernelArgs m addrNTN (ConnectionId addrNTC) blk
-> NodeKernelArgs m addrNTN (ConnectionId addrNTC) blk
llrnCustomiseNodeKernelArgs ::
      NodeKernelArgs m addrNTN (ConnectionId addrNTC) blk ->
      NodeKernelArgs m addrNTN (ConnectionId addrNTC) blk
  -- ^ Customise the 'NodeArgs'
  , forall (m :: * -> *) addrNTN addrNTC blk.
LowLevelRunNodeArgs m addrNTN addrNTC blk -> Int
llrnBfcSalt :: Int
  -- ^ Ie 'bfcSalt'
  , forall (m :: * -> *) addrNTN addrNTC blk.
LowLevelRunNodeArgs m addrNTN addrNTC blk -> StdGen
llrnRng :: StdGen
  -- ^ StdGen for various applications, e.g. keep-alive, chain-sync, gsm anti
  -- thundering herd
  , forall (m :: * -> *) addrNTN addrNTC blk.
LowLevelRunNodeArgs m addrNTN addrNTC blk
-> HardForkBlockchainTimeArgs m blk
-> HardForkBlockchainTimeArgs m blk
llrnCustomiseHardForkBlockchainTimeArgs ::
      HardForkBlockchainTimeArgs m blk ->
      HardForkBlockchainTimeArgs m blk
  -- ^ Customise the 'HardForkBlockchainTimeArgs'
  , forall (m :: * -> *) addrNTN addrNTC blk.
LowLevelRunNodeArgs m addrNTN addrNTC blk -> ChainSyncIdleTimeout
llrnChainSyncIdleTimeout :: ChainSyncIdleTimeout
  -- ^ custom Chain-Sync idle timeout
  , forall (m :: * -> *) addrNTN addrNTC blk.
LowLevelRunNodeArgs m addrNTN addrNTC blk -> GenesisConfig
llrnGenesisConfig :: GenesisConfig
  , forall (m :: * -> *) addrNTN addrNTC blk.
LowLevelRunNodeArgs m addrNTN addrNTC blk
-> NodeKernel m addrNTN (ConnectionId addrNTC) blk
-> CardanoConsensusArguments addrNTN m
-> Applications
     addrNTN
     NodeToNodeVersion
     NodeToNodeVersionData
     addrNTC
     NodeToClientVersion
     NodeToClientVersionData
     m
     NodeToNodeInitiatorResult
-> m ()
llrnRunDataDiffusion ::
      NodeKernel m addrNTN (ConnectionId addrNTC) blk ->
      Cardano.Diffusion.CardanoConsensusArguments addrNTN m ->
      Cardano.Diffusion.Applications
        addrNTN
        NodeToNodeVersion
        NodeToNodeVersionData
        addrNTC
        NodeToClientVersion
        NodeToClientVersionData
        m
        NodeToNodeInitiatorResult ->
      m ()
  -- ^ How to run the data diffusion applications
  --
  -- 'run' will not return before this does.
  , forall (m :: * -> *) addrNTN addrNTC blk.
LowLevelRunNodeArgs m addrNTN addrNTC blk
-> NodeToClientVersionData
llrnVersionDataNTC :: NodeToClientVersionData
  , forall (m :: * -> *) addrNTN addrNTC blk.
LowLevelRunNodeArgs m addrNTN addrNTC blk -> NodeToNodeVersionData
llrnVersionDataNTN :: NodeToNodeVersionData
  , forall (m :: * -> *) addrNTN addrNTC blk.
LowLevelRunNodeArgs m addrNTN addrNTC blk
-> Map NodeToNodeVersion (BlockNodeToNodeVersion blk)
llrnNodeToNodeVersions :: Map NodeToNodeVersion (BlockNodeToNodeVersion blk)
  -- ^ node-to-node protocol versions to run.
  , forall (m :: * -> *) addrNTN addrNTC blk.
LowLevelRunNodeArgs m addrNTN addrNTC blk
-> Map NodeToClientVersion (BlockNodeToClientVersion blk)
llrnNodeToClientVersions :: Map NodeToClientVersion (BlockNodeToClientVersion blk)
  -- ^ node-to-client protocol versions to run.
  , forall (m :: * -> *) addrNTN addrNTC blk.
LowLevelRunNodeArgs m addrNTN addrNTC blk -> NominalDiffTime
llrnMaxCaughtUpAge :: NominalDiffTime
  -- ^ If the volatile tip is older than this, then the node will exit the
  -- @CaughtUp@ state.
  , forall (m :: * -> *) addrNTN addrNTC blk.
LowLevelRunNodeArgs m addrNTN addrNTC blk -> ClockSkew
llrnMaxClockSkew :: InFutureCheck.ClockSkew
  -- ^ Maximum clock skew
  , forall (m :: * -> *) addrNTN addrNTC blk.
LowLevelRunNodeArgs m addrNTN addrNTC blk
-> StrictTVar m (PublicPeerSelectionState addrNTN)
llrnPublicPeerSelectionStateVar :: StrictSTM.StrictTVar m (PublicPeerSelectionState addrNTN)
  , forall (m :: * -> *) addrNTN addrNTC blk.
LowLevelRunNodeArgs m addrNTN addrNTC blk
-> Complete LedgerDbFlavorArgs m
llrnLdbFlavorArgs :: Complete LedgerDbFlavorArgs m
  -- ^ The flavor arguments
  }

data NodeDatabasePaths
  = -- | Databases will be stored under this path, such that given a
    -- path @/foo@, databases will be in @/foo/{immutable,volatile,...}@.
    OnePathForAllDbs
      FilePath
  | MultipleDbPaths
      -- | Immutable path, usually pointing to a non-necessarily
      -- performant volume. ImmutableDB will be stored under this path,
      -- so given @/foo@, the ImmutableDB will be in @/foo/immutable@.
      FilePath
      -- | Non-immutable (volatile data) path, usually pointing to a
      -- performant volume. Databases other than the ImmutableDB will
      -- be stored under this path, so given @/bar@, it will contain
      -- @/bar/{volatile,ledger,...}@.
      FilePath

immutableDbPath :: NodeDatabasePaths -> FilePath
immutableDbPath :: NodeDatabasePaths -> FilePath
immutableDbPath (OnePathForAllDbs FilePath
f) = FilePath
f
immutableDbPath (MultipleDbPaths FilePath
imm FilePath
_) = FilePath
imm

nonImmutableDbPath :: NodeDatabasePaths -> FilePath
nonImmutableDbPath :: NodeDatabasePaths -> FilePath
nonImmutableDbPath (OnePathForAllDbs FilePath
f) = FilePath
f
nonImmutableDbPath (MultipleDbPaths FilePath
_ FilePath
vol) = FilePath
vol

-- | Higher-level arguments that can determine the 'LowLevelRunNodeArgs' under
-- some usual assumptions for realistic use cases such as in @cardano-node@.
--
-- See 'stdLowLevelRunNodeArgsIO'.
data
  StdRunNodeArgs
    m
    blk
  = StdRunNodeArgs
  { forall (m :: * -> *) blk. StdRunNodeArgs m blk -> Maybe Word
srnBfcMaxConcurrencyBulkSync :: Maybe Word
  , forall (m :: * -> *) blk. StdRunNodeArgs m blk -> Maybe Word
srnBfcMaxConcurrencyDeadline :: Maybe Word
  , forall (m :: * -> *) blk. StdRunNodeArgs m blk -> Bool
srnChainDbValidateOverride :: Bool
  -- ^ If @True@, validate the ChainDB on init no matter what
  , forall (m :: * -> *) blk. StdRunNodeArgs m blk -> NodeDatabasePaths
srnDatabasePath :: NodeDatabasePaths
  -- ^ Location of the DBs
  , forall (m :: * -> *) blk.
StdRunNodeArgs m blk -> CardanoNodeArguments m
srnDiffusionArguments :: Cardano.Diffusion.CardanoNodeArguments m
  , forall (m :: * -> *) blk.
StdRunNodeArgs m blk -> CardanoConfiguration m
srnDiffusionConfiguration :: Cardano.Diffusion.CardanoConfiguration m
  , forall (m :: * -> *) blk. StdRunNodeArgs m blk -> CardanoTracers m
srnDiffusionTracers :: Cardano.Diffusion.CardanoTracers m
  , forall (m :: * -> *) blk. StdRunNodeArgs m blk -> Bool
srnEnableInDevelopmentVersions :: Bool
  -- ^ If @False@, then the node will limit the negotiated NTN and NTC
  -- versions to the latest " official " release (as chosen by Network and
  -- Consensus Team, with input from Node Team)
  , forall (m :: * -> *) blk.
StdRunNodeArgs m blk -> Tracer m (TraceEvent blk)
srnTraceChainDB :: Tracer m (ChainDB.TraceEvent blk)
  , forall (m :: * -> *) blk.
StdRunNodeArgs m blk -> Maybe MempoolCapacityBytesOverride
srnMaybeMempoolCapacityOverride :: Maybe MempoolCapacityBytesOverride
  -- ^ Determine whether to use the system default mempool capacity or explicitly set
  -- capacity of the mempool.
  , forall (m :: * -> *) blk.
StdRunNodeArgs m blk -> ChainSyncIdleTimeout
srnChainSyncIdleTimeout :: ChainSyncIdleTimeout
  , -- Ad hoc values to replace default ChainDB configurations
    forall (m :: * -> *) blk.
StdRunNodeArgs m blk -> SnapshotPolicyArgs
srnSnapshotPolicyArgs :: SnapshotPolicyArgs
  , forall (m :: * -> *) blk. StdRunNodeArgs m blk -> QueryBatchSize
srnQueryBatchSize :: QueryBatchSize
  , forall (m :: * -> *) blk.
StdRunNodeArgs m blk -> Complete LedgerDbFlavorArgs m
srnLdbFlavorArgs :: Complete LedgerDbFlavorArgs m
  }

{-------------------------------------------------------------------------------
  Entrypoints to the Consensus Layer node functionality
-------------------------------------------------------------------------------}

pure []

-- | Combination of 'runWith' and 'stdLowLevelRunArgsIO'
run ::
  forall blk.
  RunNode blk =>
  RunNodeArgs IO RemoteAddress LocalAddress blk ->
  StdRunNodeArgs IO blk ->
  IO ()
run :: forall blk.
RunNode blk =>
RunNodeArgs IO RemoteAddress LocalAddress blk
-> StdRunNodeArgs IO blk -> IO ()
run RunNodeArgs IO RemoteAddress LocalAddress blk
args StdRunNodeArgs IO blk
stdArgs =
  RunNodeArgs IO RemoteAddress LocalAddress blk
-> StdRunNodeArgs IO blk
-> IO (LowLevelRunNodeArgs IO RemoteAddress LocalAddress blk)
forall blk.
RunNode blk =>
RunNodeArgs IO RemoteAddress LocalAddress blk
-> StdRunNodeArgs IO blk
-> IO (LowLevelRunNodeArgs IO RemoteAddress LocalAddress blk)
stdLowLevelRunNodeArgsIO RunNodeArgs IO RemoteAddress LocalAddress blk
args StdRunNodeArgs IO blk
stdArgs
    IO (LowLevelRunNodeArgs IO RemoteAddress LocalAddress blk)
-> (LowLevelRunNodeArgs IO RemoteAddress LocalAddress blk -> IO ())
-> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= RunNodeArgs IO RemoteAddress LocalAddress blk
-> (NodeToNodeVersion -> RemoteAddress -> Encoding)
-> (NodeToNodeVersion -> forall s. Decoder s RemoteAddress)
-> LowLevelRunNodeArgs IO RemoteAddress LocalAddress blk
-> IO ()
forall (m :: * -> *) addrNTN addrNTC blk.
(RunNode blk, IOLike m, Hashable addrNTN, NetworkIO m,
 NetworkAddr addrNTN) =>
RunNodeArgs m addrNTN addrNTC blk
-> (NodeToNodeVersion -> addrNTN -> Encoding)
-> (NodeToNodeVersion -> forall s. Decoder s addrNTN)
-> LowLevelRunNodeArgs m addrNTN addrNTC blk
-> m ()
runWith RunNodeArgs IO RemoteAddress LocalAddress blk
args NodeToNodeVersion -> RemoteAddress -> Encoding
encodeRemoteAddress NodeToNodeVersion -> Decoder s RemoteAddress
NodeToNodeVersion -> forall s. Decoder s RemoteAddress
forall s. NodeToNodeVersion -> Decoder s RemoteAddress
decodeRemoteAddress

-- | Extra constraints used by `ouroboros-network`.
type NetworkIO m =
  ( MonadTime m
  , MonadTimer m
  , MonadLabelledSTM m
  )

-- | Extra constraints used by `ouroboros-network`.
type NetworkAddr addr =
  ( Ord addr
  , Typeable addr
  , NoThunks addr
  , NFData addr
  )

-- | Start a node.
--
-- This opens the 'ChainDB', sets up the 'NodeKernel' and initialises the
-- network layer.
--
-- This function runs forever unless an exception is thrown.
--
-- This function spawns a resource registry (which we will refer to as
-- __the consensus registry__) that will include the ChainDB as one of
-- its resources. When the Consensus layer is shut down, the consensus
-- resource registry will exit the scope of the 'withRegistry'
-- function. This causes all resources allocated in the registry
-- —including the ChainDB— to be closed.
--
-- During it's operation, different consensus threads will create
-- resources associated with the ChainDB, eg Forkers in the LedgerDB,
-- or Followers in the ChainDB. These resources are not created by the
-- database themselves (LedgerDB, VolatileDB, and ImmutableDB). For
-- example, chain selection opens a forker using the LedgerDB.
-- Crucially, this means that clients creating these resources are
-- instantiated after the ChainDB.
--
-- We rely on a specific sequence of events for this design to be correct:
--
-- - The ChainDB is only closed by exiting the scope of the consensus
--   resource registry.
--
-- - If a client creates resources tied to any of the
--   aforementioned databases and is forked into a separate thread,
--   that thread is linked to the consensus registry. Because resources
--   in a registry are deallocated in reverse order of allocation, any
--   resources created by such threads will be deallocated before the
--   ChainDB is closed, ensuring proper cleanup.
--
-- Currently, we have two distinct approaches to resource management
-- and database closure:
--
-- - In the LedgerDB, closing the database does not close any resources
--   created by its clients. We rely on the resource registry to deallocate
--   these resources before the LedgerDB is closed. However, after closing
--   the LedgerDB, the only permitted action on these resources is to free them.
--   See 'ldbForkers'.
--
-- - In the ChainDB, closing the database also closes all followers and
--   iterators.
--
-- TODO: Ideally, the ChainDB and LedgerDB should follow a consistent
-- approach to resource deallocation.
runWith ::
  forall m addrNTN addrNTC blk.
  ( RunNode blk
  , IOLike m
  , Hashable addrNTN -- the constraint comes from `initNodeKernel`
  , NetworkIO m
  , NetworkAddr addrNTN
  ) =>
  RunNodeArgs m addrNTN addrNTC blk ->
  (NodeToNodeVersion -> addrNTN -> CBOR.Encoding) ->
  (NodeToNodeVersion -> forall s. CBOR.Decoder s addrNTN) ->
  LowLevelRunNodeArgs m addrNTN addrNTC blk ->
  m ()
runWith :: forall (m :: * -> *) addrNTN addrNTC blk.
(RunNode blk, IOLike m, Hashable addrNTN, NetworkIO m,
 NetworkAddr addrNTN) =>
RunNodeArgs m addrNTN addrNTC blk
-> (NodeToNodeVersion -> addrNTN -> Encoding)
-> (NodeToNodeVersion -> forall s. Decoder s addrNTN)
-> LowLevelRunNodeArgs m addrNTN addrNTC blk
-> m ()
runWith RunNodeArgs{STM m UseBootstrapPeers
ProtocolInfo blk
PeerSharing
GenesisConfig
Tracers m (ConnectionId addrNTN) (ConnectionId addrNTC) blk
Tracers m addrNTN blk DeserialiseFailure
Tracers m (ConnectionId addrNTC) blk DeserialiseFailure
ResourceRegistry m
-> NodeKernel m addrNTN (ConnectionId addrNTC) blk -> m ()
rnTraceConsensus :: forall (m :: * -> *) addrNTN addrNTC blk.
RunNodeArgs m addrNTN addrNTC blk
-> Tracers m (ConnectionId addrNTN) (ConnectionId addrNTC) blk
rnTraceNTN :: forall (m :: * -> *) addrNTN addrNTC blk.
RunNodeArgs m addrNTN addrNTC blk
-> Tracers m addrNTN blk DeserialiseFailure
rnTraceNTC :: forall (m :: * -> *) addrNTN addrNTC blk.
RunNodeArgs m addrNTN addrNTC blk
-> Tracers m (ConnectionId addrNTC) blk DeserialiseFailure
rnProtocolInfo :: forall (m :: * -> *) addrNTN addrNTC blk.
RunNodeArgs m addrNTN addrNTC blk -> ProtocolInfo blk
rnNodeKernelHook :: forall (m :: * -> *) addrNTN addrNTC blk.
RunNodeArgs m addrNTN addrNTC blk
-> ResourceRegistry m
-> NodeKernel m addrNTN (ConnectionId addrNTC) blk
-> m ()
rnPeerSharing :: forall (m :: * -> *) addrNTN addrNTC blk.
RunNodeArgs m addrNTN addrNTC blk -> PeerSharing
rnGetUseBootstrapPeers :: forall (m :: * -> *) addrNTN addrNTC blk.
RunNodeArgs m addrNTN addrNTC blk -> STM m UseBootstrapPeers
rnGenesisConfig :: forall (m :: * -> *) addrNTN addrNTC blk.
RunNodeArgs m addrNTN addrNTC blk -> GenesisConfig
rnTraceConsensus :: Tracers m (ConnectionId addrNTN) (ConnectionId addrNTC) blk
rnTraceNTN :: Tracers m addrNTN blk DeserialiseFailure
rnTraceNTC :: Tracers m (ConnectionId addrNTC) blk DeserialiseFailure
rnProtocolInfo :: ProtocolInfo blk
rnNodeKernelHook :: ResourceRegistry m
-> NodeKernel m addrNTN (ConnectionId addrNTC) blk -> m ()
rnPeerSharing :: PeerSharing
rnGetUseBootstrapPeers :: STM m UseBootstrapPeers
rnGenesisConfig :: GenesisConfig
..} NodeToNodeVersion -> addrNTN -> Encoding
encAddrNtN NodeToNodeVersion -> forall s. Decoder s addrNTN
decAddrNtN LowLevelRunNodeArgs{Int
StdGen
Map NodeToClientVersion (BlockNodeToClientVersion blk)
Map NodeToNodeVersion (BlockNodeToNodeVersion blk)
NominalDiffTime
StrictTVar m (PublicPeerSelectionState addrNTN)
ClockSkew
Complete LedgerDbFlavorArgs m
Incomplete ChainDbArgs m blk
NodeToClientVersionData
NodeToNodeVersionData
ChainSyncIdleTimeout
GenesisConfig
HardForkBlockchainTimeArgs m blk
-> HardForkBlockchainTimeArgs m blk
RelativeMountPoint -> SomeHasFS m
Complete ChainDbArgs m blk -> Complete ChainDbArgs m blk
NodeKernelArgs m addrNTN (ConnectionId addrNTC) blk
-> NodeKernelArgs m addrNTN (ConnectionId addrNTC) blk
NodeKernel m addrNTN (ConnectionId addrNTC) blk
-> CardanoConsensusArguments addrNTN m
-> Applications
     addrNTN
     NodeToNodeVersion
     NodeToNodeVersionData
     addrNTC
     NodeToClientVersion
     NodeToClientVersionData
     m
     NodeToNodeInitiatorResult
-> m ()
forall a.
(LastShutDownWasClean -> (ChainDB m blk -> m a -> m a) -> m a)
-> m a
llrnWithCheckedDB :: forall (m :: * -> *) addrNTN addrNTC blk.
LowLevelRunNodeArgs m addrNTN addrNTC blk
-> forall a.
   (LastShutDownWasClean -> (ChainDB m blk -> m a -> m a) -> m a)
   -> m a
llrnChainDbArgsDefaults :: forall (m :: * -> *) addrNTN addrNTC blk.
LowLevelRunNodeArgs m addrNTN addrNTC blk
-> Incomplete ChainDbArgs m blk
llrnMkImmutableHasFS :: forall (m :: * -> *) addrNTN addrNTC blk.
LowLevelRunNodeArgs m addrNTN addrNTC blk
-> RelativeMountPoint -> SomeHasFS m
llrnMkVolatileHasFS :: forall (m :: * -> *) addrNTN addrNTC blk.
LowLevelRunNodeArgs m addrNTN addrNTC blk
-> RelativeMountPoint -> SomeHasFS m
llrnCustomiseChainDbArgs :: forall (m :: * -> *) addrNTN addrNTC blk.
LowLevelRunNodeArgs m addrNTN addrNTC blk
-> Complete ChainDbArgs m blk -> Complete ChainDbArgs m blk
llrnCustomiseNodeKernelArgs :: forall (m :: * -> *) addrNTN addrNTC blk.
LowLevelRunNodeArgs m addrNTN addrNTC blk
-> NodeKernelArgs m addrNTN (ConnectionId addrNTC) blk
-> NodeKernelArgs m addrNTN (ConnectionId addrNTC) blk
llrnBfcSalt :: forall (m :: * -> *) addrNTN addrNTC blk.
LowLevelRunNodeArgs m addrNTN addrNTC blk -> Int
llrnRng :: forall (m :: * -> *) addrNTN addrNTC blk.
LowLevelRunNodeArgs m addrNTN addrNTC blk -> StdGen
llrnCustomiseHardForkBlockchainTimeArgs :: forall (m :: * -> *) addrNTN addrNTC blk.
LowLevelRunNodeArgs m addrNTN addrNTC blk
-> HardForkBlockchainTimeArgs m blk
-> HardForkBlockchainTimeArgs m blk
llrnChainSyncIdleTimeout :: forall (m :: * -> *) addrNTN addrNTC blk.
LowLevelRunNodeArgs m addrNTN addrNTC blk -> ChainSyncIdleTimeout
llrnGenesisConfig :: forall (m :: * -> *) addrNTN addrNTC blk.
LowLevelRunNodeArgs m addrNTN addrNTC blk -> GenesisConfig
llrnRunDataDiffusion :: forall (m :: * -> *) addrNTN addrNTC blk.
LowLevelRunNodeArgs m addrNTN addrNTC blk
-> NodeKernel m addrNTN (ConnectionId addrNTC) blk
-> CardanoConsensusArguments addrNTN m
-> Applications
     addrNTN
     NodeToNodeVersion
     NodeToNodeVersionData
     addrNTC
     NodeToClientVersion
     NodeToClientVersionData
     m
     NodeToNodeInitiatorResult
-> m ()
llrnVersionDataNTC :: forall (m :: * -> *) addrNTN addrNTC blk.
LowLevelRunNodeArgs m addrNTN addrNTC blk
-> NodeToClientVersionData
llrnVersionDataNTN :: forall (m :: * -> *) addrNTN addrNTC blk.
LowLevelRunNodeArgs m addrNTN addrNTC blk -> NodeToNodeVersionData
llrnNodeToNodeVersions :: forall (m :: * -> *) addrNTN addrNTC blk.
LowLevelRunNodeArgs m addrNTN addrNTC blk
-> Map NodeToNodeVersion (BlockNodeToNodeVersion blk)
llrnNodeToClientVersions :: forall (m :: * -> *) addrNTN addrNTC blk.
LowLevelRunNodeArgs m addrNTN addrNTC blk
-> Map NodeToClientVersion (BlockNodeToClientVersion blk)
llrnMaxCaughtUpAge :: forall (m :: * -> *) addrNTN addrNTC blk.
LowLevelRunNodeArgs m addrNTN addrNTC blk -> NominalDiffTime
llrnMaxClockSkew :: forall (m :: * -> *) addrNTN addrNTC blk.
LowLevelRunNodeArgs m addrNTN addrNTC blk -> ClockSkew
llrnPublicPeerSelectionStateVar :: forall (m :: * -> *) addrNTN addrNTC blk.
LowLevelRunNodeArgs m addrNTN addrNTC blk
-> StrictTVar m (PublicPeerSelectionState addrNTN)
llrnLdbFlavorArgs :: forall (m :: * -> *) addrNTN addrNTC blk.
LowLevelRunNodeArgs m addrNTN addrNTC blk
-> Complete LedgerDbFlavorArgs m
llrnWithCheckedDB :: forall a.
(LastShutDownWasClean -> (ChainDB m blk -> m a -> m a) -> m a)
-> m a
llrnChainDbArgsDefaults :: Incomplete ChainDbArgs m blk
llrnMkImmutableHasFS :: RelativeMountPoint -> SomeHasFS m
llrnMkVolatileHasFS :: RelativeMountPoint -> SomeHasFS m
llrnCustomiseChainDbArgs :: Complete ChainDbArgs m blk -> Complete ChainDbArgs m blk
llrnCustomiseNodeKernelArgs :: NodeKernelArgs m addrNTN (ConnectionId addrNTC) blk
-> NodeKernelArgs m addrNTN (ConnectionId addrNTC) blk
llrnBfcSalt :: Int
llrnRng :: StdGen
llrnCustomiseHardForkBlockchainTimeArgs :: HardForkBlockchainTimeArgs m blk
-> HardForkBlockchainTimeArgs m blk
llrnChainSyncIdleTimeout :: ChainSyncIdleTimeout
llrnGenesisConfig :: GenesisConfig
llrnRunDataDiffusion :: NodeKernel m addrNTN (ConnectionId addrNTC) blk
-> CardanoConsensusArguments addrNTN m
-> Applications
     addrNTN
     NodeToNodeVersion
     NodeToNodeVersionData
     addrNTC
     NodeToClientVersion
     NodeToClientVersionData
     m
     NodeToNodeInitiatorResult
-> m ()
llrnVersionDataNTC :: NodeToClientVersionData
llrnVersionDataNTN :: NodeToNodeVersionData
llrnNodeToNodeVersions :: Map NodeToNodeVersion (BlockNodeToNodeVersion blk)
llrnNodeToClientVersions :: Map NodeToClientVersion (BlockNodeToClientVersion blk)
llrnMaxCaughtUpAge :: NominalDiffTime
llrnMaxClockSkew :: ClockSkew
llrnPublicPeerSelectionStateVar :: StrictTVar m (PublicPeerSelectionState addrNTN)
llrnLdbFlavorArgs :: Complete LedgerDbFlavorArgs m
..} =
  (LastShutDownWasClean -> (ChainDB m blk -> m () -> m ()) -> m ())
-> m ()
forall a.
(LastShutDownWasClean -> (ChainDB m blk -> m a -> m a) -> m a)
-> m a
llrnWithCheckedDB ((LastShutDownWasClean -> (ChainDB m blk -> m () -> m ()) -> m ())
 -> m ())
-> (LastShutDownWasClean
    -> (ChainDB m blk -> m () -> m ()) -> m ())
-> m ()
forall a b. (a -> b) -> a -> b
$ \(LastShutDownWasClean Bool
lastShutDownWasClean) ChainDB m blk -> m () -> m ()
continueWithCleanChainDB ->
    (ResourceRegistry m -> m ()) -> m ()
forall (m :: * -> *) a.
(MonadSTM m, MonadMask m, MonadThread m, HasCallStack) =>
(ResourceRegistry m -> m a) -> m a
withRegistry ((ResourceRegistry m -> m ()) -> m ())
-> (ResourceRegistry m -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \ResourceRegistry m
registry ->
      (SomeException -> Maybe SomeException)
-> (SomeException -> m ()) -> m () -> m ()
forall e b a.
Exception e =>
(e -> Maybe b) -> (b -> m a) -> m a -> m a
forall (m :: * -> *) e b a.
(MonadCatch m, Exception e) =>
(e -> Maybe b) -> (b -> m a) -> m a -> m a
handleJust
        -- Ignore exception thrown in connection handlers and diffusion.
        -- Also ignore 'ExitSuccess'.
        ( Predicate SomeException -> SomeException -> Maybe SomeException
forall a. Predicate a -> a -> Maybe a
runPredicate (Predicate SomeException -> SomeException -> Maybe SomeException)
-> Predicate SomeException -> SomeException -> Maybe SomeException
forall a b. (a -> b) -> a -> b
$
            (SomeException -> Bool) -> Predicate SomeException
forall a. (a -> Bool) -> Predicate a
Predicate
              ( \SomeException
err ->
                  case forall e. Exception e => SomeException -> Maybe e
fromException @ExceptionInLinkedThread SomeException
err of
                    Just (ExceptionInLinkedThread FilePath
_ SomeException
err') ->
                      (Maybe ExitCode -> Maybe ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
/= ExitCode -> Maybe ExitCode
forall a. a -> Maybe a
Just ExitCode
ExitSuccess) (Maybe ExitCode -> Bool) -> Maybe ExitCode -> Bool
forall a b. (a -> b) -> a -> b
$ SomeException -> Maybe ExitCode
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
err'
                    Maybe ExceptionInLinkedThread
Nothing -> Bool
False
              )
              Predicate SomeException
-> Predicate SomeException -> Predicate SomeException
forall a. Semigroup a => a -> a -> a
<> (SomeException -> Bool) -> Predicate SomeException
forall a. (a -> Bool) -> Predicate a
Predicate (Maybe ExceptionInHandler -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe ExceptionInHandler -> Bool)
-> (SomeException -> Maybe ExceptionInHandler)
-> SomeException
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Exception e => SomeException -> Maybe e
fromException @ExceptionInHandler)
              Predicate SomeException
-> Predicate SomeException -> Predicate SomeException
forall a. Semigroup a => a -> a -> a
<> (SomeException -> Bool) -> Predicate SomeException
forall a. (a -> Bool) -> Predicate a
Predicate (Maybe Failure -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe Failure -> Bool)
-> (SomeException -> Maybe Failure) -> SomeException -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Exception e => SomeException -> Maybe e
fromException @Diffusion.Failure)
        )
        ( \SomeException
err ->
            Tracer m SomeException -> SomeException -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith (Tracers m (ConnectionId addrNTN) (ConnectionId addrNTC) blk
-> Tracer m SomeException
forall remotePeer localPeer blk (f :: * -> *).
Tracers' remotePeer localPeer blk f -> f SomeException
consensusErrorTracer Tracers m (ConnectionId addrNTN) (ConnectionId addrNTC) blk
rnTraceConsensus) SomeException
err
              m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> SomeException -> m ()
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO SomeException
err
        )
        (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
          let systemStart :: SystemStart
              systemStart :: SystemStart
systemStart = BlockConfig blk -> SystemStart
forall blk.
ConfigSupportsNode blk =>
BlockConfig blk -> SystemStart
getSystemStart (TopLevelConfig blk -> BlockConfig blk
forall blk. TopLevelConfig blk -> BlockConfig blk
configBlock TopLevelConfig blk
cfg)

              systemTime :: SystemTime m
              systemTime :: SystemTime m
systemTime =
                SystemStart
-> Tracer m (TraceBlockchainTimeEvent UTCTime) -> SystemTime m
forall (m :: * -> *).
(MonadTime m, MonadDelay m) =>
SystemStart
-> Tracer m (TraceBlockchainTimeEvent UTCTime) -> SystemTime m
defaultSystemTime
                  SystemStart
systemStart
                  (Tracers m (ConnectionId addrNTN) (ConnectionId addrNTC) blk
-> Tracer m (TraceBlockchainTimeEvent UTCTime)
forall remotePeer localPeer blk (f :: * -> *).
Tracers' remotePeer localPeer blk f
-> f (TraceBlockchainTimeEvent UTCTime)
blockchainTimeTracer Tracers m (ConnectionId addrNTN) (ConnectionId addrNTC) blk
rnTraceConsensus)

          (genesisArgs, setLoEinChainDbArgs) <-
            GenesisConfig
-> m (GenesisNodeKernelArgs m blk,
      Complete ChainDbArgs m blk -> Complete ChainDbArgs m blk)
forall (m :: * -> *) blk.
(IOLike m, GetHeader blk, Typeable blk) =>
GenesisConfig
-> m (GenesisNodeKernelArgs m blk,
      Complete ChainDbArgs m blk -> Complete ChainDbArgs m blk)
mkGenesisNodeKernelArgs GenesisConfig
llrnGenesisConfig

          let maybeValidateAll
                | Bool
lastShutDownWasClean =
                    Complete ChainDbArgs m blk -> Complete ChainDbArgs m blk
forall a. a -> a
id
                | Bool
otherwise =
                    -- When the last shutdown was not clean, validate the complete
                    -- ChainDB to detect and recover from any disk corruption.
                    Complete ChainDbArgs m blk -> Complete ChainDbArgs m blk
forall (f :: * -> *) (m :: * -> *) blk.
ChainDbArgs f m blk -> ChainDbArgs f m blk
ChainDB.ensureValidateAll

          forM_ (sanityCheckConfig cfg) $ \SanityCheckIssue
issue ->
            Tracer m SanityCheckIssue -> SanityCheckIssue -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith (Tracers m (ConnectionId addrNTN) (ConnectionId addrNTC) blk
-> Tracer m SanityCheckIssue
forall remotePeer localPeer blk (f :: * -> *).
Tracers' remotePeer localPeer blk f -> f SanityCheckIssue
consensusSanityCheckTracer Tracers m (ConnectionId addrNTN) (ConnectionId addrNTC) blk
rnTraceConsensus) SanityCheckIssue
issue

          (chainDB, finalArgs) <-
            openChainDB
              registry
              cfg
              initLedger
              llrnMkImmutableHasFS
              llrnMkVolatileHasFS
              llrnLdbFlavorArgs
              llrnChainDbArgsDefaults
              ( setLoEinChainDbArgs
                  . maybeValidateAll
                  . llrnCustomiseChainDbArgs
              )

          continueWithCleanChainDB chainDB $ do
            btime <-
              hardForkBlockchainTime $
                llrnCustomiseHardForkBlockchainTimeArgs $
                  HardForkBlockchainTimeArgs
                    { hfbtBackoffDelay = pure $ BackoffDelay 60
                    , hfbtGetLedgerState =
                        ledgerState <$> ChainDB.getCurrentLedger chainDB
                    , hfbtLedgerConfig = configLedger cfg
                    , hfbtRegistry = registry
                    , hfbtSystemTime = systemTime
                    , hfbtTracer =
                        contramap
                          (fmap (fromRelativeTime systemStart))
                          (blockchainTimeTracer rnTraceConsensus)
                    , hfbtMaxClockRewind = secondsToNominalDiffTime 20
                    }

            nodeKernelArgs <- do
              durationUntilTooOld <-
                GSM.realDurationUntilTooOld
                  (configLedger cfg)
                  (ledgerState <$> ChainDB.getCurrentLedger chainDB)
                  llrnMaxCaughtUpAge
                  systemTime
              let gsmMarkerFileView =
                    case ChainDbSpecificArgs Identity m blk -> HKD Identity (SomeHasFS m)
forall (f :: * -> *) (m :: * -> *) blk.
ChainDbSpecificArgs f m blk -> HKD f (SomeHasFS m)
ChainDB.cdbsHasFSGsmDB (ChainDbSpecificArgs Identity m blk -> HKD Identity (SomeHasFS m))
-> ChainDbSpecificArgs Identity m blk -> HKD Identity (SomeHasFS m)
forall a b. (a -> b) -> a -> b
$ Complete ChainDbArgs m blk -> ChainDbSpecificArgs Identity m blk
forall (f :: * -> *) (m :: * -> *) blk.
ChainDbArgs f m blk -> ChainDbSpecificArgs f m blk
ChainDB.cdbsArgs Complete ChainDbArgs m blk
finalArgs of
                      SomeHasFS HasFS m h
x -> ChainDB m blk -> HasFS m h -> MarkerFileView m
forall (m :: * -> *) blk h.
MonadThrow m =>
ChainDB m blk -> HasFS m h -> MarkerFileView m
GSM.realMarkerFileView ChainDB m blk
chainDB HasFS m h
x
                  historicityCheck m GsmState
getGsmState =
                    case GenesisConfig -> Maybe HistoricityCutoff
gcHistoricityCutoff GenesisConfig
llrnGenesisConfig of
                      Maybe HistoricityCutoff
Nothing -> HistoricityCheck m blk
forall (m :: * -> *) blk. Applicative m => HistoricityCheck m blk
HistoricityCheck.noCheck
                      Just HistoricityCutoff
historicityCutoff ->
                        SystemTime m
-> m GsmState -> HistoricityCutoff -> HistoricityCheck m blk
forall (m :: * -> *) blk.
(Monad m, HasHeader blk, HasAnnTip blk) =>
SystemTime m
-> m GsmState -> HistoricityCutoff -> HistoricityCheck m blk
HistoricityCheck.mkCheck SystemTime m
systemTime m GsmState
getGsmState HistoricityCutoff
historicityCutoff
              fmap (nodeKernelArgsEnforceInvariants . llrnCustomiseNodeKernelArgs) $
                mkNodeKernelArgs
                  registry
                  llrnBfcSalt
                  gsmAntiThunderingHerd
                  keepAliveRng
                  cfg
                  rnTraceConsensus
                  btime
                  (InFutureCheck.realHeaderInFutureCheck llrnMaxClockSkew systemTime)
                  historicityCheck
                  chainDB
                  llrnMaxCaughtUpAge
                  (Just durationUntilTooOld)
                  gsmMarkerFileView
                  rnGetUseBootstrapPeers
                  llrnPublicPeerSelectionStateVar
                  genesisArgs
                  DiffusionPipeliningOn
            nodeKernel <- initNodeKernel nodeKernelArgs
            rnNodeKernelHook registry nodeKernel
            churnModeVar <- StrictSTM.newTVarIO ChurnModeNormal
            churnMetrics <- newPeerMetric Diffusion.peerMetricsConfiguration
            let consensusDiffusionArgs =
                  Cardano.Diffusion.CardanoConsensusArguments
                    { StrictTVar m ChurnMode
churnModeVar :: StrictTVar m ChurnMode
churnModeVar :: StrictTVar m ChurnMode
Cardano.Diffusion.churnModeVar
                    , PeerMetrics m addrNTN
churnMetrics :: PeerMetrics m addrNTN
churnMetrics :: PeerMetrics m addrNTN
Cardano.Diffusion.churnMetrics
                    , ledgerPeersAPI :: LedgerPeersConsensusInterface (LedgerPeersConsensusInterface m) m
Cardano.Diffusion.ledgerPeersAPI =
                        LedgerPeersConsensusInterface
                          { lpGetLatestSlot :: STM m (WithOrigin SlotNo)
lpGetLatestSlot = NodeKernel m addrNTN (ConnectionId addrNTC) blk
-> STM m (WithOrigin SlotNo)
forall (m :: * -> *) blk addrNTN addrNTC.
(IOLike m, UpdateLedger blk) =>
NodeKernel m addrNTN addrNTC blk -> STM m (WithOrigin SlotNo)
getImmTipSlot NodeKernel m addrNTN (ConnectionId addrNTC) blk
nodeKernel
                          , lpGetLedgerPeers :: STM m [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
lpGetLedgerPeers = [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
-> Maybe [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
-> [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
 -> [(PoolStake, NonEmpty LedgerRelayAccessPoint)])
-> STM m (Maybe [(PoolStake, NonEmpty LedgerRelayAccessPoint)])
-> STM m [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NodeKernel m addrNTN (ConnectionId addrNTC) blk
-> (LedgerState blk EmptyMK -> Bool)
-> STM m (Maybe [(PoolStake, NonEmpty LedgerRelayAccessPoint)])
forall (m :: * -> *) blk addrNTN addrNTC.
(IOLike m, LedgerSupportsPeerSelection blk) =>
NodeKernel m addrNTN addrNTC blk
-> (LedgerState blk EmptyMK -> Bool)
-> STM m (Maybe [(PoolStake, NonEmpty LedgerRelayAccessPoint)])
getPeersFromCurrentLedger NodeKernel m addrNTN (ConnectionId addrNTC) blk
nodeKernel (Bool -> LedgerState blk EmptyMK -> Bool
forall a b. a -> b -> a
const Bool
True)
                          , lpExtraAPI :: LedgerPeersConsensusInterface m
lpExtraAPI =
                              Cardano.LedgerPeersConsensusInterface
                                { readFetchMode :: STM m FetchMode
Cardano.readFetchMode = NodeKernel m addrNTN (ConnectionId addrNTC) blk -> STM m FetchMode
forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernel m addrNTN addrNTC blk -> STM m FetchMode
getFetchMode NodeKernel m addrNTN (ConnectionId addrNTC) blk
nodeKernel
                                , getLedgerStateJudgement :: STM m LedgerStateJudgement
Cardano.getLedgerStateJudgement = GsmState -> LedgerStateJudgement
GSM.gsmStateToLedgerJudgement (GsmState -> LedgerStateJudgement)
-> STM m GsmState -> STM m LedgerStateJudgement
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NodeKernel m addrNTN (ConnectionId addrNTC) blk -> STM m GsmState
forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernel m addrNTN addrNTC blk -> STM m GsmState
getGsmState NodeKernel m addrNTN (ConnectionId addrNTC) blk
nodeKernel
                                , updateOutboundConnectionsState :: OutboundConnectionsState -> STM m ()
Cardano.updateOutboundConnectionsState =
                                    let varOcs :: StrictTVar m OutboundConnectionsState
varOcs = NodeKernel m addrNTN (ConnectionId addrNTC) blk
-> StrictTVar m OutboundConnectionsState
forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernel m addrNTN addrNTC blk
-> StrictTVar m OutboundConnectionsState
getOutboundConnectionsState NodeKernel m addrNTN (ConnectionId addrNTC) blk
nodeKernel
                                     in \OutboundConnectionsState
newOcs -> do
                                          oldOcs <- StrictTVar m OutboundConnectionsState
-> STM m OutboundConnectionsState
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m OutboundConnectionsState
varOcs
                                          when (newOcs /= oldOcs) $ writeTVar varOcs newOcs
                                }
                          }
                    , readUseBootstrapPeers :: STM m UseBootstrapPeers
Cardano.Diffusion.readUseBootstrapPeers = STM m UseBootstrapPeers
rnGetUseBootstrapPeers
                    }

            stdGen <- StrictSTM.newTVarIO peerSelectionRng
            let ntnApps = NodeKernelArgs m addrNTN (ConnectionId addrNTC) blk
-> NodeKernel m addrNTN (ConnectionId addrNTC) blk
-> PeerMetrics m addrNTN
-> (NodeToNodeVersion -> addrNTN -> Encoding)
-> (NodeToNodeVersion -> forall s. Decoder s addrNTN)
-> BlockNodeToNodeVersion blk
-> Apps
     m
     addrNTN
     ByteString
     ByteString
     ByteString
     ByteString
     ByteString
     NodeToNodeInitiatorResult
     ()
mkNodeToNodeApps NodeKernelArgs m addrNTN (ConnectionId addrNTC) blk
nodeKernelArgs NodeKernel m addrNTN (ConnectionId addrNTC) blk
nodeKernel PeerMetrics m addrNTN
churnMetrics NodeToNodeVersion -> addrNTN -> Encoding
encAddrNtN NodeToNodeVersion -> Decoder s addrNTN
NodeToNodeVersion -> forall s. Decoder s addrNTN
decAddrNtN
                ntcApps = NodeKernelArgs m addrNTN (ConnectionId addrNTC) blk
-> NodeKernel m addrNTN (ConnectionId addrNTC) blk
-> BlockNodeToClientVersion blk
-> NodeToClientVersion
-> Apps
     m
     (ConnectionId addrNTC)
     ByteString
     ByteString
     ByteString
     ByteString
     ()
mkNodeToClientApps NodeKernelArgs m addrNTN (ConnectionId addrNTC) blk
nodeKernelArgs NodeKernel m addrNTN (ConnectionId addrNTC) blk
nodeKernel
                apps =
                  StrictTVar m StdGen
-> CardanoConsensusArguments addrNTN m
-> MiniProtocolParameters
-> (BlockNodeToNodeVersion blk
    -> Apps
         m
         addrNTN
         ByteString
         ByteString
         ByteString
         ByteString
         ByteString
         NodeToNodeInitiatorResult
         ())
-> (BlockNodeToClientVersion blk
    -> NodeToClientVersion
    -> Apps
         m
         (ConnectionId addrNTC)
         ByteString
         ByteString
         ByteString
         ByteString
         ())
-> NodeKernel m addrNTN (ConnectionId addrNTC) blk
-> Applications
     addrNTN
     NodeToNodeVersion
     NodeToNodeVersionData
     addrNTC
     NodeToClientVersion
     NodeToClientVersionData
     m
     NodeToNodeInitiatorResult
mkDiffusionApplications
                    StrictTVar m StdGen
stdGen
                    CardanoConsensusArguments addrNTN m
consensusDiffusionArgs
                    (NodeKernelArgs m addrNTN (ConnectionId addrNTC) blk
-> MiniProtocolParameters
forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> MiniProtocolParameters
miniProtocolParameters NodeKernelArgs m addrNTN (ConnectionId addrNTC) blk
nodeKernelArgs)
                    BlockNodeToNodeVersion blk
-> Apps
     m
     addrNTN
     ByteString
     ByteString
     ByteString
     ByteString
     ByteString
     NodeToNodeInitiatorResult
     ()
ntnApps
                    BlockNodeToClientVersion blk
-> NodeToClientVersion
-> Apps
     m
     (ConnectionId addrNTC)
     ByteString
     ByteString
     ByteString
     ByteString
     ()
ntcApps
                    NodeKernel m addrNTN (ConnectionId addrNTC) blk
nodeKernel

            llrnRunDataDiffusion nodeKernel consensusDiffusionArgs apps
 where
  (StdGen
gsmAntiThunderingHerd, StdGen
rng') = StdGen -> (StdGen, StdGen)
forall g. RandomGen g => g -> (g, g)
split StdGen
llrnRng
  (StdGen
peerSelectionRng, StdGen
rng'') = StdGen -> (StdGen, StdGen)
forall g. RandomGen g => g -> (g, g)
split StdGen
rng'
  (StdGen
keepAliveRng, StdGen
ntnAppsRng) = StdGen -> (StdGen, StdGen)
forall g. RandomGen g => g -> (g, g)
split StdGen
rng''

  ProtocolInfo
    { pInfoConfig :: forall b. ProtocolInfo b -> TopLevelConfig b
pInfoConfig = TopLevelConfig blk
cfg
    , pInfoInitLedger :: forall b. ProtocolInfo b -> ExtLedgerState b ValuesMK
pInfoInitLedger = ExtLedgerState blk ValuesMK
initLedger
    } = ProtocolInfo blk
rnProtocolInfo

  codecConfig :: CodecConfig blk
  codecConfig :: CodecConfig blk
codecConfig = TopLevelConfig blk -> CodecConfig blk
forall blk. TopLevelConfig blk -> CodecConfig blk
configCodec TopLevelConfig blk
cfg

  mkNodeToNodeApps ::
    NodeKernelArgs m addrNTN (ConnectionId addrNTC) blk ->
    NodeKernel m addrNTN (ConnectionId addrNTC) blk ->
    PeerMetrics m addrNTN ->
    (NodeToNodeVersion -> addrNTN -> CBOR.Encoding) ->
    (NodeToNodeVersion -> forall s. CBOR.Decoder s addrNTN) ->
    BlockNodeToNodeVersion blk ->
    NTN.Apps
      m
      addrNTN
      ByteString
      ByteString
      ByteString
      ByteString
      ByteString
      NodeToNodeInitiatorResult
      ()
  mkNodeToNodeApps :: NodeKernelArgs m addrNTN (ConnectionId addrNTC) blk
-> NodeKernel m addrNTN (ConnectionId addrNTC) blk
-> PeerMetrics m addrNTN
-> (NodeToNodeVersion -> addrNTN -> Encoding)
-> (NodeToNodeVersion -> forall s. Decoder s addrNTN)
-> BlockNodeToNodeVersion blk
-> Apps
     m
     addrNTN
     ByteString
     ByteString
     ByteString
     ByteString
     ByteString
     NodeToNodeInitiatorResult
     ()
mkNodeToNodeApps NodeKernelArgs m addrNTN (ConnectionId addrNTC) blk
nodeKernelArgs NodeKernel m addrNTN (ConnectionId addrNTC) blk
nodeKernel PeerMetrics m addrNTN
peerMetrics NodeToNodeVersion -> addrNTN -> Encoding
encAddrNTN NodeToNodeVersion -> forall s. Decoder s addrNTN
decAddrNTN BlockNodeToNodeVersion blk
version =
    NodeKernel m addrNTN (ConnectionId addrNTC) blk
-> StdGen
-> Tracers m addrNTN blk DeserialiseFailure
-> (NodeToNodeVersion
    -> Codecs
         blk
         addrNTN
         DeserialiseFailure
         m
         ByteString
         ByteString
         ByteString
         ByteString
         ByteString
         ByteString
         ByteString)
-> ByteLimits ByteString ByteString ByteString ByteString
-> (forall header.
    ProtocolTimeLimitsWithRnd (ChainSync header (Point blk) (Tip blk)))
-> ChainSyncLoPBucketConfig
-> CSJConfig
-> ReportPeerMetrics m (ConnectionId addrNTN)
-> Handlers m addrNTN blk
-> Apps
     m
     addrNTN
     ByteString
     ByteString
     ByteString
     ByteString
     ByteString
     NodeToNodeInitiatorResult
     ()
forall (m :: * -> *) addrNTN addrNTC blk e bCS bBF bTX bKA bPS.
(IOLike m, MonadTimer m, Ord addrNTN, Exception e,
 LedgerSupportsProtocol blk, ShowProxy blk, ShowProxy (Header blk),
 ShowProxy (TxId (GenTx blk)), ShowProxy (GenTx blk)) =>
NodeKernel m addrNTN addrNTC blk
-> StdGen
-> Tracers m addrNTN blk e
-> (NodeToNodeVersion
    -> Codecs blk addrNTN e m bCS bCS bBF bBF bTX bKA bPS)
-> ByteLimits bCS bBF bTX bKA
-> (forall header.
    ProtocolTimeLimitsWithRnd (ChainSync header (Point blk) (Tip blk)))
-> ChainSyncLoPBucketConfig
-> CSJConfig
-> ReportPeerMetrics m (ConnectionId addrNTN)
-> Handlers m addrNTN blk
-> Apps m addrNTN bCS bBF bTX bKA bPS NodeToNodeInitiatorResult ()
NTN.mkApps
      NodeKernel m addrNTN (ConnectionId addrNTC) blk
nodeKernel
      StdGen
ntnAppsRng
      Tracers m addrNTN blk DeserialiseFailure
rnTraceNTN
      (CodecConfig blk
-> BlockNodeToNodeVersion blk
-> (NodeToNodeVersion -> addrNTN -> Encoding)
-> (NodeToNodeVersion -> forall s. Decoder s addrNTN)
-> NodeToNodeVersion
-> Codecs
     blk
     addrNTN
     DeserialiseFailure
     m
     ByteString
     ByteString
     ByteString
     ByteString
     ByteString
     ByteString
     ByteString
forall (m :: * -> *) blk addr.
(IOLike m, SerialiseNodeToNodeConstraints blk) =>
CodecConfig blk
-> BlockNodeToNodeVersion blk
-> (NodeToNodeVersion -> addr -> Encoding)
-> (NodeToNodeVersion -> forall s. Decoder s addr)
-> NodeToNodeVersion
-> Codecs
     blk
     addr
     DeserialiseFailure
     m
     ByteString
     ByteString
     ByteString
     ByteString
     ByteString
     ByteString
     ByteString
NTN.defaultCodecs CodecConfig blk
codecConfig BlockNodeToNodeVersion blk
version NodeToNodeVersion -> addrNTN -> Encoding
encAddrNTN NodeToNodeVersion -> Decoder s addrNTN
NodeToNodeVersion -> forall s. Decoder s addrNTN
decAddrNTN)
      ByteLimits ByteString ByteString ByteString ByteString
NTN.byteLimits
      (ChainSyncIdleTimeout
-> ProtocolTimeLimitsWithRnd
     (ChainSync header (Point blk) (Tip blk))
forall header point tip.
ChainSyncIdleTimeout
-> ProtocolTimeLimitsWithRnd (ChainSync header point tip)
timeLimitsChainSync ChainSyncIdleTimeout
llrnChainSyncIdleTimeout)
      (GenesisConfig -> ChainSyncLoPBucketConfig
gcChainSyncLoPBucketConfig GenesisConfig
llrnGenesisConfig)
      (GenesisConfig -> CSJConfig
gcCSJConfig GenesisConfig
llrnGenesisConfig)
      (PeerMetricsConfiguration
-> PeerMetrics m addrNTN
-> ReportPeerMetrics m (ConnectionId addrNTN)
forall (m :: * -> *) p.
(MonadSTM m, Ord p) =>
PeerMetricsConfiguration
-> PeerMetrics m p -> ReportPeerMetrics m (ConnectionId p)
reportMetric PeerMetricsConfiguration
Diffusion.peerMetricsConfiguration PeerMetrics m addrNTN
peerMetrics)
      (NodeKernelArgs m addrNTN (ConnectionId addrNTC) blk
-> NodeKernel m addrNTN (ConnectionId addrNTC) blk
-> Handlers m addrNTN blk
forall (m :: * -> *) blk addrNTN addrNTC.
(IOLike m, MonadTime m, MonadTimer m, LedgerSupportsMempool blk,
 HasTxId (GenTx blk), LedgerSupportsProtocol blk, Ord addrNTN,
 Hashable addrNTN) =>
NodeKernelArgs m addrNTN addrNTC blk
-> NodeKernel m addrNTN addrNTC blk -> Handlers m addrNTN blk
NTN.mkHandlers NodeKernelArgs m addrNTN (ConnectionId addrNTC) blk
nodeKernelArgs NodeKernel m addrNTN (ConnectionId addrNTC) blk
nodeKernel)

  mkNodeToClientApps ::
    NodeKernelArgs m addrNTN (ConnectionId addrNTC) blk ->
    NodeKernel m addrNTN (ConnectionId addrNTC) blk ->
    BlockNodeToClientVersion blk ->
    NodeToClientVersion ->
    NTC.Apps m (ConnectionId addrNTC) ByteString ByteString ByteString ByteString ()
  mkNodeToClientApps :: NodeKernelArgs m addrNTN (ConnectionId addrNTC) blk
-> NodeKernel m addrNTN (ConnectionId addrNTC) blk
-> BlockNodeToClientVersion blk
-> NodeToClientVersion
-> Apps
     m
     (ConnectionId addrNTC)
     ByteString
     ByteString
     ByteString
     ByteString
     ()
mkNodeToClientApps NodeKernelArgs m addrNTN (ConnectionId addrNTC) blk
nodeKernelArgs NodeKernel m addrNTN (ConnectionId addrNTC) blk
nodeKernel BlockNodeToClientVersion blk
blockVersion NodeToClientVersion
networkVersion =
    NodeKernel m addrNTN (ConnectionId addrNTC) blk
-> Tracers m (ConnectionId addrNTC) blk DeserialiseFailure
-> Codecs
     blk
     DeserialiseFailure
     m
     ByteString
     ByteString
     ByteString
     ByteString
-> Handlers m (ConnectionId addrNTC) blk
-> Apps
     m
     (ConnectionId addrNTC)
     ByteString
     ByteString
     ByteString
     ByteString
     ()
forall (m :: * -> *) addrNTN addrNTC blk e bCS bTX bSQ bTM.
(IOLike m, Exception e, ShowProxy blk, ShowProxy (ApplyTxErr blk),
 ShowProxy (GenTx blk), ShowProxy (GenTxId blk),
 ShowProxy (Query blk),
 forall (fp :: QueryFootprint). ShowQuery (BlockQuery blk fp)) =>
NodeKernel m addrNTN addrNTC blk
-> Tracers m addrNTC blk e
-> Codecs blk e m bCS bTX bSQ bTM
-> Handlers m addrNTC blk
-> Apps m addrNTC bCS bTX bSQ bTM ()
NTC.mkApps
      NodeKernel m addrNTN (ConnectionId addrNTC) blk
nodeKernel
      Tracers m (ConnectionId addrNTC) blk DeserialiseFailure
rnTraceNTC
      (CodecConfig blk
-> BlockNodeToClientVersion blk
-> NodeToClientVersion
-> Codecs
     blk
     DeserialiseFailure
     m
     ByteString
     ByteString
     ByteString
     ByteString
forall (m :: * -> *) blk.
(MonadST m, SerialiseNodeToClientConstraints blk,
 BlockSupportsLedgerQuery blk, Show (BlockNodeToClientVersion blk),
 StandardHash blk, Serialise (HeaderHash blk)) =>
CodecConfig blk
-> BlockNodeToClientVersion blk
-> NodeToClientVersion
-> DefaultCodecs blk m
NTC.defaultCodecs CodecConfig blk
codecConfig BlockNodeToClientVersion blk
blockVersion NodeToClientVersion
networkVersion)
      (NodeKernelArgs m addrNTN (ConnectionId addrNTC) blk
-> NodeKernel m addrNTN (ConnectionId addrNTC) blk
-> Handlers m (ConnectionId addrNTC) blk
forall (m :: * -> *) blk addrNTN addrNTC.
(IOLike m, LedgerSupportsMempool blk, LedgerSupportsProtocol blk,
 BlockSupportsLedgerQuery blk, ConfigSupportsNode blk) =>
NodeKernelArgs m addrNTN addrNTC blk
-> NodeKernel m addrNTN addrNTC blk -> Handlers m addrNTC blk
NTC.mkHandlers NodeKernelArgs m addrNTN (ConnectionId addrNTC) blk
nodeKernelArgs NodeKernel m addrNTN (ConnectionId addrNTC) blk
nodeKernel)

  mkDiffusionApplications ::
    StrictSTM.StrictTVar m StdGen ->
    Cardano.Diffusion.CardanoConsensusArguments addrNTN m ->
    MiniProtocolParameters ->
    ( BlockNodeToNodeVersion blk ->
      NTN.Apps
        m
        addrNTN
        ByteString
        ByteString
        ByteString
        ByteString
        ByteString
        NodeToNodeInitiatorResult
        ()
    ) ->
    ( BlockNodeToClientVersion blk ->
      NodeToClientVersion ->
      NTC.Apps
        m
        (ConnectionId addrNTC)
        ByteString
        ByteString
        ByteString
        ByteString
        ()
    ) ->
    NodeKernel m addrNTN (ConnectionId addrNTC) blk ->
    Cardano.Diffusion.Applications
      addrNTN
      NodeToNodeVersion
      NodeToNodeVersionData
      addrNTC
      NodeToClientVersion
      NodeToClientVersionData
      m
      NodeToNodeInitiatorResult
  mkDiffusionApplications :: StrictTVar m StdGen
-> CardanoConsensusArguments addrNTN m
-> MiniProtocolParameters
-> (BlockNodeToNodeVersion blk
    -> Apps
         m
         addrNTN
         ByteString
         ByteString
         ByteString
         ByteString
         ByteString
         NodeToNodeInitiatorResult
         ())
-> (BlockNodeToClientVersion blk
    -> NodeToClientVersion
    -> Apps
         m
         (ConnectionId addrNTC)
         ByteString
         ByteString
         ByteString
         ByteString
         ())
-> NodeKernel m addrNTN (ConnectionId addrNTC) blk
-> Applications
     addrNTN
     NodeToNodeVersion
     NodeToNodeVersionData
     addrNTC
     NodeToClientVersion
     NodeToClientVersionData
     m
     NodeToNodeInitiatorResult
mkDiffusionApplications
    StrictTVar m StdGen
stdGenVar
    CardanoConsensusArguments addrNTN m
consensusDiffusionArgs
    MiniProtocolParameters
miniProtocolParams
    BlockNodeToNodeVersion blk
-> Apps
     m
     addrNTN
     ByteString
     ByteString
     ByteString
     ByteString
     ByteString
     NodeToNodeInitiatorResult
     ()
ntnApps
    BlockNodeToClientVersion blk
-> NodeToClientVersion
-> Apps
     m
     (ConnectionId addrNTC)
     ByteString
     ByteString
     ByteString
     ByteString
     ()
ntcApps
    NodeKernel m addrNTN (ConnectionId addrNTC) blk
kernel =
      Applications
  addrNTN
  NodeToNodeVersion
  NodeToNodeVersionData
  addrNTC
  NodeToClientVersion
  NodeToClientVersionData
  m
  NodeToNodeInitiatorResult
apps
     where
      apps :: Applications
  addrNTN
  NodeToNodeVersion
  NodeToNodeVersionData
  addrNTC
  NodeToClientVersion
  NodeToClientVersionData
  m
  NodeToNodeInitiatorResult
apps =
        Diffusion.Applications
          { daApplicationInitiatorMode :: Versions
  NodeToNodeVersion
  NodeToNodeVersionData
  (OuroborosBundleWithExpandedCtx
     'InitiatorMode addrNTN ByteString m NodeToNodeInitiatorResult Void)
Diffusion.daApplicationInitiatorMode =
              [Versions
   NodeToNodeVersion
   NodeToNodeVersionData
   (OuroborosBundleWithExpandedCtx
      'InitiatorMode
      addrNTN
      ByteString
      m
      NodeToNodeInitiatorResult
      Void)]
-> Versions
     NodeToNodeVersion
     NodeToNodeVersionData
     (OuroborosBundleWithExpandedCtx
        'InitiatorMode addrNTN ByteString m NodeToNodeInitiatorResult Void)
forall vNum (f :: * -> *) extra r.
(Ord vNum, Foldable f, HasCallStack) =>
f (Versions vNum extra r) -> Versions vNum extra r
combineVersions
                [ NodeToNodeVersion
-> NodeToNodeVersionData
-> (NodeToNodeVersionData
    -> OuroborosBundleWithExpandedCtx
         'InitiatorMode addrNTN ByteString m NodeToNodeInitiatorResult Void)
-> Versions
     NodeToNodeVersion
     NodeToNodeVersionData
     (OuroborosBundleWithExpandedCtx
        'InitiatorMode addrNTN ByteString m NodeToNodeInitiatorResult Void)
forall vNum vData r.
vNum -> vData -> (vData -> r) -> Versions vNum vData r
simpleSingletonVersions
                    NodeToNodeVersion
version
                    NodeToNodeVersionData
llrnVersionDataNTN
                    ( \NodeToNodeVersionData
versionData ->
                        MiniProtocolParameters
-> NodeToNodeVersion
-> NodeToNodeVersionData
-> Apps
     m
     addrNTN
     ByteString
     ByteString
     ByteString
     ByteString
     ByteString
     NodeToNodeInitiatorResult
     ()
-> OuroborosBundleWithExpandedCtx
     'InitiatorMode addrNTN ByteString m NodeToNodeInitiatorResult Void
forall (m :: * -> *) addr b a c.
MiniProtocolParameters
-> NodeToNodeVersion
-> NodeToNodeVersionData
-> Apps m addr b b b b b a c
-> OuroborosBundleWithExpandedCtx 'InitiatorMode addr b m a Void
NTN.initiator MiniProtocolParameters
miniProtocolParams NodeToNodeVersion
version NodeToNodeVersionData
versionData
                        -- Initiator side won't start responder side of Peer
                        -- Sharing protocol so we give a dummy implementation
                        -- here.
                        (Apps
   m
   addrNTN
   ByteString
   ByteString
   ByteString
   ByteString
   ByteString
   NodeToNodeInitiatorResult
   ()
 -> OuroborosBundleWithExpandedCtx
      'InitiatorMode addrNTN ByteString m NodeToNodeInitiatorResult Void)
-> Apps
     m
     addrNTN
     ByteString
     ByteString
     ByteString
     ByteString
     ByteString
     NodeToNodeInitiatorResult
     ()
-> OuroborosBundleWithExpandedCtx
     'InitiatorMode addrNTN ByteString m NodeToNodeInitiatorResult Void
forall a b. (a -> b) -> a -> b
$
                          BlockNodeToNodeVersion blk
-> Apps
     m
     addrNTN
     ByteString
     ByteString
     ByteString
     ByteString
     ByteString
     NodeToNodeInitiatorResult
     ()
ntnApps BlockNodeToNodeVersion blk
blockVersion
                    )
                | (NodeToNodeVersion
version, BlockNodeToNodeVersion blk
blockVersion) <- Map NodeToNodeVersion (BlockNodeToNodeVersion blk)
-> [(NodeToNodeVersion, BlockNodeToNodeVersion blk)]
forall k a. Map k a -> [(k, a)]
Map.toList Map NodeToNodeVersion (BlockNodeToNodeVersion blk)
llrnNodeToNodeVersions
                ]
          , daApplicationInitiatorResponderMode :: Versions
  NodeToNodeVersion
  NodeToNodeVersionData
  (OuroborosBundleWithExpandedCtx
     'InitiatorResponderMode
     addrNTN
     ByteString
     m
     NodeToNodeInitiatorResult
     ())
Diffusion.daApplicationInitiatorResponderMode =
              [Versions
   NodeToNodeVersion
   NodeToNodeVersionData
   (OuroborosBundleWithExpandedCtx
      'InitiatorResponderMode
      addrNTN
      ByteString
      m
      NodeToNodeInitiatorResult
      ())]
-> Versions
     NodeToNodeVersion
     NodeToNodeVersionData
     (OuroborosBundleWithExpandedCtx
        'InitiatorResponderMode
        addrNTN
        ByteString
        m
        NodeToNodeInitiatorResult
        ())
forall vNum (f :: * -> *) extra r.
(Ord vNum, Foldable f, HasCallStack) =>
f (Versions vNum extra r) -> Versions vNum extra r
combineVersions
                [ NodeToNodeVersion
-> NodeToNodeVersionData
-> (NodeToNodeVersionData
    -> OuroborosBundleWithExpandedCtx
         'InitiatorResponderMode
         addrNTN
         ByteString
         m
         NodeToNodeInitiatorResult
         ())
-> Versions
     NodeToNodeVersion
     NodeToNodeVersionData
     (OuroborosBundleWithExpandedCtx
        'InitiatorResponderMode
        addrNTN
        ByteString
        m
        NodeToNodeInitiatorResult
        ())
forall vNum vData r.
vNum -> vData -> (vData -> r) -> Versions vNum vData r
simpleSingletonVersions
                    NodeToNodeVersion
version
                    NodeToNodeVersionData
llrnVersionDataNTN
                    ( \NodeToNodeVersionData
versionData ->
                        MiniProtocolParameters
-> NodeToNodeVersion
-> NodeToNodeVersionData
-> Apps
     m
     addrNTN
     ByteString
     ByteString
     ByteString
     ByteString
     ByteString
     NodeToNodeInitiatorResult
     ()
-> OuroborosBundleWithExpandedCtx
     'InitiatorResponderMode
     addrNTN
     ByteString
     m
     NodeToNodeInitiatorResult
     ()
forall (m :: * -> *) addr b a c.
MiniProtocolParameters
-> NodeToNodeVersion
-> NodeToNodeVersionData
-> Apps m addr b b b b b a c
-> OuroborosBundleWithExpandedCtx
     'InitiatorResponderMode addr b m a c
NTN.initiatorAndResponder MiniProtocolParameters
miniProtocolParams NodeToNodeVersion
version NodeToNodeVersionData
versionData (Apps
   m
   addrNTN
   ByteString
   ByteString
   ByteString
   ByteString
   ByteString
   NodeToNodeInitiatorResult
   ()
 -> OuroborosBundleWithExpandedCtx
      'InitiatorResponderMode
      addrNTN
      ByteString
      m
      NodeToNodeInitiatorResult
      ())
-> Apps
     m
     addrNTN
     ByteString
     ByteString
     ByteString
     ByteString
     ByteString
     NodeToNodeInitiatorResult
     ()
-> OuroborosBundleWithExpandedCtx
     'InitiatorResponderMode
     addrNTN
     ByteString
     m
     NodeToNodeInitiatorResult
     ()
forall a b. (a -> b) -> a -> b
$
                          BlockNodeToNodeVersion blk
-> Apps
     m
     addrNTN
     ByteString
     ByteString
     ByteString
     ByteString
     ByteString
     NodeToNodeInitiatorResult
     ()
ntnApps BlockNodeToNodeVersion blk
blockVersion
                    )
                | (NodeToNodeVersion
version, BlockNodeToNodeVersion blk
blockVersion) <- Map NodeToNodeVersion (BlockNodeToNodeVersion blk)
-> [(NodeToNodeVersion, BlockNodeToNodeVersion blk)]
forall k a. Map k a -> [(k, a)]
Map.toList Map NodeToNodeVersion (BlockNodeToNodeVersion blk)
llrnNodeToNodeVersions
                ]
          , daLocalResponderApplication :: Versions
  NodeToClientVersion
  NodeToClientVersionData
  (OuroborosApplicationWithMinimalCtx
     'ResponderMode addrNTC ByteString m Void ())
Diffusion.daLocalResponderApplication =
              [Versions
   NodeToClientVersion
   NodeToClientVersionData
   (OuroborosApplicationWithMinimalCtx
      'ResponderMode addrNTC ByteString m Void ())]
-> Versions
     NodeToClientVersion
     NodeToClientVersionData
     (OuroborosApplicationWithMinimalCtx
        'ResponderMode addrNTC ByteString m Void ())
forall vNum (f :: * -> *) extra r.
(Ord vNum, Foldable f, HasCallStack) =>
f (Versions vNum extra r) -> Versions vNum extra r
combineVersions
                [ NodeToClientVersion
-> NodeToClientVersionData
-> (NodeToClientVersionData
    -> OuroborosApplicationWithMinimalCtx
         'ResponderMode addrNTC ByteString m Void ())
-> Versions
     NodeToClientVersion
     NodeToClientVersionData
     (OuroborosApplicationWithMinimalCtx
        'ResponderMode addrNTC ByteString m Void ())
forall vNum vData r.
vNum -> vData -> (vData -> r) -> Versions vNum vData r
simpleSingletonVersions
                    NodeToClientVersion
version
                    NodeToClientVersionData
llrnVersionDataNTC
                    (\NodeToClientVersionData
versionData -> NodeToClientVersion
-> NodeToClientVersionData
-> Apps
     m
     (ConnectionId addrNTC)
     ByteString
     ByteString
     ByteString
     ByteString
     ()
-> OuroborosApplicationWithMinimalCtx
     'ResponderMode addrNTC ByteString m Void ()
forall (m :: * -> *) peer b a.
NodeToClientVersion
-> NodeToClientVersionData
-> Apps m (ConnectionId peer) b b b b a
-> OuroborosApplicationWithMinimalCtx
     'ResponderMode peer b m Void a
NTC.responder NodeToClientVersion
version NodeToClientVersionData
versionData (Apps
   m
   (ConnectionId addrNTC)
   ByteString
   ByteString
   ByteString
   ByteString
   ()
 -> OuroborosApplicationWithMinimalCtx
      'ResponderMode addrNTC ByteString m Void ())
-> Apps
     m
     (ConnectionId addrNTC)
     ByteString
     ByteString
     ByteString
     ByteString
     ()
-> OuroborosApplicationWithMinimalCtx
     'ResponderMode addrNTC ByteString m Void ()
forall a b. (a -> b) -> a -> b
$ BlockNodeToClientVersion blk
-> NodeToClientVersion
-> Apps
     m
     (ConnectionId addrNTC)
     ByteString
     ByteString
     ByteString
     ByteString
     ()
ntcApps BlockNodeToClientVersion blk
blockVersion NodeToClientVersion
version)
                | (NodeToClientVersion
version, BlockNodeToClientVersion blk
blockVersion) <- Map NodeToClientVersion (BlockNodeToClientVersion blk)
-> [(NodeToClientVersion, BlockNodeToClientVersion blk)]
forall k a. Map k a -> [(k, a)]
Map.toList Map NodeToClientVersion (BlockNodeToClientVersion blk)
llrnNodeToClientVersions
                ]
          , daRethrowPolicy :: RethrowPolicy
Diffusion.daRethrowPolicy = Proxy blk -> RethrowPolicy
forall blk.
(Typeable blk, StandardHash blk) =>
Proxy blk -> RethrowPolicy
consensusRethrowPolicy (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @blk)
          , daReturnPolicy :: ReturnPolicy NodeToNodeInitiatorResult
Diffusion.daReturnPolicy = ReturnPolicy NodeToNodeInitiatorResult
returnPolicy
          , daRepromoteErrorDelay :: RepromoteDelay
Diffusion.daRepromoteErrorDelay = RepromoteDelay
Diffusion.repromoteErrorDelay
          , daLocalRethrowPolicy :: RethrowPolicy
Diffusion.daLocalRethrowPolicy = RethrowPolicy
localRethrowPolicy
          , daPeerSelectionPolicy :: PeerSelectionPolicy addrNTN m
daPeerSelectionPolicy =
              StrictTVar m StdGen
-> STM m ChurnMode
-> PeerMetrics m addrNTN
-> PeerSelectionPolicy addrNTN m
forall (m :: * -> *) peerAddr.
(MonadSTM m, Ord peerAddr) =>
StrictTVar m StdGen
-> STM m ChurnMode
-> PeerMetrics m peerAddr
-> PeerSelectionPolicy peerAddr m
Cardano.Diffusion.simpleChurnModePeerSelectionPolicy
                StrictTVar m StdGen
stdGenVar
                (StrictTVar m ChurnMode -> STM m ChurnMode
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
StrictSTM.readTVar (StrictTVar m ChurnMode -> STM m ChurnMode)
-> StrictTVar m ChurnMode -> STM m ChurnMode
forall a b. (a -> b) -> a -> b
$ CardanoConsensusArguments addrNTN m -> StrictTVar m ChurnMode
forall ntnAddr (m :: * -> *).
CardanoConsensusArguments ntnAddr m -> StrictTVar m ChurnMode
Cardano.Diffusion.churnModeVar CardanoConsensusArguments addrNTN m
consensusDiffusionArgs)
                (CardanoConsensusArguments addrNTN m -> PeerMetrics m addrNTN
forall ntnAddr (m :: * -> *).
CardanoConsensusArguments ntnAddr m -> PeerMetrics m ntnAddr
Cardano.Diffusion.churnMetrics CardanoConsensusArguments addrNTN m
consensusDiffusionArgs)
          , daPeerSharingRegistry :: PeerSharingRegistry addrNTN m
Diffusion.daPeerSharingRegistry = NodeKernel m addrNTN (ConnectionId addrNTC) blk
-> PeerSharingRegistry addrNTN m
forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernel m addrNTN addrNTC blk -> PeerSharingRegistry addrNTN m
getPeerSharingRegistry NodeKernel m addrNTN (ConnectionId addrNTC) blk
kernel
          }

      localRethrowPolicy :: RethrowPolicy
      localRethrowPolicy :: RethrowPolicy
localRethrowPolicy = RethrowPolicy
forall a. Monoid a => a
mempty

  runPredicate :: Predicate a -> a -> Maybe a
  runPredicate :: forall a. Predicate a -> a -> Maybe a
runPredicate (Predicate a -> Bool
p) a
err = if a -> Bool
p a
err then a -> Maybe a
forall a. a -> Maybe a
Just a
err else Maybe a
forall a. Maybe a
Nothing

-- | Check the DB marker, lock the DB and look for the clean shutdown marker.
--
-- Run the body action with the DB locked.
stdWithCheckedDB ::
  forall blk a.
  (StandardHash blk, Typeable blk) =>
  Proxy blk ->
  Tracer IO (TraceEvent blk) ->
  FilePath ->
  NetworkMagic ->
  -- | Body action with last shutdown was clean.
  (LastShutDownWasClean -> (ChainDB IO blk -> IO a -> IO a) -> IO a) ->
  IO a
stdWithCheckedDB :: forall blk a.
(StandardHash blk, Typeable blk) =>
Proxy blk
-> Tracer IO (TraceEvent blk)
-> FilePath
-> NetworkMagic
-> (LastShutDownWasClean
    -> (ChainDB IO blk -> IO a -> IO a) -> IO a)
-> IO a
stdWithCheckedDB Proxy blk
pb Tracer IO (TraceEvent blk)
tracer FilePath
databasePath NetworkMagic
networkMagic LastShutDownWasClean -> (ChainDB IO blk -> IO a -> IO a) -> IO a
body = do
  -- Check the DB marker first, before doing the lock file, since if the
  -- marker is not present, it expects an empty DB dir.
  (DbMarkerError -> IO ())
-> (() -> IO ()) -> Either DbMarkerError () -> IO ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either DbMarkerError -> IO ()
forall e a. Exception e => e -> IO a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
    (Either DbMarkerError () -> IO ())
-> IO (Either DbMarkerError ()) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< HasFS IO HandleIO
-> MountPoint -> NetworkMagic -> IO (Either DbMarkerError ())
forall (m :: * -> *) h.
MonadThrow m =>
HasFS m h
-> MountPoint -> NetworkMagic -> m (Either DbMarkerError ())
checkDbMarker
      HasFS IO HandleIO
hasFS
      MountPoint
mountPoint
      NetworkMagic
networkMagic

  -- Then create the lock file.
  MountPoint -> IO a -> IO a
forall a. MountPoint -> IO a -> IO a
withLockDB MountPoint
mountPoint (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ Proxy blk
-> Tracer IO (TraceEvent blk)
-> HasFS IO HandleIO
-> (LastShutDownWasClean
    -> (ChainDB IO blk -> IO a -> IO a) -> IO a)
-> IO a
forall a (m :: * -> *) h blk.
(IOLike m, StandardHash blk, Typeable blk) =>
Proxy blk
-> Tracer m (TraceEvent blk)
-> HasFS m h
-> (LastShutDownWasClean -> (ChainDB m blk -> m a -> m a) -> m a)
-> m a
runWithCheckedDB Proxy blk
pb Tracer IO (TraceEvent blk)
tracer HasFS IO HandleIO
hasFS LastShutDownWasClean -> (ChainDB IO blk -> IO a -> IO a) -> IO a
body
 where
  mountPoint :: MountPoint
mountPoint = FilePath -> MountPoint
MountPoint FilePath
databasePath
  hasFS :: HasFS IO HandleIO
hasFS = MountPoint -> HasFS IO HandleIO
forall (m :: * -> *).
(MonadIO m, PrimState IO ~ PrimState m) =>
MountPoint -> HasFS m HandleIO
ioHasFS MountPoint
mountPoint

openChainDB ::
  forall m blk.
  (RunNode blk, IOLike m) =>
  ResourceRegistry m ->
  TopLevelConfig blk ->
  -- | Initial ledger
  ExtLedgerState blk ValuesMK ->
  -- | Immutable FS, see 'NodeDatabasePaths'
  (ChainDB.RelativeMountPoint -> SomeHasFS m) ->
  -- | Volatile FS, see 'NodeDatabasePaths'
  (ChainDB.RelativeMountPoint -> SomeHasFS m) ->
  Complete LedgerDbFlavorArgs m ->
  -- | A set of default arguments (possibly modified from 'defaultArgs')
  Incomplete ChainDbArgs m blk ->
  -- | Customise the 'ChainDbArgs'
  (Complete ChainDbArgs m blk -> Complete ChainDbArgs m blk) ->
  m (ChainDB m blk, Complete ChainDbArgs m blk)
openChainDB :: forall (m :: * -> *) blk.
(RunNode blk, IOLike m) =>
ResourceRegistry m
-> TopLevelConfig blk
-> ExtLedgerState blk ValuesMK
-> (RelativeMountPoint -> SomeHasFS m)
-> (RelativeMountPoint -> SomeHasFS m)
-> Complete LedgerDbFlavorArgs m
-> Incomplete ChainDbArgs m blk
-> (Complete ChainDbArgs m blk -> Complete ChainDbArgs m blk)
-> m (ChainDB m blk, Complete ChainDbArgs m blk)
openChainDB ResourceRegistry m
registry TopLevelConfig blk
cfg ExtLedgerState blk ValuesMK
initLedger RelativeMountPoint -> SomeHasFS m
fsImm RelativeMountPoint -> SomeHasFS m
fsVol Complete LedgerDbFlavorArgs m
flavorArgs Incomplete ChainDbArgs m blk
defArgs Complete ChainDbArgs m blk -> Complete ChainDbArgs m blk
customiseArgs =
  let args :: Complete ChainDbArgs m blk
args =
        Complete ChainDbArgs m blk -> Complete ChainDbArgs m blk
customiseArgs (Complete ChainDbArgs m blk -> Complete ChainDbArgs m blk)
-> Complete ChainDbArgs m blk -> Complete ChainDbArgs m blk
forall a b. (a -> b) -> a -> b
$
          ResourceRegistry m
-> TopLevelConfig blk
-> ExtLedgerState blk ValuesMK
-> ChunkInfo
-> (blk -> Bool)
-> (RelativeMountPoint -> SomeHasFS m)
-> (RelativeMountPoint -> SomeHasFS m)
-> Complete LedgerDbFlavorArgs m
-> Incomplete ChainDbArgs m blk
-> Complete ChainDbArgs m blk
forall (m :: * -> *) blk.
(ConsensusProtocol (BlockProtocol blk), IOLike m) =>
ResourceRegistry m
-> TopLevelConfig blk
-> ExtLedgerState blk ValuesMK
-> ChunkInfo
-> (blk -> Bool)
-> (RelativeMountPoint -> SomeHasFS m)
-> (RelativeMountPoint -> SomeHasFS m)
-> Complete LedgerDbFlavorArgs m
-> Incomplete ChainDbArgs m blk
-> Complete ChainDbArgs m blk
ChainDB.completeChainDbArgs
            ResourceRegistry m
registry
            TopLevelConfig blk
cfg
            ExtLedgerState blk ValuesMK
initLedger
            (StorageConfig blk -> ChunkInfo
forall blk. NodeInitStorage blk => StorageConfig blk -> ChunkInfo
nodeImmutableDbChunkInfo (TopLevelConfig blk -> StorageConfig blk
forall blk. TopLevelConfig blk -> StorageConfig blk
configStorage TopLevelConfig blk
cfg))
            (StorageConfig blk -> blk -> Bool
forall blk. NodeInitStorage blk => StorageConfig blk -> blk -> Bool
nodeCheckIntegrity (TopLevelConfig blk -> StorageConfig blk
forall blk. TopLevelConfig blk -> StorageConfig blk
configStorage TopLevelConfig blk
cfg))
            RelativeMountPoint -> SomeHasFS m
fsImm
            RelativeMountPoint -> SomeHasFS m
fsVol
            Complete LedgerDbFlavorArgs m
flavorArgs
            Incomplete ChainDbArgs m blk
defArgs
   in (,Complete ChainDbArgs m blk
args) (ChainDB m blk -> (ChainDB m blk, Complete ChainDbArgs m blk))
-> m (ChainDB m blk)
-> m (ChainDB m blk, Complete ChainDbArgs m blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Complete ChainDbArgs m blk -> m (ChainDB m blk)
forall (m :: * -> *) blk.
(IOLike m, LedgerSupportsProtocol blk,
 BlockSupportsDiffusionPipelining blk, InspectLedger blk,
 HasHardForkHistory blk, ConvertRawHash blk,
 SerialiseDiskConstraints blk, LedgerSupportsLedgerDB blk) =>
Complete ChainDbArgs m blk -> m (ChainDB m blk)
ChainDB.openDB Complete ChainDbArgs m blk
args

mkNodeKernelArgs ::
  forall m addrNTN addrNTC blk.
  (RunNode blk, IOLike m) =>
  ResourceRegistry m ->
  Int ->
  StdGen ->
  StdGen ->
  TopLevelConfig blk ->
  Tracers m (ConnectionId addrNTN) (ConnectionId addrNTC) blk ->
  BlockchainTime m ->
  InFutureCheck.SomeHeaderInFutureCheck m blk ->
  (m GSM.GsmState -> HistoricityCheck m blk) ->
  ChainDB m blk ->
  NominalDiffTime ->
  Maybe (GSM.WrapDurationUntilTooOld m blk) ->
  GSM.MarkerFileView m ->
  STM m UseBootstrapPeers ->
  StrictSTM.StrictTVar m (PublicPeerSelectionState addrNTN) ->
  GenesisNodeKernelArgs m blk ->
  DiffusionPipeliningSupport ->
  m (NodeKernelArgs m addrNTN (ConnectionId addrNTC) blk)
mkNodeKernelArgs :: forall (m :: * -> *) addrNTN addrNTC blk.
(RunNode blk, IOLike m) =>
ResourceRegistry m
-> Int
-> StdGen
-> StdGen
-> TopLevelConfig blk
-> Tracers m (ConnectionId addrNTN) (ConnectionId addrNTC) blk
-> BlockchainTime m
-> SomeHeaderInFutureCheck m blk
-> (m GsmState -> HistoricityCheck m blk)
-> ChainDB m blk
-> NominalDiffTime
-> Maybe (WrapDurationUntilTooOld m blk)
-> MarkerFileView m
-> STM m UseBootstrapPeers
-> StrictTVar m (PublicPeerSelectionState addrNTN)
-> GenesisNodeKernelArgs m blk
-> DiffusionPipeliningSupport
-> m (NodeKernelArgs m addrNTN (ConnectionId addrNTC) blk)
mkNodeKernelArgs
  ResourceRegistry m
registry
  Int
bfcSalt
  StdGen
gsmAntiThunderingHerd
  StdGen
rng
  TopLevelConfig blk
cfg
  Tracers m (ConnectionId addrNTN) (ConnectionId addrNTC) blk
tracers
  BlockchainTime m
btime
  SomeHeaderInFutureCheck m blk
chainSyncFutureCheck
  m GsmState -> HistoricityCheck m blk
chainSyncHistoricityCheck
  ChainDB m blk
chainDB
  NominalDiffTime
maxCaughtUpAge
  Maybe (WrapDurationUntilTooOld m blk)
gsmDurationUntilTooOld
  MarkerFileView m
gsmMarkerFileView
  STM m UseBootstrapPeers
getUseBootstrapPeers
  StrictTVar m (PublicPeerSelectionState addrNTN)
publicPeerSelectionStateVar
  GenesisNodeKernelArgs m blk
genesisArgs
  DiffusionPipeliningSupport
getDiffusionPipeliningSupport =
    do
      let (StdGen
kaRng, StdGen
psRng) = StdGen -> (StdGen, StdGen)
forall g. RandomGen g => g -> (g, g)
split StdGen
rng
      NodeKernelArgs m addrNTN (ConnectionId addrNTC) blk
-> m (NodeKernelArgs m addrNTN (ConnectionId addrNTC) blk)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return
        NodeKernelArgs
          { Tracers m (ConnectionId addrNTN) (ConnectionId addrNTC) blk
tracers :: Tracers m (ConnectionId addrNTN) (ConnectionId addrNTC) blk
tracers :: Tracers m (ConnectionId addrNTN) (ConnectionId addrNTC) blk
tracers
          , ResourceRegistry m
registry :: ResourceRegistry m
registry :: ResourceRegistry m
registry
          , TopLevelConfig blk
cfg :: TopLevelConfig blk
cfg :: TopLevelConfig blk
cfg
          , BlockchainTime m
btime :: BlockchainTime m
btime :: BlockchainTime m
btime
          , ChainDB m blk
chainDB :: ChainDB m blk
chainDB :: ChainDB m blk
chainDB
          , initChainDB :: StorageConfig blk -> InitChainDB m blk -> m ()
initChainDB = StorageConfig blk -> InitChainDB m blk -> m ()
forall blk (m :: * -> *).
(NodeInitStorage blk, IOLike m) =>
StorageConfig blk -> InitChainDB m blk -> m ()
forall (m :: * -> *).
IOLike m =>
StorageConfig blk -> InitChainDB m blk -> m ()
nodeInitChainDB
          , SomeHeaderInFutureCheck m blk
chainSyncFutureCheck :: SomeHeaderInFutureCheck m blk
chainSyncFutureCheck :: SomeHeaderInFutureCheck m blk
chainSyncFutureCheck
          , m GsmState -> HistoricityCheck m blk
chainSyncHistoricityCheck :: m GsmState -> HistoricityCheck m blk
chainSyncHistoricityCheck :: m GsmState -> HistoricityCheck m blk
chainSyncHistoricityCheck
          , blockFetchSize :: Header blk -> SizeInBytes
blockFetchSize = Header blk -> SizeInBytes
forall blk.
SerialiseNodeToNodeConstraints blk =>
Header blk -> SizeInBytes
estimateBlockSize
          , mempoolCapacityOverride :: MempoolCapacityBytesOverride
mempoolCapacityOverride = MempoolCapacityBytesOverride
NoMempoolCapacityBytesOverride
          , miniProtocolParameters :: MiniProtocolParameters
miniProtocolParameters = MiniProtocolParameters
defaultMiniProtocolParameters
          , blockFetchConfiguration :: BlockFetchConfiguration
blockFetchConfiguration = Int -> BlockFetchConfiguration
Diffusion.defaultBlockFetchConfiguration Int
bfcSalt
          , gsmArgs :: GsmNodeKernelArgs m blk
gsmArgs =
              GsmNodeKernelArgs
                { StdGen
gsmAntiThunderingHerd :: StdGen
gsmAntiThunderingHerd :: StdGen
gsmAntiThunderingHerd
                , Maybe (WrapDurationUntilTooOld m blk)
gsmDurationUntilTooOld :: Maybe (WrapDurationUntilTooOld m blk)
gsmDurationUntilTooOld :: Maybe (WrapDurationUntilTooOld m blk)
gsmDurationUntilTooOld
                , MarkerFileView m
gsmMarkerFileView :: MarkerFileView m
gsmMarkerFileView :: MarkerFileView m
gsmMarkerFileView
                , gsmMinCaughtUpDuration :: NominalDiffTime
gsmMinCaughtUpDuration = NominalDiffTime
maxCaughtUpAge
                }
          , STM m UseBootstrapPeers
getUseBootstrapPeers :: STM m UseBootstrapPeers
getUseBootstrapPeers :: STM m UseBootstrapPeers
getUseBootstrapPeers
          , keepAliveRng :: StdGen
keepAliveRng = StdGen
kaRng
          , peerSharingRng :: StdGen
peerSharingRng = StdGen
psRng
          , StrictTVar m (PublicPeerSelectionState addrNTN)
publicPeerSelectionStateVar :: StrictTVar m (PublicPeerSelectionState addrNTN)
publicPeerSelectionStateVar :: StrictTVar m (PublicPeerSelectionState addrNTN)
publicPeerSelectionStateVar
          , GenesisNodeKernelArgs m blk
genesisArgs :: GenesisNodeKernelArgs m blk
genesisArgs :: GenesisNodeKernelArgs m blk
genesisArgs
          , DiffusionPipeliningSupport
getDiffusionPipeliningSupport :: DiffusionPipeliningSupport
getDiffusionPipeliningSupport :: DiffusionPipeliningSupport
getDiffusionPipeliningSupport
          }

-- | We allow the user running the node to customise the 'NodeKernelArgs'
-- through 'llrnCustomiseNodeKernelArgs', but there are some limits to some
-- values. This function makes sure we don't exceed those limits and that the
-- values are consistent.
nodeKernelArgsEnforceInvariants ::
  NodeKernelArgs m addrNTN (ConnectionId addrNTC) blk ->
  NodeKernelArgs m addrNTN (ConnectionId addrNTC) blk
nodeKernelArgsEnforceInvariants :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN (ConnectionId addrNTC) blk
-> NodeKernelArgs m addrNTN (ConnectionId addrNTC) blk
nodeKernelArgsEnforceInvariants NodeKernelArgs m addrNTN (ConnectionId addrNTC) blk
nodeKernelArgs =
  NodeKernelArgs m addrNTN (ConnectionId addrNTC) blk
nodeKernelArgs
    { miniProtocolParameters =
        miniProtocolParameters
          { -- If 'blockFetchPipeliningMax' exceeds the configured default, it
            -- would be a protocol violation.
            blockFetchPipeliningMax =
              min
                (blockFetchPipeliningMax miniProtocolParameters)
                (blockFetchPipeliningMax defaultMiniProtocolParameters)
          }
    , blockFetchConfiguration =
        blockFetchConfiguration
          { -- 'bfcMaxRequestsInflight' must be <= 'blockFetchPipeliningMax'
            bfcMaxRequestsInflight =
              min
                (bfcMaxRequestsInflight blockFetchConfiguration)
                (fromIntegral $ blockFetchPipeliningMax miniProtocolParameters)
          }
    }
 where
  NodeKernelArgs{StdGen
STM m UseBootstrapPeers
StrictTVar m (PublicPeerSelectionState addrNTN)
MempoolCapacityBytesOverride
DiffusionPipeliningSupport
TopLevelConfig blk
BlockchainTime m
SomeHeaderInFutureCheck m blk
ChainDB m blk
ResourceRegistry m
MiniProtocolParameters
BlockFetchConfiguration
GsmNodeKernelArgs m blk
GenesisNodeKernelArgs m blk
Tracers m (ConnectionId addrNTN) (ConnectionId addrNTC) blk
m GsmState -> HistoricityCheck m blk
Header blk -> SizeInBytes
StorageConfig blk -> InitChainDB m blk -> m ()
miniProtocolParameters :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> MiniProtocolParameters
tracers :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk
-> Tracers m (ConnectionId addrNTN) addrNTC blk
registry :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> ResourceRegistry m
cfg :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> TopLevelConfig blk
btime :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> BlockchainTime m
chainDB :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> ChainDB m blk
initChainDB :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk
-> StorageConfig blk -> InitChainDB m blk -> m ()
chainSyncFutureCheck :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk
-> SomeHeaderInFutureCheck m blk
chainSyncHistoricityCheck :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk
-> m GsmState -> HistoricityCheck m blk
blockFetchSize :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> Header blk -> SizeInBytes
mempoolCapacityOverride :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk
-> MempoolCapacityBytesOverride
blockFetchConfiguration :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> BlockFetchConfiguration
gsmArgs :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> GsmNodeKernelArgs m blk
getUseBootstrapPeers :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> STM m UseBootstrapPeers
keepAliveRng :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> StdGen
peerSharingRng :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> StdGen
publicPeerSelectionStateVar :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk
-> StrictTVar m (PublicPeerSelectionState addrNTN)
genesisArgs :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> GenesisNodeKernelArgs m blk
getDiffusionPipeliningSupport :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> DiffusionPipeliningSupport
miniProtocolParameters :: MiniProtocolParameters
blockFetchConfiguration :: BlockFetchConfiguration
tracers :: Tracers m (ConnectionId addrNTN) (ConnectionId addrNTC) blk
registry :: ResourceRegistry m
cfg :: TopLevelConfig blk
btime :: BlockchainTime m
chainDB :: ChainDB m blk
initChainDB :: StorageConfig blk -> InitChainDB m blk -> m ()
chainSyncFutureCheck :: SomeHeaderInFutureCheck m blk
chainSyncHistoricityCheck :: m GsmState -> HistoricityCheck m blk
blockFetchSize :: Header blk -> SizeInBytes
mempoolCapacityOverride :: MempoolCapacityBytesOverride
keepAliveRng :: StdGen
gsmArgs :: GsmNodeKernelArgs m blk
getUseBootstrapPeers :: STM m UseBootstrapPeers
peerSharingRng :: StdGen
publicPeerSelectionStateVar :: StrictTVar m (PublicPeerSelectionState addrNTN)
genesisArgs :: GenesisNodeKernelArgs m blk
getDiffusionPipeliningSupport :: DiffusionPipeliningSupport
..} = NodeKernelArgs m addrNTN (ConnectionId addrNTC) blk
nodeKernelArgs

{-------------------------------------------------------------------------------
  Arguments for use in the real node
-------------------------------------------------------------------------------}

-- | How to locate the ChainDB on disk
stdMkChainDbHasFS ::
  FilePath ->
  ChainDB.RelativeMountPoint ->
  SomeHasFS IO
stdMkChainDbHasFS :: FilePath -> RelativeMountPoint -> SomeHasFS IO
stdMkChainDbHasFS FilePath
rootPath (ChainDB.RelativeMountPoint FilePath
relPath) =
  HasFS IO HandleIO -> SomeHasFS IO
forall h (m :: * -> *). Eq h => HasFS m h -> SomeHasFS m
SomeHasFS (HasFS IO HandleIO -> SomeHasFS IO)
-> HasFS IO HandleIO -> SomeHasFS IO
forall a b. (a -> b) -> a -> b
$ MountPoint -> HasFS IO HandleIO
forall (m :: * -> *).
(MonadIO m, PrimState IO ~ PrimState m) =>
MountPoint -> HasFS m HandleIO
ioHasFS (MountPoint -> HasFS IO HandleIO)
-> MountPoint -> HasFS IO HandleIO
forall a b. (a -> b) -> a -> b
$ FilePath -> MountPoint
MountPoint (FilePath -> MountPoint) -> FilePath -> MountPoint
forall a b. (a -> b) -> a -> b
$ FilePath
rootPath FilePath -> FilePath -> FilePath
</> FilePath
relPath

stdBfcSaltIO :: IO Int
stdBfcSaltIO :: IO Int
stdBfcSaltIO = IO Int
forall a (m :: * -> *). (Random a, MonadIO m) => m a
randomIO

stdVersionDataNTN ::
  NetworkMagic ->
  DiffusionMode ->
  PeerSharing ->
  NodeToNodeVersionData
stdVersionDataNTN :: NetworkMagic
-> DiffusionMode -> PeerSharing -> NodeToNodeVersionData
stdVersionDataNTN NetworkMagic
networkMagic DiffusionMode
diffusionMode PeerSharing
peerSharing =
  NodeToNodeVersionData
    { NetworkMagic
networkMagic :: NetworkMagic
networkMagic :: NetworkMagic
networkMagic
    , DiffusionMode
diffusionMode :: DiffusionMode
diffusionMode :: DiffusionMode
diffusionMode
    , PeerSharing
peerSharing :: PeerSharing
peerSharing :: PeerSharing
peerSharing
    , query :: Bool
query = Bool
False
    }

stdVersionDataNTC :: NetworkMagic -> NodeToClientVersionData
stdVersionDataNTC :: NetworkMagic -> NodeToClientVersionData
stdVersionDataNTC NetworkMagic
networkMagic =
  NodeToClientVersionData
    { NetworkMagic
networkMagic :: NetworkMagic
networkMagic :: NetworkMagic
networkMagic
    , query :: Bool
query = Bool
False
    }

stdRunDataDiffusion ::
  Cardano.Diffusion.CardanoNodeArguments IO ->
  Cardano.Diffusion.CardanoConsensusArguments RemoteAddress IO ->
  Cardano.Diffusion.CardanoTracers IO ->
  Cardano.Diffusion.CardanoConfiguration IO ->
  Cardano.Diffusion.CardanoApplications IO a ->
  IO ()
stdRunDataDiffusion :: forall a.
CardanoNodeArguments IO
-> CardanoConsensusArguments RemoteAddress IO
-> CardanoTracers IO
-> CardanoConfiguration IO
-> CardanoApplications IO a
-> IO ()
stdRunDataDiffusion = \CardanoNodeArguments IO
nodeArgs CardanoConsensusArguments RemoteAddress IO
consensusArgs CardanoTracers IO
tracers CardanoConfiguration IO
config CardanoApplications IO a
apps ->
  IO Void -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Void -> IO ()) -> IO Void -> IO ()
forall a b. (a -> b) -> a -> b
$ CardanoNodeArguments IO
-> CardanoConsensusArguments RemoteAddress IO
-> CardanoTracers IO
-> CardanoConfiguration IO
-> CardanoApplications IO a
-> IO Void
forall a.
CardanoNodeArguments IO
-> CardanoConsensusArguments RemoteAddress IO
-> CardanoTracers IO
-> CardanoConfiguration IO
-> CardanoApplications IO a
-> IO Void
Cardano.Diffusion.run CardanoNodeArguments IO
nodeArgs CardanoConsensusArguments RemoteAddress IO
consensusArgs CardanoTracers IO
tracers CardanoConfiguration IO
config CardanoApplications IO a
apps

-- | Conveniently packaged 'LowLevelRunNodeArgs' arguments from a standard
-- non-testing invocation.
stdLowLevelRunNodeArgsIO ::
  forall blk.
  RunNode blk =>
  RunNodeArgs IO RemoteAddress LocalAddress blk ->
  StdRunNodeArgs IO blk ->
  IO
    ( LowLevelRunNodeArgs
        IO
        RemoteAddress
        LocalAddress
        blk
    )
stdLowLevelRunNodeArgsIO :: forall blk.
RunNode blk =>
RunNodeArgs IO RemoteAddress LocalAddress blk
-> StdRunNodeArgs IO blk
-> IO (LowLevelRunNodeArgs IO RemoteAddress LocalAddress blk)
stdLowLevelRunNodeArgsIO
  RunNodeArgs
    { ProtocolInfo blk
rnProtocolInfo :: forall (m :: * -> *) addrNTN addrNTC blk.
RunNodeArgs m addrNTN addrNTC blk -> ProtocolInfo blk
rnProtocolInfo :: ProtocolInfo blk
rnProtocolInfo
    , PeerSharing
rnPeerSharing :: forall (m :: * -> *) addrNTN addrNTC blk.
RunNodeArgs m addrNTN addrNTC blk -> PeerSharing
rnPeerSharing :: PeerSharing
rnPeerSharing
    , GenesisConfig
rnGenesisConfig :: forall (m :: * -> *) addrNTN addrNTC blk.
RunNodeArgs m addrNTN addrNTC blk -> GenesisConfig
rnGenesisConfig :: GenesisConfig
rnGenesisConfig
    }
  $(SafeWildCards.fields 'StdRunNodeArgs) = do
    llrnBfcSalt <- IO Int
stdBfcSaltIO
    llrnRng <- newStdGen
    pure
      LowLevelRunNodeArgs
        { llrnBfcSalt
        , llrnChainSyncIdleTimeout = srnChainSyncIdleTimeout
        , llrnGenesisConfig = rnGenesisConfig
        , llrnCustomiseHardForkBlockchainTimeArgs = id
        , llrnRng
        , llrnMkImmutableHasFS = stdMkChainDbHasFS $ immutableDbPath srnDatabasePath
        , llrnMkVolatileHasFS = stdMkChainDbHasFS $ nonImmutableDbPath srnDatabasePath
        , llrnChainDbArgsDefaults = updateChainDbDefaults ChainDB.defaultArgs
        , llrnCustomiseChainDbArgs = id
        , llrnCustomiseNodeKernelArgs
        , llrnRunDataDiffusion =
            \NodeKernel IO RemoteAddress (ConnectionId LocalAddress) blk
_kernel CardanoConsensusArguments RemoteAddress IO
cardanoConsensusDiffusionArgs Applications
  RemoteAddress
  NodeToNodeVersion
  NodeToNodeVersionData
  LocalAddress
  NodeToClientVersion
  NodeToClientVersionData
  IO
  NodeToNodeInitiatorResult
apps ->
              CardanoNodeArguments IO
-> CardanoConsensusArguments RemoteAddress IO
-> CardanoTracers IO
-> CardanoConfiguration IO
-> Applications
     RemoteAddress
     NodeToNodeVersion
     NodeToNodeVersionData
     LocalAddress
     NodeToClientVersion
     NodeToClientVersionData
     IO
     NodeToNodeInitiatorResult
-> IO ()
forall a.
CardanoNodeArguments IO
-> CardanoConsensusArguments RemoteAddress IO
-> CardanoTracers IO
-> CardanoConfiguration IO
-> CardanoApplications IO a
-> IO ()
stdRunDataDiffusion
                CardanoNodeArguments IO
srnDiffusionArguments
                CardanoConsensusArguments RemoteAddress IO
cardanoConsensusDiffusionArgs
                CardanoTracers IO
srnDiffusionTracers
                CardanoConfiguration IO
srnDiffusionConfiguration
                Applications
  RemoteAddress
  NodeToNodeVersion
  NodeToNodeVersionData
  LocalAddress
  NodeToClientVersion
  NodeToClientVersionData
  IO
  NodeToNodeInitiatorResult
apps
        , llrnVersionDataNTC =
            stdVersionDataNTC networkMagic
        , llrnVersionDataNTN =
            stdVersionDataNTN
              networkMagic
              (Diffusion.dcMode srnDiffusionConfiguration)
              rnPeerSharing
        , llrnNodeToNodeVersions =
            limitToLatestReleasedVersion
              fst
              (supportedNodeToNodeVersions (Proxy @blk))
        , llrnNodeToClientVersions =
            limitToLatestReleasedVersion
              snd
              (supportedNodeToClientVersions (Proxy @blk))
        , llrnWithCheckedDB =
            -- 'stdWithCheckedDB' uses the FS just to check for the clean file.
            -- We put that one in the immutable path.
            stdWithCheckedDB (Proxy @blk) srnTraceChainDB (immutableDbPath srnDatabasePath) networkMagic
        , llrnMaxCaughtUpAge = secondsToNominalDiffTime $ 20 * 60 -- 20 min
        , llrnMaxClockSkew =
            InFutureCheck.defaultClockSkew
        , llrnPublicPeerSelectionStateVar =
            Diffusion.dcPublicPeerSelectionVar srnDiffusionConfiguration
        , llrnLdbFlavorArgs =
            srnLdbFlavorArgs
        }
   where
    networkMagic :: NetworkMagic
    networkMagic :: NetworkMagic
networkMagic = BlockConfig blk -> NetworkMagic
forall blk.
ConfigSupportsNode blk =>
BlockConfig blk -> NetworkMagic
getNetworkMagic (BlockConfig blk -> NetworkMagic)
-> BlockConfig blk -> NetworkMagic
forall a b. (a -> b) -> a -> b
$ TopLevelConfig blk -> BlockConfig blk
forall blk. TopLevelConfig blk -> BlockConfig blk
configBlock (TopLevelConfig blk -> BlockConfig blk)
-> TopLevelConfig blk -> BlockConfig blk
forall a b. (a -> b) -> a -> b
$ ProtocolInfo blk -> TopLevelConfig blk
forall b. ProtocolInfo b -> TopLevelConfig b
pInfoConfig ProtocolInfo blk
rnProtocolInfo

    updateChainDbDefaults ::
      Incomplete ChainDbArgs IO blk ->
      Incomplete ChainDbArgs IO blk
    updateChainDbDefaults :: Incomplete ChainDbArgs IO blk -> Incomplete ChainDbArgs IO blk
updateChainDbDefaults =
      SnapshotPolicyArgs
-> Incomplete ChainDbArgs IO blk -> Incomplete ChainDbArgs IO blk
forall (f :: * -> *) (m :: * -> *) blk.
SnapshotPolicyArgs -> ChainDbArgs f m blk -> ChainDbArgs f m blk
ChainDB.updateSnapshotPolicyArgs SnapshotPolicyArgs
srnSnapshotPolicyArgs
        (Incomplete ChainDbArgs IO blk -> Incomplete ChainDbArgs IO blk)
-> (Incomplete ChainDbArgs IO blk -> Incomplete ChainDbArgs IO blk)
-> Incomplete ChainDbArgs IO blk
-> Incomplete ChainDbArgs IO blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QueryBatchSize
-> Incomplete ChainDbArgs IO blk -> Incomplete ChainDbArgs IO blk
forall (f :: * -> *) (m :: * -> *) blk.
QueryBatchSize -> ChainDbArgs f m blk -> ChainDbArgs f m blk
ChainDB.updateQueryBatchSize QueryBatchSize
srnQueryBatchSize
        (Incomplete ChainDbArgs IO blk -> Incomplete ChainDbArgs IO blk)
-> (Incomplete ChainDbArgs IO blk -> Incomplete ChainDbArgs IO blk)
-> Incomplete ChainDbArgs IO blk
-> Incomplete ChainDbArgs IO blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tracer IO (TraceEvent blk)
-> Incomplete ChainDbArgs IO blk -> Incomplete ChainDbArgs IO blk
forall (m :: * -> *) blk (f :: * -> *).
Tracer m (TraceEvent blk)
-> ChainDbArgs f m blk -> ChainDbArgs f m blk
ChainDB.updateTracer Tracer IO (TraceEvent blk)
srnTraceChainDB
        (Incomplete ChainDbArgs IO blk -> Incomplete ChainDbArgs IO blk)
-> (Incomplete ChainDbArgs IO blk -> Incomplete ChainDbArgs IO blk)
-> Incomplete ChainDbArgs IO blk
-> Incomplete ChainDbArgs IO blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ( if Bool -> Bool
not Bool
srnChainDbValidateOverride
              then Incomplete ChainDbArgs IO blk -> Incomplete ChainDbArgs IO blk
forall a. a -> a
id
              else Incomplete ChainDbArgs IO blk -> Incomplete ChainDbArgs IO blk
forall (f :: * -> *) (m :: * -> *) blk.
ChainDbArgs f m blk -> ChainDbArgs f m blk
ChainDB.ensureValidateAll
          )

    llrnCustomiseNodeKernelArgs ::
      NodeKernelArgs m addrNTN (ConnectionId addrNTC) blk ->
      NodeKernelArgs m addrNTN (ConnectionId addrNTC) blk
    llrnCustomiseNodeKernelArgs :: forall (m :: * -> *) addrNTN addrNTC.
NodeKernelArgs m addrNTN (ConnectionId addrNTC) blk
-> NodeKernelArgs m addrNTN (ConnectionId addrNTC) blk
llrnCustomiseNodeKernelArgs =
      (BlockFetchConfiguration -> BlockFetchConfiguration)
-> NodeKernelArgs m addrNTN (ConnectionId addrNTC) blk
-> NodeKernelArgs m addrNTN (ConnectionId addrNTC) blk
forall (m :: * -> *) addrNTN addrNTC blk.
(BlockFetchConfiguration -> BlockFetchConfiguration)
-> NodeKernelArgs m addrNTN (ConnectionId addrNTC) blk
-> NodeKernelArgs m addrNTN (ConnectionId addrNTC) blk
overBlockFetchConfiguration BlockFetchConfiguration -> BlockFetchConfiguration
modifyBlockFetchConfiguration
        (NodeKernelArgs m addrNTN (ConnectionId addrNTC) blk
 -> NodeKernelArgs m addrNTN (ConnectionId addrNTC) blk)
-> (NodeKernelArgs m addrNTN (ConnectionId addrNTC) blk
    -> NodeKernelArgs m addrNTN (ConnectionId addrNTC) blk)
-> NodeKernelArgs m addrNTN (ConnectionId addrNTC) blk
-> NodeKernelArgs m addrNTN (ConnectionId addrNTC) blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NodeKernelArgs m addrNTN (ConnectionId addrNTC) blk
-> NodeKernelArgs m addrNTN (ConnectionId addrNTC) blk
modifyMempoolCapacityOverride
     where
      modifyBlockFetchConfiguration :: BlockFetchConfiguration -> BlockFetchConfiguration
modifyBlockFetchConfiguration =
        (BlockFetchConfiguration -> BlockFetchConfiguration)
-> (Word -> BlockFetchConfiguration -> BlockFetchConfiguration)
-> Maybe Word
-> BlockFetchConfiguration
-> BlockFetchConfiguration
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
          BlockFetchConfiguration -> BlockFetchConfiguration
forall a. a -> a
id
          (\Word
mc BlockFetchConfiguration
bfc -> BlockFetchConfiguration
bfc{bfcMaxConcurrencyDeadline = mc})
          Maybe Word
srnBfcMaxConcurrencyDeadline
          (BlockFetchConfiguration -> BlockFetchConfiguration)
-> (BlockFetchConfiguration -> BlockFetchConfiguration)
-> BlockFetchConfiguration
-> BlockFetchConfiguration
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (BlockFetchConfiguration -> BlockFetchConfiguration)
-> (Word -> BlockFetchConfiguration -> BlockFetchConfiguration)
-> Maybe Word
-> BlockFetchConfiguration
-> BlockFetchConfiguration
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
            BlockFetchConfiguration -> BlockFetchConfiguration
forall a. a -> a
id
            (\Word
mc BlockFetchConfiguration
bfc -> BlockFetchConfiguration
bfc{bfcMaxConcurrencyBulkSync = mc})
            Maybe Word
srnBfcMaxConcurrencyBulkSync
      modifyMempoolCapacityOverride :: NodeKernelArgs m addrNTN (ConnectionId addrNTC) blk
-> NodeKernelArgs m addrNTN (ConnectionId addrNTC) blk
modifyMempoolCapacityOverride =
        (NodeKernelArgs m addrNTN (ConnectionId addrNTC) blk
 -> NodeKernelArgs m addrNTN (ConnectionId addrNTC) blk)
-> (MempoolCapacityBytesOverride
    -> NodeKernelArgs m addrNTN (ConnectionId addrNTC) blk
    -> NodeKernelArgs m addrNTN (ConnectionId addrNTC) blk)
-> Maybe MempoolCapacityBytesOverride
-> NodeKernelArgs m addrNTN (ConnectionId addrNTC) blk
-> NodeKernelArgs m addrNTN (ConnectionId addrNTC) blk
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
          NodeKernelArgs m addrNTN (ConnectionId addrNTC) blk
-> NodeKernelArgs m addrNTN (ConnectionId addrNTC) blk
forall a. a -> a
id
          (\MempoolCapacityBytesOverride
mc NodeKernelArgs m addrNTN (ConnectionId addrNTC) blk
nka -> NodeKernelArgs m addrNTN (ConnectionId addrNTC) blk
nka{mempoolCapacityOverride = mc})
          Maybe MempoolCapacityBytesOverride
srnMaybeMempoolCapacityOverride

    -- Limit the node version unless srnEnableInDevelopmentVersions is set
    limitToLatestReleasedVersion ::
      forall k v.
      Ord k =>
      ((Maybe NodeToNodeVersion, Maybe NodeToClientVersion) -> Maybe k) ->
      Map k v ->
      Map k v
    limitToLatestReleasedVersion :: forall k v.
Ord k =>
((Maybe NodeToNodeVersion, Maybe NodeToClientVersion) -> Maybe k)
-> Map k v -> Map k v
limitToLatestReleasedVersion (Maybe NodeToNodeVersion, Maybe NodeToClientVersion) -> Maybe k
prj =
      if Bool
srnEnableInDevelopmentVersions
        then Map k v -> Map k v
forall a. a -> a
id
        else case (Maybe NodeToNodeVersion, Maybe NodeToClientVersion) -> Maybe k
prj ((Maybe NodeToNodeVersion, Maybe NodeToClientVersion) -> Maybe k)
-> (Maybe NodeToNodeVersion, Maybe NodeToClientVersion) -> Maybe k
forall a b. (a -> b) -> a -> b
$ Proxy blk -> (Maybe NodeToNodeVersion, Maybe NodeToClientVersion)
forall blk.
SupportedNetworkProtocolVersion blk =>
Proxy blk -> (Maybe NodeToNodeVersion, Maybe NodeToClientVersion)
latestReleasedNodeVersion (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @blk) of
          Maybe k
Nothing -> Map k v -> Map k v
forall a. a -> a
id
          Just k
version -> (k -> Bool) -> Map k v -> Map k v
forall k a. (k -> Bool) -> Map k a -> Map k a
Map.takeWhileAntitone (k -> k -> Bool
forall a. Ord a => a -> a -> Bool
<= k
version)

{-------------------------------------------------------------------------------
  Miscellany
-------------------------------------------------------------------------------}

overBlockFetchConfiguration ::
  (BlockFetchConfiguration -> BlockFetchConfiguration) ->
  NodeKernelArgs m addrNTN (ConnectionId addrNTC) blk ->
  NodeKernelArgs m addrNTN (ConnectionId addrNTC) blk
overBlockFetchConfiguration :: forall (m :: * -> *) addrNTN addrNTC blk.
(BlockFetchConfiguration -> BlockFetchConfiguration)
-> NodeKernelArgs m addrNTN (ConnectionId addrNTC) blk
-> NodeKernelArgs m addrNTN (ConnectionId addrNTC) blk
overBlockFetchConfiguration BlockFetchConfiguration -> BlockFetchConfiguration
f NodeKernelArgs m addrNTN (ConnectionId addrNTC) blk
args =
  NodeKernelArgs m addrNTN (ConnectionId addrNTC) blk
args
    { blockFetchConfiguration = f blockFetchConfiguration
    }
 where
  NodeKernelArgs{BlockFetchConfiguration
blockFetchConfiguration :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> BlockFetchConfiguration
blockFetchConfiguration :: BlockFetchConfiguration
blockFetchConfiguration} = NodeKernelArgs m addrNTN (ConnectionId addrNTC) blk
args