{-# LANGUAGE MonadComprehensions #-}
{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE RecordWildCards     #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications    #-}
-- | Run the whole Node
--
-- Intended for qualified import.
--
module Ouroboros.Consensus.Node
  ( DiffusionTracers (..)
  , DiffusionArguments (..)
  , run
    -- * Exposed by 'run'
  , RunNodeArgs (..)
  , RunNode
  , Tracers
  , Tracers' (..)
  , ChainDB.TraceEvent (..)
  , ProtocolInfo (..)
  , ChainDbArgs (..)
  , NodeArgs (..)
  , NodeKernel (..)
  , MaxTxCapacityOverride (..)
  , MempoolCapacityBytesOverride (..)
  , IPSubscriptionTarget (..)
  , DnsSubscriptionTarget (..)
  , ConnectionId (..)
  , RemoteConnectionId
    -- * Internal helpers
  , openChainDB
  , mkChainDbArgs
  , mkNodeArgs
  , nodeArgsEnforceInvariants
  ) where

import           Codec.Serialise (DeserialiseFailure)
import           Control.Monad (when)
import           Control.Tracer (Tracer, contramap)
import           Data.ByteString.Lazy (ByteString)
import           Data.Functor.Identity (Identity)
import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import           System.Random (newStdGen, randomIO, randomRIO)

import           Ouroboros.Network.BlockFetch (BlockFetchConfiguration (..))
import           Ouroboros.Network.Diffusion
import           Ouroboros.Network.Magic
import           Ouroboros.Network.NodeToClient (LocalConnectionId,
                     NodeToClientVersionData (..))
import           Ouroboros.Network.NodeToNode (MiniProtocolParameters (..),
                     NodeToNodeVersionData (..), RemoteConnectionId,
                     combineVersions, defaultMiniProtocolParameters)
import           Ouroboros.Network.Protocol.Limits (shortWait)

import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.BlockchainTime hiding (getSystemStart)
import           Ouroboros.Consensus.Config
import           Ouroboros.Consensus.Config.SupportsNode
import           Ouroboros.Consensus.Fragment.InFuture (CheckInFuture,
                     ClockSkew)
import qualified Ouroboros.Consensus.Fragment.InFuture as InFuture
import           Ouroboros.Consensus.Ledger.Extended (ExtLedgerState (..))
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.ErrorPolicy
import           Ouroboros.Consensus.Node.InitStorage
import           Ouroboros.Consensus.Node.NetworkProtocolVersion
import           Ouroboros.Consensus.Node.ProtocolInfo
import           Ouroboros.Consensus.Node.Recovery
import           Ouroboros.Consensus.Node.Run
import           Ouroboros.Consensus.Node.Tracers
import           Ouroboros.Consensus.NodeKernel
import           Ouroboros.Consensus.Util.IOLike
import           Ouroboros.Consensus.Util.Orphans ()
import           Ouroboros.Consensus.Util.ResourceRegistry

import           Ouroboros.Consensus.Storage.ChainDB (ChainDB, ChainDbArgs)
import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB
import           Ouroboros.Consensus.Storage.FS.API.Types
import           Ouroboros.Consensus.Storage.FS.IO (ioHasFS)
import           Ouroboros.Consensus.Storage.ImmutableDB (ChunkInfo,
                     ValidationPolicy (..))
import           Ouroboros.Consensus.Storage.LedgerDB.DiskPolicy
                     (defaultDiskPolicy)
import           Ouroboros.Consensus.Storage.LedgerDB.InMemory
                     (ledgerDbDefaultParams)
import           Ouroboros.Consensus.Storage.VolatileDB
                     (BlockValidationPolicy (..), mkBlocksPerFile)

-- | Arguments required by 'runNode'
data RunNodeArgs blk = RunNodeArgs {
      -- | Consensus tracers
      RunNodeArgs blk
-> Tracers IO RemoteConnectionId LocalConnectionId blk
rnTraceConsensus :: Tracers IO RemoteConnectionId LocalConnectionId blk

      -- | Protocol tracers for node-to-node communication
    , RunNodeArgs blk
-> Tracers IO RemoteConnectionId blk DeserialiseFailure
rnTraceNTN :: NTN.Tracers IO RemoteConnectionId blk DeserialiseFailure

      -- | Protocol tracers for node-to-client communication
    , RunNodeArgs blk
-> Tracers IO LocalConnectionId blk DeserialiseFailure
rnTraceNTC :: NTC.Tracers IO LocalConnectionId blk DeserialiseFailure

      -- | ChainDB tracer
    , RunNodeArgs blk -> Tracer IO (TraceEvent blk)
rnTraceDB :: Tracer IO (ChainDB.TraceEvent blk)

      -- | Diffusion tracers
    , RunNodeArgs blk -> DiffusionTracers
rnTraceDiffusion :: DiffusionTracers

      -- | Diffusion arguments
    , RunNodeArgs blk -> DiffusionArguments
rnDiffusionArguments :: DiffusionArguments

      -- | Network magic
    , RunNodeArgs blk -> NetworkMagic
rnNetworkMagic :: NetworkMagic

      -- | Database path
    , RunNodeArgs blk -> FilePath
rnDatabasePath :: FilePath

      -- | Protocol info
    , RunNodeArgs blk -> ProtocolInfo IO blk
rnProtocolInfo :: ProtocolInfo IO blk

      -- | Customise the 'ChainDbArgs'
    , RunNodeArgs blk
-> ChainDbArgs Identity IO blk -> ChainDbArgs Identity IO blk
rnCustomiseChainDbArgs :: ChainDbArgs Identity IO blk -> ChainDbArgs Identity IO blk

      -- | Customise the 'NodeArgs'
    , RunNodeArgs blk
-> NodeArgs IO RemoteConnectionId LocalConnectionId blk
-> NodeArgs IO RemoteConnectionId LocalConnectionId blk
rnCustomiseNodeArgs :: NodeArgs IO RemoteConnectionId LocalConnectionId blk
                          -> NodeArgs IO RemoteConnectionId LocalConnectionId blk

      -- | node-to-node protocol versions to run.
    , RunNodeArgs blk
-> Map NodeToNodeVersion (BlockNodeToNodeVersion blk)
rnNodeToNodeVersions   :: Map NodeToNodeVersion (BlockNodeToNodeVersion blk)

      -- | node-to-client protocol versions to run.
    , RunNodeArgs blk
-> Map NodeToClientVersion (BlockNodeToClientVersion blk)
rnNodeToClientVersions :: Map NodeToClientVersion (BlockNodeToClientVersion blk)

      -- | Hook called after the initialisation of the 'NodeKernel'
      --
      -- Called on the 'NodeKernel' after creating it, but before the network
      -- layer is initialised.
    , RunNodeArgs blk
-> ResourceRegistry IO
-> NodeKernel IO RemoteConnectionId LocalConnectionId blk
-> IO ()
rnNodeKernelHook :: ResourceRegistry IO
                       -> NodeKernel IO RemoteConnectionId LocalConnectionId blk
                       -> IO ()

      -- | Maximum clock skew.
      --
      -- Use 'defaultClockSkew' when unsure.
    , RunNodeArgs blk -> ClockSkew
rnMaxClockSkew :: ClockSkew
    }

-- | 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.
run :: forall blk. RunNode blk => RunNodeArgs blk -> IO ()
run :: RunNodeArgs blk -> IO ()
run runargs :: RunNodeArgs blk
runargs@RunNodeArgs{FilePath
Map NodeToClientVersion (BlockNodeToClientVersion blk)
Map NodeToNodeVersion (BlockNodeToNodeVersion blk)
Tracer IO (TraceEvent blk)
NetworkMagic
ProtocolInfo IO blk
ClockSkew
Tracers IO RemoteConnectionId LocalConnectionId blk
Tracers IO RemoteConnectionId blk DeserialiseFailure
Tracers IO LocalConnectionId blk DeserialiseFailure
DiffusionArguments
DiffusionTracers
ResourceRegistry IO
-> NodeKernel IO RemoteConnectionId LocalConnectionId blk -> IO ()
ChainDbArgs Identity IO blk -> ChainDbArgs Identity IO blk
NodeArgs IO RemoteConnectionId LocalConnectionId blk
-> NodeArgs IO RemoteConnectionId LocalConnectionId blk
rnMaxClockSkew :: ClockSkew
rnNodeKernelHook :: ResourceRegistry IO
-> NodeKernel IO RemoteConnectionId LocalConnectionId blk -> IO ()
rnNodeToClientVersions :: Map NodeToClientVersion (BlockNodeToClientVersion blk)
rnNodeToNodeVersions :: Map NodeToNodeVersion (BlockNodeToNodeVersion blk)
rnCustomiseNodeArgs :: NodeArgs IO RemoteConnectionId LocalConnectionId blk
-> NodeArgs IO RemoteConnectionId LocalConnectionId blk
rnCustomiseChainDbArgs :: ChainDbArgs Identity IO blk -> ChainDbArgs Identity IO blk
rnProtocolInfo :: ProtocolInfo IO blk
rnDatabasePath :: FilePath
rnNetworkMagic :: NetworkMagic
rnDiffusionArguments :: DiffusionArguments
rnTraceDiffusion :: DiffusionTracers
rnTraceDB :: Tracer IO (TraceEvent blk)
rnTraceNTC :: Tracers IO LocalConnectionId blk DeserialiseFailure
rnTraceNTN :: Tracers IO RemoteConnectionId blk DeserialiseFailure
rnTraceConsensus :: Tracers IO RemoteConnectionId LocalConnectionId blk
rnMaxClockSkew :: forall blk. RunNodeArgs blk -> ClockSkew
rnNodeKernelHook :: forall blk.
RunNodeArgs blk
-> ResourceRegistry IO
-> NodeKernel IO RemoteConnectionId LocalConnectionId blk
-> IO ()
rnNodeToClientVersions :: forall blk.
RunNodeArgs blk
-> Map NodeToClientVersion (BlockNodeToClientVersion blk)
rnNodeToNodeVersions :: forall blk.
RunNodeArgs blk
-> Map NodeToNodeVersion (BlockNodeToNodeVersion blk)
rnCustomiseNodeArgs :: forall blk.
RunNodeArgs blk
-> NodeArgs IO RemoteConnectionId LocalConnectionId blk
-> NodeArgs IO RemoteConnectionId LocalConnectionId blk
rnCustomiseChainDbArgs :: forall blk.
RunNodeArgs blk
-> ChainDbArgs Identity IO blk -> ChainDbArgs Identity IO blk
rnProtocolInfo :: forall blk. RunNodeArgs blk -> ProtocolInfo IO blk
rnDatabasePath :: forall blk. RunNodeArgs blk -> FilePath
rnNetworkMagic :: forall blk. RunNodeArgs blk -> NetworkMagic
rnDiffusionArguments :: forall blk. RunNodeArgs blk -> DiffusionArguments
rnTraceDiffusion :: forall blk. RunNodeArgs blk -> DiffusionTracers
rnTraceDB :: forall blk. RunNodeArgs blk -> Tracer IO (TraceEvent blk)
rnTraceNTC :: forall blk.
RunNodeArgs blk
-> Tracers IO LocalConnectionId blk DeserialiseFailure
rnTraceNTN :: forall blk.
RunNodeArgs blk
-> Tracers IO RemoteConnectionId blk DeserialiseFailure
rnTraceConsensus :: forall blk.
RunNodeArgs blk
-> Tracers IO RemoteConnectionId LocalConnectionId blk
..} =

    RunNodeArgs blk -> (Bool -> IO ()) -> IO ()
forall blk a.
RunNode blk =>
RunNodeArgs blk -> (Bool -> IO a) -> IO a
withDBChecks RunNodeArgs blk
runargs ((Bool -> IO ()) -> IO ()) -> (Bool -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Bool
lastShutDownWasClean ->
    (ResourceRegistry IO -> IO ()) -> IO ()
forall (m :: * -> *) a.
(IOLike m, HasCallStack) =>
(ResourceRegistry m -> m a) -> m a
withRegistry ((ResourceRegistry IO -> IO ()) -> IO ())
-> (ResourceRegistry IO -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ResourceRegistry IO
registry -> 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 IO
          systemTime :: SystemTime IO
systemTime = SystemStart -> Tracer IO TraceBlockchainTimeEvent -> SystemTime IO
forall (m :: * -> *).
(MonadTime m, MonadDelay m) =>
SystemStart -> Tracer m TraceBlockchainTimeEvent -> SystemTime m
defaultSystemTime
                         SystemStart
systemStart
                         (Tracers IO RemoteConnectionId LocalConnectionId blk
-> Tracer IO TraceBlockchainTimeEvent
forall remotePeer localPeer blk (f :: * -> *).
Tracers' remotePeer localPeer blk f -> f TraceBlockchainTimeEvent
blockchainTimeTracer Tracers IO RemoteConnectionId LocalConnectionId blk
rnTraceConsensus)

          inFuture :: CheckInFuture IO blk
          inFuture :: CheckInFuture IO blk
inFuture = LedgerConfig blk
-> ClockSkew -> SystemTime IO -> CheckInFuture IO blk
forall (m :: * -> *) blk.
(Monad m, UpdateLedger blk, HasHardForkHistory blk) =>
LedgerConfig blk
-> ClockSkew -> SystemTime m -> CheckInFuture m blk
InFuture.reference
                       (TopLevelConfig blk -> LedgerConfig blk
forall blk. TopLevelConfig blk -> LedgerConfig blk
configLedger TopLevelConfig blk
cfg)
                       ClockSkew
rnMaxClockSkew
                       SystemTime IO
systemTime

      let customiseChainDbArgs' :: ChainDbArgs Identity IO blk -> ChainDbArgs Identity IO blk
customiseChainDbArgs' ChainDbArgs Identity IO blk
args
            | Bool
lastShutDownWasClean
            = ChainDbArgs Identity IO blk -> ChainDbArgs Identity IO blk
rnCustomiseChainDbArgs ChainDbArgs Identity IO blk
args
            | Bool
otherwise
              -- When the last shutdown was not clean, validate the complete
              -- ChainDB to detect and recover from any corruptions. This will
              -- override the default value /and/ the user-customised value of
              -- the 'ChainDB.cdbImmValidation' and the
              -- 'ChainDB.cdbVolValidation' fields.
            = (ChainDbArgs Identity IO blk -> ChainDbArgs Identity IO blk
rnCustomiseChainDbArgs ChainDbArgs Identity IO blk
args) {
                  cdbImmutableDbValidation :: ValidationPolicy
ChainDB.cdbImmutableDbValidation = ValidationPolicy
ValidateAllChunks
                , cdbVolatileDbValidation :: BlockValidationPolicy
ChainDB.cdbVolatileDbValidation  = BlockValidationPolicy
ValidateAll
                }

      (ResourceKey IO
_, ChainDB IO blk
chainDB) <- ResourceRegistry IO
-> (ResourceId -> IO (ChainDB IO blk))
-> (ChainDB IO blk -> IO ())
-> IO (ResourceKey IO, ChainDB IO blk)
forall (m :: * -> *) a.
(IOLike m, HasCallStack) =>
ResourceRegistry m
-> (ResourceId -> m a) -> (a -> m ()) -> m (ResourceKey m, a)
allocate ResourceRegistry IO
registry
        (\ResourceId
_ -> Tracer IO (TraceEvent blk)
-> ResourceRegistry IO
-> CheckInFuture IO blk
-> FilePath
-> TopLevelConfig blk
-> ExtLedgerState blk
-> (ChainDbArgs Identity IO blk -> ChainDbArgs Identity IO blk)
-> IO (ChainDB IO blk)
forall blk.
RunNode blk =>
Tracer IO (TraceEvent blk)
-> ResourceRegistry IO
-> CheckInFuture IO blk
-> FilePath
-> TopLevelConfig blk
-> ExtLedgerState blk
-> (ChainDbArgs Identity IO blk -> ChainDbArgs Identity IO blk)
-> IO (ChainDB IO blk)
openChainDB
          Tracer IO (TraceEvent blk)
rnTraceDB ResourceRegistry IO
registry CheckInFuture IO blk
inFuture FilePath
rnDatabasePath TopLevelConfig blk
cfg ExtLedgerState blk
initLedger
          ChainDbArgs Identity IO blk -> ChainDbArgs Identity IO blk
customiseChainDbArgs')
        ChainDB IO blk -> IO ()
forall (m :: * -> *) blk. ChainDB m blk -> m ()
ChainDB.closeDB

      BlockchainTime IO
btime      <- ResourceRegistry IO
-> Tracer IO (RelativeTime, PastHorizonException)
-> SystemTime IO
-> LedgerConfig blk
-> IO BackoffDelay
-> STM IO (LedgerState blk)
-> IO (BlockchainTime IO)
forall (m :: * -> *) blk.
(IOLike m, HasHardForkHistory blk, HasCallStack) =>
ResourceRegistry m
-> Tracer m (RelativeTime, PastHorizonException)
-> SystemTime m
-> LedgerConfig blk
-> m BackoffDelay
-> STM m (LedgerState blk)
-> m (BlockchainTime m)
hardForkBlockchainTime
                      ResourceRegistry IO
registry
                      (((RelativeTime, PastHorizonException) -> TraceBlockchainTimeEvent)
-> Tracer IO TraceBlockchainTimeEvent
-> Tracer IO (RelativeTime, PastHorizonException)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap
                         (\(RelativeTime
t, PastHorizonException
ex) ->
                              UTCTime -> PastHorizonException -> TraceBlockchainTimeEvent
TraceCurrentSlotUnknown
                                (SystemStart -> RelativeTime -> UTCTime
fromRelativeTime SystemStart
systemStart RelativeTime
t)
                                PastHorizonException
ex)
                         (Tracers IO RemoteConnectionId LocalConnectionId blk
-> Tracer IO TraceBlockchainTimeEvent
forall remotePeer localPeer blk (f :: * -> *).
Tracers' remotePeer localPeer blk f -> f TraceBlockchainTimeEvent
blockchainTimeTracer Tracers IO RemoteConnectionId LocalConnectionId blk
rnTraceConsensus))
                      SystemTime IO
systemTime
                      (TopLevelConfig blk -> LedgerConfig blk
forall blk. TopLevelConfig blk -> LedgerConfig blk
configLedger TopLevelConfig blk
cfg)
                      (BackoffDelay -> IO BackoffDelay
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BackoffDelay -> IO BackoffDelay)
-> BackoffDelay -> IO BackoffDelay
forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> BackoffDelay
BackoffDelay NominalDiffTime
60) -- see 'BackoffDelay'
                      (ExtLedgerState blk -> LedgerState blk
forall blk. ExtLedgerState blk -> LedgerState blk
ledgerState (ExtLedgerState blk -> LedgerState blk)
-> STM (ExtLedgerState blk) -> STM (LedgerState blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                         ChainDB IO blk -> STM IO (ExtLedgerState blk)
forall (m :: * -> *) blk.
ChainDB m blk -> STM m (ExtLedgerState blk)
ChainDB.getCurrentLedger ChainDB IO blk
chainDB)
      NodeArgs IO RemoteConnectionId LocalConnectionId blk
nodeArgs   <- NodeArgs IO RemoteConnectionId LocalConnectionId blk
-> NodeArgs IO RemoteConnectionId LocalConnectionId blk
forall (m :: * -> *) blk.
NodeArgs m RemoteConnectionId LocalConnectionId blk
-> NodeArgs m RemoteConnectionId LocalConnectionId blk
nodeArgsEnforceInvariants (NodeArgs IO RemoteConnectionId LocalConnectionId blk
 -> NodeArgs IO RemoteConnectionId LocalConnectionId blk)
-> (NodeArgs IO RemoteConnectionId LocalConnectionId blk
    -> NodeArgs IO RemoteConnectionId LocalConnectionId blk)
-> NodeArgs IO RemoteConnectionId LocalConnectionId blk
-> NodeArgs IO RemoteConnectionId LocalConnectionId blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NodeArgs IO RemoteConnectionId LocalConnectionId blk
-> NodeArgs IO RemoteConnectionId LocalConnectionId blk
rnCustomiseNodeArgs (NodeArgs IO RemoteConnectionId LocalConnectionId blk
 -> NodeArgs IO RemoteConnectionId LocalConnectionId blk)
-> IO (NodeArgs IO RemoteConnectionId LocalConnectionId blk)
-> IO (NodeArgs IO RemoteConnectionId LocalConnectionId blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                      ResourceRegistry IO
-> TopLevelConfig blk
-> [IO (BlockForging IO blk)]
-> Tracers IO RemoteConnectionId LocalConnectionId blk
-> BlockchainTime IO
-> ChainDB IO blk
-> IO (NodeArgs IO RemoteConnectionId LocalConnectionId blk)
forall blk.
RunNode blk =>
ResourceRegistry IO
-> TopLevelConfig blk
-> [IO (BlockForging IO blk)]
-> Tracers IO RemoteConnectionId LocalConnectionId blk
-> BlockchainTime IO
-> ChainDB IO blk
-> IO (NodeArgs IO RemoteConnectionId LocalConnectionId blk)
mkNodeArgs
                        ResourceRegistry IO
registry
                        TopLevelConfig blk
cfg
                        [IO (BlockForging IO blk)]
blockForging
                        Tracers IO RemoteConnectionId LocalConnectionId blk
rnTraceConsensus
                        BlockchainTime IO
btime
                        ChainDB IO blk
chainDB
      NodeKernel IO RemoteConnectionId LocalConnectionId blk
nodeKernel <- NodeArgs IO RemoteConnectionId LocalConnectionId blk
-> IO (NodeKernel IO RemoteConnectionId LocalConnectionId blk)
forall (m :: * -> *) remotePeer localPeer blk.
(IOLike m, RunNode blk, NoThunks remotePeer, Ord remotePeer,
 Hashable remotePeer) =>
NodeArgs m remotePeer localPeer blk
-> m (NodeKernel m remotePeer localPeer blk)
initNodeKernel NodeArgs IO RemoteConnectionId LocalConnectionId blk
nodeArgs
      ResourceRegistry IO
-> NodeKernel IO RemoteConnectionId LocalConnectionId blk -> IO ()
rnNodeKernelHook ResourceRegistry IO
registry NodeKernel IO RemoteConnectionId LocalConnectionId blk
nodeKernel

      let ntnApps :: BlockNodeToNodeVersion blk
-> Apps
     IO
     RemoteConnectionId
     ByteString
     ByteString
     ByteString
     ByteString
     ()
ntnApps = NodeArgs IO RemoteConnectionId LocalConnectionId blk
-> NodeKernel IO RemoteConnectionId LocalConnectionId blk
-> BlockNodeToNodeVersion blk
-> Apps
     IO
     RemoteConnectionId
     ByteString
     ByteString
     ByteString
     ByteString
     ()
mkNodeToNodeApps   NodeArgs IO RemoteConnectionId LocalConnectionId blk
nodeArgs NodeKernel IO RemoteConnectionId LocalConnectionId blk
nodeKernel
          ntcApps :: BlockNodeToClientVersion blk
-> Apps IO LocalConnectionId ByteString ByteString ByteString ()
ntcApps = NodeArgs IO RemoteConnectionId LocalConnectionId blk
-> NodeKernel IO RemoteConnectionId LocalConnectionId blk
-> BlockNodeToClientVersion blk
-> Apps IO LocalConnectionId ByteString ByteString ByteString ()
mkNodeToClientApps NodeArgs IO RemoteConnectionId LocalConnectionId blk
nodeArgs NodeKernel IO RemoteConnectionId LocalConnectionId blk
nodeKernel
          diffusionApplications :: DiffusionApplications
diffusionApplications = MiniProtocolParameters
-> (BlockNodeToNodeVersion blk
    -> Apps
         IO
         RemoteConnectionId
         ByteString
         ByteString
         ByteString
         ByteString
         ())
-> (BlockNodeToClientVersion blk
    -> Apps IO LocalConnectionId ByteString ByteString ByteString ())
-> DiffusionApplications
mkDiffusionApplications
                                    (NodeArgs IO RemoteConnectionId LocalConnectionId blk
-> MiniProtocolParameters
forall (m :: * -> *) remotePeer localPeer blk.
NodeArgs m remotePeer localPeer blk -> MiniProtocolParameters
miniProtocolParameters NodeArgs IO RemoteConnectionId LocalConnectionId blk
nodeArgs)
                                    BlockNodeToNodeVersion blk
-> Apps
     IO
     RemoteConnectionId
     ByteString
     ByteString
     ByteString
     ByteString
     ()
ntnApps
                                    BlockNodeToClientVersion blk
-> Apps IO LocalConnectionId ByteString ByteString ByteString ()
ntcApps

      DiffusionTracers
-> DiffusionArguments -> DiffusionApplications -> IO ()
runDataDiffusion DiffusionTracers
rnTraceDiffusion
                       DiffusionArguments
rnDiffusionArguments
                       DiffusionApplications
diffusionApplications
  where
    randomElem :: [a] -> IO a
    randomElem :: [a] -> IO a
randomElem [a]
xs = do
      Int
ix <- (Int, Int) -> IO Int
forall a. Random a => (a, a) -> IO a
randomRIO (Int
0, [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
      a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> IO a) -> a -> IO a
forall a b. (a -> b) -> a -> b
$ [a]
xs [a] -> Int -> a
forall a. [a] -> Int -> a
!! Int
ix

    nodeToNodeVersionData :: NodeToNodeVersionData
nodeToNodeVersionData = NodeToNodeVersionData :: NetworkMagic -> DiffusionMode -> NodeToNodeVersionData
NodeToNodeVersionData
      { networkMagic :: NetworkMagic
networkMagic  = NetworkMagic
rnNetworkMagic
      , diffusionMode :: DiffusionMode
diffusionMode = DiffusionArguments -> DiffusionMode
daDiffusionMode DiffusionArguments
rnDiffusionArguments
      }
    nodeToClientVersionData :: NodeToClientVersionData
nodeToClientVersionData = NodeToClientVersionData :: NetworkMagic -> NodeToClientVersionData
NodeToClientVersionData
      { networkMagic :: NetworkMagic
networkMagic = NetworkMagic
rnNetworkMagic }

    ProtocolInfo
      { pInfoConfig :: forall (m :: * -> *) b. ProtocolInfo m b -> TopLevelConfig b
pInfoConfig       = TopLevelConfig blk
cfg
      , pInfoInitLedger :: forall (m :: * -> *) b. ProtocolInfo m b -> ExtLedgerState b
pInfoInitLedger   = ExtLedgerState blk
initLedger
      , pInfoBlockForging :: forall (m :: * -> *) b. ProtocolInfo m b -> [m (BlockForging m b)]
pInfoBlockForging = [IO (BlockForging IO blk)]
blockForging
      } = ProtocolInfo IO blk
rnProtocolInfo

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

    mkNodeToNodeApps
      :: NodeArgs   IO RemoteConnectionId LocalConnectionId blk
      -> NodeKernel IO RemoteConnectionId LocalConnectionId blk
      -> BlockNodeToNodeVersion blk
      -> NTN.Apps IO RemoteConnectionId ByteString ByteString ByteString ByteString ()
    mkNodeToNodeApps :: NodeArgs IO RemoteConnectionId LocalConnectionId blk
-> NodeKernel IO RemoteConnectionId LocalConnectionId blk
-> BlockNodeToNodeVersion blk
-> Apps
     IO
     RemoteConnectionId
     ByteString
     ByteString
     ByteString
     ByteString
     ()
mkNodeToNodeApps NodeArgs IO RemoteConnectionId LocalConnectionId blk
nodeArgs NodeKernel IO RemoteConnectionId LocalConnectionId blk
nodeKernel BlockNodeToNodeVersion blk
version =
        NodeKernel IO RemoteConnectionId LocalConnectionId blk
-> Tracers IO RemoteConnectionId blk DeserialiseFailure
-> Codecs
     blk
     DeserialiseFailure
     IO
     ByteString
     ByteString
     ByteString
     ByteString
     ByteString
     ByteString
-> IO ChainSyncTimeout
-> Handlers IO RemoteConnectionId blk
-> Apps
     IO
     RemoteConnectionId
     ByteString
     ByteString
     ByteString
     ByteString
     ()
forall (m :: * -> *) remotePeer localPeer blk e bCS bBF bTX bKA.
(IOLike m, MonadTimer m, Ord remotePeer, Exception e,
 LedgerSupportsProtocol blk, ShowProxy blk, ShowProxy (Header blk),
 ShowProxy (TxId (GenTx blk)), ShowProxy (GenTx blk)) =>
NodeKernel m remotePeer localPeer blk
-> Tracers m remotePeer blk e
-> Codecs blk e m bCS bCS bBF bBF bTX bKA
-> m ChainSyncTimeout
-> Handlers m remotePeer blk
-> Apps m remotePeer bCS bBF bTX bKA ()
NTN.mkApps
          NodeKernel IO RemoteConnectionId LocalConnectionId blk
nodeKernel
          Tracers IO RemoteConnectionId blk DeserialiseFailure
rnTraceNTN
          (CodecConfig blk
-> BlockNodeToNodeVersion blk
-> Codecs
     blk
     DeserialiseFailure
     IO
     ByteString
     ByteString
     ByteString
     ByteString
     ByteString
     ByteString
forall (m :: * -> *) blk.
(IOLike m, SerialiseNodeToNodeConstraints blk) =>
CodecConfig blk
-> BlockNodeToNodeVersion blk
-> Codecs
     blk
     DeserialiseFailure
     m
     ByteString
     ByteString
     ByteString
     ByteString
     ByteString
     ByteString
NTN.defaultCodecs CodecConfig blk
codecConfig BlockNodeToNodeVersion blk
version)
          IO ChainSyncTimeout
chainSyncTimeout
          (NodeArgs IO RemoteConnectionId LocalConnectionId blk
-> NodeKernel IO RemoteConnectionId LocalConnectionId blk
-> Handlers IO RemoteConnectionId blk
forall (m :: * -> *) blk remotePeer localPeer.
(IOLike m, MonadTimer m, LedgerSupportsMempool blk,
 HasTxId (GenTx blk), LedgerSupportsProtocol blk, Ord remotePeer) =>
NodeArgs m remotePeer localPeer blk
-> NodeKernel m remotePeer localPeer blk
-> Handlers m remotePeer blk
NTN.mkHandlers NodeArgs IO RemoteConnectionId LocalConnectionId blk
nodeArgs NodeKernel IO RemoteConnectionId LocalConnectionId blk
nodeKernel)
      where
        chainSyncTimeout :: IO NTN.ChainSyncTimeout
        chainSyncTimeout :: IO ChainSyncTimeout
chainSyncTimeout = do
            -- These values approximately correspond to false positive
            -- thresholds for streaks of empty slots with 99% probability,
            -- 99.9% probability up to 99.999% probability.
            -- t = T_s [log (1-Y) / log (1-f)]
            -- Y = [0.99, 0.999...]
            -- T_s = slot length of 1s.
            -- f = 0.05
            -- The timeout is randomly picked per bearer to avoid all bearers
            -- going down at the same time in case of a long streak of empty
            -- slots. TODO: workaround until peer selection governor.
            Maybe DiffTime
mustReplyTimeout <- DiffTime -> Maybe DiffTime
forall a. a -> Maybe a
Just (DiffTime -> Maybe DiffTime) -> IO DiffTime -> IO (Maybe DiffTime)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [DiffTime] -> IO DiffTime
forall a. [a] -> IO a
randomElem [DiffTime
90, DiffTime
135, DiffTime
180, DiffTime
224, DiffTime
269]
            ChainSyncTimeout -> IO ChainSyncTimeout
forall (m :: * -> *) a. Monad m => a -> m a
return ChainSyncTimeout :: Maybe DiffTime -> Maybe DiffTime -> ChainSyncTimeout
NTN.ChainSyncTimeout
              { canAwaitTimeout :: Maybe DiffTime
canAwaitTimeout  = Maybe DiffTime
shortWait
              , Maybe DiffTime
mustReplyTimeout :: Maybe DiffTime
mustReplyTimeout :: Maybe DiffTime
mustReplyTimeout
              }

    mkNodeToClientApps
      :: NodeArgs   IO RemoteConnectionId LocalConnectionId blk
      -> NodeKernel IO RemoteConnectionId LocalConnectionId blk
      -> BlockNodeToClientVersion blk
      -> NTC.Apps IO LocalConnectionId ByteString ByteString ByteString ()
    mkNodeToClientApps :: NodeArgs IO RemoteConnectionId LocalConnectionId blk
-> NodeKernel IO RemoteConnectionId LocalConnectionId blk
-> BlockNodeToClientVersion blk
-> Apps IO LocalConnectionId ByteString ByteString ByteString ()
mkNodeToClientApps NodeArgs IO RemoteConnectionId LocalConnectionId blk
nodeArgs NodeKernel IO RemoteConnectionId LocalConnectionId blk
nodeKernel BlockNodeToClientVersion blk
version =
        Tracers IO LocalConnectionId blk DeserialiseFailure
-> Codecs
     blk DeserialiseFailure IO ByteString ByteString ByteString
-> Handlers IO LocalConnectionId blk
-> Apps IO LocalConnectionId ByteString ByteString ByteString ()
forall (m :: * -> *) peer blk e bCS bTX bSQ.
(IOLike m, Exception e, ShowProxy blk, ShowProxy (ApplyTxErr blk),
 ShowProxy (Query blk), ShowProxy (GenTx blk),
 ShowQuery (Query blk)) =>
Tracers m peer blk e
-> Codecs blk e m bCS bTX bSQ
-> Handlers m peer blk
-> Apps m peer bCS bTX bSQ ()
NTC.mkApps
          Tracers IO LocalConnectionId blk DeserialiseFailure
rnTraceNTC
          (CodecConfig blk
-> BlockNodeToClientVersion blk
-> Codecs
     blk DeserialiseFailure IO ByteString ByteString ByteString
forall (m :: * -> *) blk.
(MonadST m, SerialiseNodeToClientConstraints blk,
 ShowQuery (Query blk)) =>
CodecConfig blk
-> BlockNodeToClientVersion blk -> DefaultCodecs blk m
NTC.defaultCodecs CodecConfig blk
codecConfig BlockNodeToClientVersion blk
version)
          (NodeArgs IO RemoteConnectionId LocalConnectionId blk
-> NodeKernel IO RemoteConnectionId LocalConnectionId blk
-> Handlers IO LocalConnectionId blk
forall (m :: * -> *) blk remotePeer localPeer.
(IOLike m, LedgerSupportsMempool blk, QueryLedger blk) =>
NodeArgs m remotePeer localPeer blk
-> NodeKernel m remotePeer localPeer blk
-> Handlers m localPeer blk
NTC.mkHandlers NodeArgs IO RemoteConnectionId LocalConnectionId blk
nodeArgs NodeKernel IO RemoteConnectionId LocalConnectionId blk
nodeKernel)

    mkDiffusionApplications
      :: MiniProtocolParameters
      -> (   BlockNodeToNodeVersion blk
          -> NTN.Apps IO RemoteConnectionId ByteString ByteString ByteString ByteString ()
         )
      -> (   BlockNodeToClientVersion blk
          -> NTC.Apps IO LocalConnectionId      ByteString ByteString ByteString ()
         )
      -> DiffusionApplications
    mkDiffusionApplications :: MiniProtocolParameters
-> (BlockNodeToNodeVersion blk
    -> Apps
         IO
         RemoteConnectionId
         ByteString
         ByteString
         ByteString
         ByteString
         ())
-> (BlockNodeToClientVersion blk
    -> Apps IO LocalConnectionId ByteString ByteString ByteString ())
-> DiffusionApplications
mkDiffusionApplications MiniProtocolParameters
miniProtocolParams BlockNodeToNodeVersion blk
-> Apps
     IO
     RemoteConnectionId
     ByteString
     ByteString
     ByteString
     ByteString
     ()
ntnApps BlockNodeToClientVersion blk
-> Apps IO LocalConnectionId ByteString ByteString ByteString ()
ntcApps =
      DiffusionApplications :: Versions
  NodeToNodeVersion
  NodeToNodeVersionData
  (OuroborosApplication
     'ResponderMode SockAddr ByteString IO Void ())
-> Versions
     NodeToNodeVersion
     NodeToNodeVersionData
     (OuroborosApplication
        'InitiatorMode SockAddr ByteString IO () Void)
-> Versions
     NodeToClientVersion
     NodeToClientVersionData
     (OuroborosApplication
        'ResponderMode LocalAddress ByteString IO Void ())
-> ErrorPolicies
-> DiffusionApplications
DiffusionApplications {
          daResponderApplication :: Versions
  NodeToNodeVersion
  NodeToNodeVersionData
  (OuroborosApplication
     'ResponderMode SockAddr ByteString IO Void ())
daResponderApplication = [Versions
   NodeToNodeVersion
   NodeToNodeVersionData
   (OuroborosApplication
      'ResponderMode SockAddr ByteString IO Void ())]
-> Versions
     NodeToNodeVersion
     NodeToNodeVersionData
     (OuroborosApplication
        'ResponderMode SockAddr ByteString IO Void ())
forall vNum (f :: * -> *) extra r.
(Ord vNum, Foldable f, HasCallStack) =>
f (Versions vNum extra r) -> Versions vNum extra r
combineVersions [
              NodeToNodeVersion
-> NodeToNodeVersionData
-> OuroborosApplication
     'ResponderMode SockAddr ByteString IO Void ()
-> Versions
     NodeToNodeVersion
     NodeToNodeVersionData
     (OuroborosApplication
        'ResponderMode SockAddr ByteString IO Void ())
forall vNum vData r. vNum -> vData -> r -> Versions vNum vData r
simpleSingletonVersions
                NodeToNodeVersion
version
                NodeToNodeVersionData
nodeToNodeVersionData
                (MiniProtocolParameters
-> NodeToNodeVersion
-> Apps
     IO
     RemoteConnectionId
     ByteString
     ByteString
     ByteString
     ByteString
     ()
-> OuroborosApplication
     'ResponderMode SockAddr ByteString IO Void ()
forall (m :: * -> *) peer b a.
MiniProtocolParameters
-> NodeToNodeVersion
-> Apps m (ConnectionId peer) b b b b a
-> OuroborosApplication 'ResponderMode peer b m Void a
NTN.responder MiniProtocolParameters
miniProtocolParams NodeToNodeVersion
version (Apps
   IO
   RemoteConnectionId
   ByteString
   ByteString
   ByteString
   ByteString
   ()
 -> OuroborosApplication
      'ResponderMode SockAddr ByteString IO Void ())
-> Apps
     IO
     RemoteConnectionId
     ByteString
     ByteString
     ByteString
     ByteString
     ()
-> OuroborosApplication
     'ResponderMode SockAddr ByteString IO Void ()
forall a b. (a -> b) -> a -> b
$ BlockNodeToNodeVersion blk
-> Apps
     IO
     RemoteConnectionId
     ByteString
     ByteString
     ByteString
     ByteString
     ()
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)
rnNodeToNodeVersions
            ]
        , daInitiatorApplication :: Versions
  NodeToNodeVersion
  NodeToNodeVersionData
  (OuroborosApplication
     'InitiatorMode SockAddr ByteString IO () Void)
daInitiatorApplication = [Versions
   NodeToNodeVersion
   NodeToNodeVersionData
   (OuroborosApplication
      'InitiatorMode SockAddr ByteString IO () Void)]
-> Versions
     NodeToNodeVersion
     NodeToNodeVersionData
     (OuroborosApplication
        'InitiatorMode SockAddr ByteString IO () Void)
forall vNum (f :: * -> *) extra r.
(Ord vNum, Foldable f, HasCallStack) =>
f (Versions vNum extra r) -> Versions vNum extra r
combineVersions [
              NodeToNodeVersion
-> NodeToNodeVersionData
-> OuroborosApplication
     'InitiatorMode SockAddr ByteString IO () Void
-> Versions
     NodeToNodeVersion
     NodeToNodeVersionData
     (OuroborosApplication
        'InitiatorMode SockAddr ByteString IO () Void)
forall vNum vData r. vNum -> vData -> r -> Versions vNum vData r
simpleSingletonVersions
                NodeToNodeVersion
version
                NodeToNodeVersionData
nodeToNodeVersionData
                (MiniProtocolParameters
-> NodeToNodeVersion
-> Apps
     IO
     RemoteConnectionId
     ByteString
     ByteString
     ByteString
     ByteString
     ()
-> OuroborosApplication
     'InitiatorMode SockAddr ByteString IO () Void
forall (m :: * -> *) peer b a.
MiniProtocolParameters
-> NodeToNodeVersion
-> Apps m (ConnectionId peer) b b b b a
-> OuroborosApplication 'InitiatorMode peer b m a Void
NTN.initiator MiniProtocolParameters
miniProtocolParams NodeToNodeVersion
version (Apps
   IO
   RemoteConnectionId
   ByteString
   ByteString
   ByteString
   ByteString
   ()
 -> OuroborosApplication
      'InitiatorMode SockAddr ByteString IO () Void)
-> Apps
     IO
     RemoteConnectionId
     ByteString
     ByteString
     ByteString
     ByteString
     ()
-> OuroborosApplication
     'InitiatorMode SockAddr ByteString IO () Void
forall a b. (a -> b) -> a -> b
$ BlockNodeToNodeVersion blk
-> Apps
     IO
     RemoteConnectionId
     ByteString
     ByteString
     ByteString
     ByteString
     ()
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)
rnNodeToNodeVersions
            ]
        , daLocalResponderApplication :: Versions
  NodeToClientVersion
  NodeToClientVersionData
  (OuroborosApplication
     'ResponderMode LocalAddress ByteString IO Void ())
daLocalResponderApplication = [Versions
   NodeToClientVersion
   NodeToClientVersionData
   (OuroborosApplication
      'ResponderMode LocalAddress ByteString IO Void ())]
-> Versions
     NodeToClientVersion
     NodeToClientVersionData
     (OuroborosApplication
        'ResponderMode LocalAddress ByteString IO Void ())
forall vNum (f :: * -> *) extra r.
(Ord vNum, Foldable f, HasCallStack) =>
f (Versions vNum extra r) -> Versions vNum extra r
combineVersions [
              NodeToClientVersion
-> NodeToClientVersionData
-> OuroborosApplication
     'ResponderMode LocalAddress ByteString IO Void ()
-> Versions
     NodeToClientVersion
     NodeToClientVersionData
     (OuroborosApplication
        'ResponderMode LocalAddress ByteString IO Void ())
forall vNum vData r. vNum -> vData -> r -> Versions vNum vData r
simpleSingletonVersions
                NodeToClientVersion
version
                NodeToClientVersionData
nodeToClientVersionData
                (NodeToClientVersion
-> Apps IO LocalConnectionId ByteString ByteString ByteString ()
-> OuroborosApplication
     'ResponderMode LocalAddress ByteString IO Void ()
forall (m :: * -> *) peer b a.
NodeToClientVersion
-> Apps m (ConnectionId peer) b b b a
-> OuroborosApplication 'ResponderMode peer b m Void a
NTC.responder NodeToClientVersion
version (Apps IO LocalConnectionId ByteString ByteString ByteString ()
 -> OuroborosApplication
      'ResponderMode LocalAddress ByteString IO Void ())
-> Apps IO LocalConnectionId ByteString ByteString ByteString ()
-> OuroborosApplication
     'ResponderMode LocalAddress ByteString IO Void ()
forall a b. (a -> b) -> a -> b
$ BlockNodeToClientVersion blk
-> Apps IO LocalConnectionId ByteString ByteString ByteString ()
ntcApps BlockNodeToClientVersion blk
blockVersion)
            | (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)
rnNodeToClientVersions
            ]
        , daErrorPolicies :: ErrorPolicies
daErrorPolicies = ErrorPolicies
consensusErrorPolicy
        }

-- | Check the DB marker, lock the DB and look for the clean shutdown marker.
--
-- Run the body action with the DB locked, and if the last shutdown was clean.
--
withDBChecks :: forall blk a.
                RunNode blk
             => RunNodeArgs blk
             -> (Bool -> IO a)  -- ^ Body action with last shutdown was clean.
             -> IO a
withDBChecks :: RunNodeArgs blk -> (Bool -> IO a) -> IO a
withDBChecks RunNodeArgs{FilePath
Map NodeToClientVersion (BlockNodeToClientVersion blk)
Map NodeToNodeVersion (BlockNodeToNodeVersion blk)
Tracer IO (TraceEvent blk)
NetworkMagic
ProtocolInfo IO blk
ClockSkew
Tracers IO RemoteConnectionId LocalConnectionId blk
Tracers IO RemoteConnectionId blk DeserialiseFailure
Tracers IO LocalConnectionId blk DeserialiseFailure
DiffusionArguments
DiffusionTracers
ResourceRegistry IO
-> NodeKernel IO RemoteConnectionId LocalConnectionId blk -> IO ()
ChainDbArgs Identity IO blk -> ChainDbArgs Identity IO blk
NodeArgs IO RemoteConnectionId LocalConnectionId blk
-> NodeArgs IO RemoteConnectionId LocalConnectionId blk
rnMaxClockSkew :: ClockSkew
rnNodeKernelHook :: ResourceRegistry IO
-> NodeKernel IO RemoteConnectionId LocalConnectionId blk -> IO ()
rnNodeToClientVersions :: Map NodeToClientVersion (BlockNodeToClientVersion blk)
rnNodeToNodeVersions :: Map NodeToNodeVersion (BlockNodeToNodeVersion blk)
rnCustomiseNodeArgs :: NodeArgs IO RemoteConnectionId LocalConnectionId blk
-> NodeArgs IO RemoteConnectionId LocalConnectionId blk
rnCustomiseChainDbArgs :: ChainDbArgs Identity IO blk -> ChainDbArgs Identity IO blk
rnProtocolInfo :: ProtocolInfo IO blk
rnDatabasePath :: FilePath
rnNetworkMagic :: NetworkMagic
rnDiffusionArguments :: DiffusionArguments
rnTraceDiffusion :: DiffusionTracers
rnTraceDB :: Tracer IO (TraceEvent blk)
rnTraceNTC :: Tracers IO LocalConnectionId blk DeserialiseFailure
rnTraceNTN :: Tracers IO RemoteConnectionId blk DeserialiseFailure
rnTraceConsensus :: Tracers IO RemoteConnectionId LocalConnectionId blk
rnMaxClockSkew :: forall blk. RunNodeArgs blk -> ClockSkew
rnNodeKernelHook :: forall blk.
RunNodeArgs blk
-> ResourceRegistry IO
-> NodeKernel IO RemoteConnectionId LocalConnectionId blk
-> IO ()
rnNodeToClientVersions :: forall blk.
RunNodeArgs blk
-> Map NodeToClientVersion (BlockNodeToClientVersion blk)
rnNodeToNodeVersions :: forall blk.
RunNodeArgs blk
-> Map NodeToNodeVersion (BlockNodeToNodeVersion blk)
rnCustomiseNodeArgs :: forall blk.
RunNodeArgs blk
-> NodeArgs IO RemoteConnectionId LocalConnectionId blk
-> NodeArgs IO RemoteConnectionId LocalConnectionId blk
rnCustomiseChainDbArgs :: forall blk.
RunNodeArgs blk
-> ChainDbArgs Identity IO blk -> ChainDbArgs Identity IO blk
rnProtocolInfo :: forall blk. RunNodeArgs blk -> ProtocolInfo IO blk
rnDatabasePath :: forall blk. RunNodeArgs blk -> FilePath
rnNetworkMagic :: forall blk. RunNodeArgs blk -> NetworkMagic
rnDiffusionArguments :: forall blk. RunNodeArgs blk -> DiffusionArguments
rnTraceDiffusion :: forall blk. RunNodeArgs blk -> DiffusionTracers
rnTraceDB :: forall blk. RunNodeArgs blk -> Tracer IO (TraceEvent blk)
rnTraceNTC :: forall blk.
RunNodeArgs blk
-> Tracers IO LocalConnectionId blk DeserialiseFailure
rnTraceNTN :: forall blk.
RunNodeArgs blk
-> Tracers IO RemoteConnectionId blk DeserialiseFailure
rnTraceConsensus :: forall blk.
RunNodeArgs blk
-> Tracers IO RemoteConnectionId LocalConnectionId blk
..} Bool -> 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 (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO () -> IO ()
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
      (BlockConfig blk -> NetworkMagic
forall blk.
ConfigSupportsNode blk =>
BlockConfig blk -> NetworkMagic
getNetworkMagic (TopLevelConfig blk -> BlockConfig blk
forall blk. TopLevelConfig blk -> BlockConfig blk
configBlock TopLevelConfig blk
pInfoConfig))

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

      -- When we shut down cleanly, we create a marker file so that the next
      -- time we start, we know we don't have to validate the contents of the
      -- whole ChainDB. When we shut down with an exception indicating
      -- corruption or something going wrong with the file system, we don't
      -- create this marker file so that the next time we start, we do a full
      -- validation.
      Bool
lastShutDownWasClean <- HasFS IO HandleIO -> IO Bool
forall (m :: * -> *) h. HasFS m h -> m Bool
hasCleanShutdownMarker HasFS IO HandleIO
hasFS
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
lastShutDownWasClean (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ HasFS IO HandleIO -> IO ()
forall (m :: * -> *) h. HasFS m h -> m ()
removeCleanShutdownMarker HasFS IO HandleIO
hasFS

      -- On a clean shutdown, create a marker in the database folder so that
      -- next time we start up, we know we don't have to validate the whole
      -- database.
      HasFS IO HandleIO -> IO a -> IO a
forall (m :: * -> *) h a. IOLike m => HasFS m h -> m a -> m a
createMarkerOnCleanShutdown HasFS IO HandleIO
hasFS (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$
        Bool -> IO a
body Bool
lastShutDownWasClean
  where
    mountPoint :: MountPoint
mountPoint                   = FilePath -> MountPoint
MountPoint FilePath
rnDatabasePath
    hasFS :: HasFS IO HandleIO
hasFS                        = MountPoint -> HasFS IO HandleIO
ioHasFS MountPoint
mountPoint
    ProtocolInfo { TopLevelConfig blk
pInfoConfig :: TopLevelConfig blk
pInfoConfig :: forall (m :: * -> *) b. ProtocolInfo m b -> TopLevelConfig b
pInfoConfig } = ProtocolInfo IO blk
rnProtocolInfo

openChainDB
  :: forall blk. RunNode blk
  => Tracer IO (ChainDB.TraceEvent blk)
  -> ResourceRegistry IO
  -> CheckInFuture IO blk
  -> FilePath
     -- ^ Database path
  -> TopLevelConfig blk
  -> ExtLedgerState blk
     -- ^ Initial ledger
  -> (ChainDbArgs Identity IO blk -> ChainDbArgs Identity IO blk)
      -- ^ Customise the 'ChainDbArgs'
  -> IO (ChainDB IO blk)
openChainDB :: Tracer IO (TraceEvent blk)
-> ResourceRegistry IO
-> CheckInFuture IO blk
-> FilePath
-> TopLevelConfig blk
-> ExtLedgerState blk
-> (ChainDbArgs Identity IO blk -> ChainDbArgs Identity IO blk)
-> IO (ChainDB IO blk)
openChainDB Tracer IO (TraceEvent blk)
tracer ResourceRegistry IO
registry CheckInFuture IO blk
inFuture FilePath
dbPath TopLevelConfig blk
cfg ExtLedgerState blk
initLedger ChainDbArgs Identity IO blk -> ChainDbArgs Identity IO blk
customiseArgs =
    ChainDbArgs Identity IO blk -> IO (ChainDB IO blk)
forall (m :: * -> *) blk.
(IOLike m, LedgerSupportsProtocol blk, InspectLedger blk,
 HasHardForkHistory blk, ConvertRawHash blk,
 SerialiseDiskConstraints blk) =>
ChainDbArgs Identity m blk -> m (ChainDB m blk)
ChainDB.openDB ChainDbArgs Identity IO blk
args
  where
    args :: ChainDbArgs Identity IO blk
    args :: ChainDbArgs Identity IO blk
args = ChainDbArgs Identity IO blk -> ChainDbArgs Identity IO blk
customiseArgs (ChainDbArgs Identity IO blk -> ChainDbArgs Identity IO blk)
-> ChainDbArgs Identity IO blk -> ChainDbArgs Identity IO blk
forall a b. (a -> b) -> a -> b
$
             Tracer IO (TraceEvent blk)
-> ResourceRegistry IO
-> CheckInFuture IO blk
-> FilePath
-> TopLevelConfig blk
-> ExtLedgerState blk
-> ChunkInfo
-> ChainDbArgs Identity IO blk
forall blk.
RunNode blk =>
Tracer IO (TraceEvent blk)
-> ResourceRegistry IO
-> CheckInFuture IO blk
-> FilePath
-> TopLevelConfig blk
-> ExtLedgerState blk
-> ChunkInfo
-> ChainDbArgs Identity IO blk
mkChainDbArgs Tracer IO (TraceEvent blk)
tracer ResourceRegistry IO
registry CheckInFuture IO blk
inFuture FilePath
dbPath TopLevelConfig blk
cfg ExtLedgerState blk
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))

mkChainDbArgs
  :: forall blk. RunNode blk
  => Tracer IO (ChainDB.TraceEvent blk)
  -> ResourceRegistry IO
  -> CheckInFuture IO blk
  -> FilePath
     -- ^ Database path
  -> TopLevelConfig blk
  -> ExtLedgerState blk
     -- ^ Initial ledger
  -> ChunkInfo
  -> ChainDbArgs Identity IO blk
mkChainDbArgs :: Tracer IO (TraceEvent blk)
-> ResourceRegistry IO
-> CheckInFuture IO blk
-> FilePath
-> TopLevelConfig blk
-> ExtLedgerState blk
-> ChunkInfo
-> ChainDbArgs Identity IO blk
mkChainDbArgs Tracer IO (TraceEvent blk)
tracer ResourceRegistry IO
registry CheckInFuture IO blk
inFuture FilePath
dbPath TopLevelConfig blk
cfg ExtLedgerState blk
initLedger
              ChunkInfo
chunkInfo = (FilePath -> ChainDbArgs Defaults IO blk
forall blk. FilePath -> ChainDbArgs Defaults IO blk
ChainDB.defaultArgs FilePath
dbPath) {
      cdbMaxBlocksPerFile :: BlocksPerFile
ChainDB.cdbMaxBlocksPerFile      = Word32 -> BlocksPerFile
mkBlocksPerFile Word32
1000
    , cdbChunkInfo :: HKD Identity ChunkInfo
ChainDB.cdbChunkInfo             = HKD Identity ChunkInfo
ChunkInfo
chunkInfo
    , cdbGenesis :: HKD Identity (IO (ExtLedgerState blk))
ChainDB.cdbGenesis               = ExtLedgerState blk -> IO (ExtLedgerState blk)
forall (m :: * -> *) a. Monad m => a -> m a
return ExtLedgerState blk
initLedger
    , cdbDiskPolicy :: HKD Identity DiskPolicy
ChainDB.cdbDiskPolicy            = SecurityParam -> DiskPolicy
defaultDiskPolicy SecurityParam
k
    , cdbCheckIntegrity :: HKD Identity (blk -> Bool)
ChainDB.cdbCheckIntegrity        = 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)
    , cdbParamsLgrDB :: HKD Identity LedgerDbParams
ChainDB.cdbParamsLgrDB           = SecurityParam -> LedgerDbParams
ledgerDbDefaultParams SecurityParam
k
    , cdbTopLevelConfig :: HKD Identity (TopLevelConfig blk)
ChainDB.cdbTopLevelConfig        = HKD Identity (TopLevelConfig blk)
TopLevelConfig blk
cfg
    , cdbRegistry :: HKD Identity (ResourceRegistry IO)
ChainDB.cdbRegistry              = HKD Identity (ResourceRegistry IO)
ResourceRegistry IO
registry
    , cdbTracer :: Tracer IO (TraceEvent blk)
ChainDB.cdbTracer                = Tracer IO (TraceEvent blk)
tracer
    , cdbImmutableDbValidation :: ValidationPolicy
ChainDB.cdbImmutableDbValidation = ValidationPolicy
ValidateMostRecentChunk
    , cdbVolatileDbValidation :: BlockValidationPolicy
ChainDB.cdbVolatileDbValidation  = BlockValidationPolicy
NoValidation
    , cdbCheckInFuture :: HKD Identity (CheckInFuture IO blk)
ChainDB.cdbCheckInFuture         = HKD Identity (CheckInFuture IO blk)
CheckInFuture IO blk
inFuture
    }
  where
    k :: SecurityParam
k = TopLevelConfig blk -> SecurityParam
forall blk.
ConsensusProtocol (BlockProtocol blk) =>
TopLevelConfig blk -> SecurityParam
configSecurityParam TopLevelConfig blk
cfg

mkNodeArgs
  :: forall blk. RunNode blk
  => ResourceRegistry IO
  -> TopLevelConfig blk
  -> [IO (BlockForging IO blk)]
  -> Tracers IO RemoteConnectionId LocalConnectionId blk
  -> BlockchainTime IO
  -> ChainDB IO blk
  -> IO (NodeArgs IO RemoteConnectionId LocalConnectionId blk)
mkNodeArgs :: ResourceRegistry IO
-> TopLevelConfig blk
-> [IO (BlockForging IO blk)]
-> Tracers IO RemoteConnectionId LocalConnectionId blk
-> BlockchainTime IO
-> ChainDB IO blk
-> IO (NodeArgs IO RemoteConnectionId LocalConnectionId blk)
mkNodeArgs ResourceRegistry IO
registry TopLevelConfig blk
cfg [IO (BlockForging IO blk)]
initBlockForging Tracers IO RemoteConnectionId LocalConnectionId blk
tracers BlockchainTime IO
btime ChainDB IO blk
chainDB = do
    [BlockForging IO blk]
blockForging <- [IO (BlockForging IO blk)] -> IO [BlockForging IO blk]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [IO (BlockForging IO blk)]
initBlockForging
    Int
bfsalt <- IO Int
forall a. Random a => IO a
randomIO -- Per-node specific value used by blockfetch when ranking peers.
    StdGen
keepAliveRng <- IO StdGen
newStdGen
    NodeArgs IO RemoteConnectionId LocalConnectionId blk
-> IO (NodeArgs IO RemoteConnectionId LocalConnectionId blk)
forall (m :: * -> *) a. Monad m => a -> m a
return NodeArgs :: forall (m :: * -> *) remotePeer localPeer blk.
Tracers m remotePeer localPeer blk
-> ResourceRegistry m
-> TopLevelConfig blk
-> BlockchainTime m
-> ChainDB m blk
-> (StorageConfig blk -> InitChainDB m blk -> m ())
-> (Header blk -> Word32)
-> [BlockForging m blk]
-> MaxTxCapacityOverride
-> MempoolCapacityBytesOverride
-> MiniProtocolParameters
-> BlockFetchConfiguration
-> StdGen
-> NodeArgs m remotePeer localPeer blk
NodeArgs
      { Tracers IO RemoteConnectionId LocalConnectionId blk
$sel:tracers:NodeArgs :: Tracers IO RemoteConnectionId LocalConnectionId blk
tracers :: Tracers IO RemoteConnectionId LocalConnectionId blk
tracers
      , ResourceRegistry IO
$sel:registry:NodeArgs :: ResourceRegistry IO
registry :: ResourceRegistry IO
registry
      , TopLevelConfig blk
$sel:cfg:NodeArgs :: TopLevelConfig blk
cfg :: TopLevelConfig blk
cfg
      , BlockchainTime IO
$sel:btime:NodeArgs :: BlockchainTime IO
btime :: BlockchainTime IO
btime
      , ChainDB IO blk
$sel:chainDB:NodeArgs :: ChainDB IO blk
chainDB :: ChainDB IO blk
chainDB
      , $sel:blockForging:NodeArgs :: [BlockForging IO blk]
blockForging            = [BlockForging IO blk]
blockForging
      , $sel:initChainDB:NodeArgs :: StorageConfig blk -> InitChainDB IO blk -> IO ()
initChainDB             = StorageConfig blk -> InitChainDB IO blk -> IO ()
forall blk (m :: * -> *).
(NodeInitStorage blk, IOLike m) =>
StorageConfig blk -> InitChainDB m blk -> m ()
nodeInitChainDB
      , $sel:blockFetchSize:NodeArgs :: Header blk -> Word32
blockFetchSize          = Header blk -> Word32
forall blk.
SerialiseNodeToNodeConstraints blk =>
Header blk -> Word32
estimateBlockSize
      , $sel:maxTxCapacityOverride:NodeArgs :: MaxTxCapacityOverride
maxTxCapacityOverride   = MaxTxCapacityOverride
NoMaxTxCapacityOverride
      , $sel:mempoolCapacityOverride:NodeArgs :: MempoolCapacityBytesOverride
mempoolCapacityOverride = MempoolCapacityBytesOverride
NoMempoolCapacityBytesOverride
      , $sel:miniProtocolParameters:NodeArgs :: MiniProtocolParameters
miniProtocolParameters  = MiniProtocolParameters
defaultMiniProtocolParameters
      , $sel:blockFetchConfiguration:NodeArgs :: BlockFetchConfiguration
blockFetchConfiguration = Int -> BlockFetchConfiguration
defaultBlockFetchConfiguration Int
bfsalt
      , $sel:keepAliveRng:NodeArgs :: StdGen
keepAliveRng            = StdGen
keepAliveRng
      }
  where
    defaultBlockFetchConfiguration :: Int -> BlockFetchConfiguration
    defaultBlockFetchConfiguration :: Int -> BlockFetchConfiguration
defaultBlockFetchConfiguration Int
bfsalt = BlockFetchConfiguration :: Word -> Word -> Word -> DiffTime -> Int -> BlockFetchConfiguration
BlockFetchConfiguration
      { bfcMaxConcurrencyBulkSync :: Word
bfcMaxConcurrencyBulkSync = Word
1
      , bfcMaxConcurrencyDeadline :: Word
bfcMaxConcurrencyDeadline = Word
1
      , bfcMaxRequestsInflight :: Word
bfcMaxRequestsInflight    = MiniProtocolParameters -> Word
blockFetchPipeliningMax MiniProtocolParameters
defaultMiniProtocolParameters
      , bfcDecisionLoopInterval :: DiffTime
bfcDecisionLoopInterval   = DiffTime
0.01 -- 10ms
      , bfcSalt :: Int
bfcSalt                   = Int
bfsalt
      }

-- | We allow the user running the node to customise the 'NodeArgs' through
-- 'rnCustomiseNodeArgs', but there are some limits to some values. This
-- function makes sure we don't exceed those limits and that the values are
-- consistent.
nodeArgsEnforceInvariants
  :: NodeArgs m RemoteConnectionId LocalConnectionId blk
  -> NodeArgs m RemoteConnectionId LocalConnectionId blk
nodeArgsEnforceInvariants :: NodeArgs m RemoteConnectionId LocalConnectionId blk
-> NodeArgs m RemoteConnectionId LocalConnectionId blk
nodeArgsEnforceInvariants nodeArgs :: NodeArgs m RemoteConnectionId LocalConnectionId blk
nodeArgs@NodeArgs{[BlockForging m blk]
StdGen
MiniProtocolParameters
TopLevelConfig blk
BlockFetchConfiguration
ResourceRegistry m
ChainDB m blk
BlockchainTime m
Tracers m RemoteConnectionId LocalConnectionId blk
MempoolCapacityBytesOverride
MaxTxCapacityOverride
Header blk -> Word32
StorageConfig blk -> InitChainDB m blk -> m ()
keepAliveRng :: StdGen
blockFetchConfiguration :: BlockFetchConfiguration
miniProtocolParameters :: MiniProtocolParameters
mempoolCapacityOverride :: MempoolCapacityBytesOverride
maxTxCapacityOverride :: MaxTxCapacityOverride
blockForging :: [BlockForging m blk]
blockFetchSize :: Header blk -> Word32
initChainDB :: StorageConfig blk -> InitChainDB m blk -> m ()
chainDB :: ChainDB m blk
btime :: BlockchainTime m
cfg :: TopLevelConfig blk
registry :: ResourceRegistry m
tracers :: Tracers m RemoteConnectionId LocalConnectionId blk
$sel:keepAliveRng:NodeArgs :: forall (m :: * -> *) remotePeer localPeer blk.
NodeArgs m remotePeer localPeer blk -> StdGen
$sel:blockFetchConfiguration:NodeArgs :: forall (m :: * -> *) remotePeer localPeer blk.
NodeArgs m remotePeer localPeer blk -> BlockFetchConfiguration
$sel:mempoolCapacityOverride:NodeArgs :: forall (m :: * -> *) remotePeer localPeer blk.
NodeArgs m remotePeer localPeer blk -> MempoolCapacityBytesOverride
$sel:maxTxCapacityOverride:NodeArgs :: forall (m :: * -> *) remotePeer localPeer blk.
NodeArgs m remotePeer localPeer blk -> MaxTxCapacityOverride
$sel:blockFetchSize:NodeArgs :: forall (m :: * -> *) remotePeer localPeer blk.
NodeArgs m remotePeer localPeer blk -> Header blk -> Word32
$sel:initChainDB:NodeArgs :: forall (m :: * -> *) remotePeer localPeer blk.
NodeArgs m remotePeer localPeer blk
-> StorageConfig blk -> InitChainDB m blk -> m ()
$sel:blockForging:NodeArgs :: forall (m :: * -> *) remotePeer localPeer blk.
NodeArgs m remotePeer localPeer blk -> [BlockForging m blk]
$sel:chainDB:NodeArgs :: forall (m :: * -> *) remotePeer localPeer blk.
NodeArgs m remotePeer localPeer blk -> ChainDB m blk
$sel:btime:NodeArgs :: forall (m :: * -> *) remotePeer localPeer blk.
NodeArgs m remotePeer localPeer blk -> BlockchainTime m
$sel:cfg:NodeArgs :: forall (m :: * -> *) remotePeer localPeer blk.
NodeArgs m remotePeer localPeer blk -> TopLevelConfig blk
$sel:registry:NodeArgs :: forall (m :: * -> *) remotePeer localPeer blk.
NodeArgs m remotePeer localPeer blk -> ResourceRegistry m
$sel:tracers:NodeArgs :: forall (m :: * -> *) remotePeer localPeer blk.
NodeArgs m remotePeer localPeer blk
-> Tracers m remotePeer localPeer blk
$sel:miniProtocolParameters:NodeArgs :: forall (m :: * -> *) remotePeer localPeer blk.
NodeArgs m remotePeer localPeer blk -> MiniProtocolParameters
..} = NodeArgs m RemoteConnectionId LocalConnectionId blk
nodeArgs
    { $sel:miniProtocolParameters:NodeArgs :: MiniProtocolParameters
miniProtocolParameters = MiniProtocolParameters
miniProtocolParameters
        -- If 'blockFetchPipeliningMax' exceeds the configured default, it
        -- would be a protocol violation.
        { blockFetchPipeliningMax :: Word
blockFetchPipeliningMax =
            Word -> Word -> Word
forall a. Ord a => a -> a -> a
min (MiniProtocolParameters -> Word
blockFetchPipeliningMax MiniProtocolParameters
miniProtocolParameters)
                (MiniProtocolParameters -> Word
blockFetchPipeliningMax MiniProtocolParameters
defaultMiniProtocolParameters)
        }
    , $sel:blockFetchConfiguration:NodeArgs :: BlockFetchConfiguration
blockFetchConfiguration = BlockFetchConfiguration
blockFetchConfiguration
        -- 'bfcMaxRequestsInflight' must be <= 'blockFetchPipeliningMax'
        { bfcMaxRequestsInflight :: Word
bfcMaxRequestsInflight =
            Word -> Word -> Word
forall a. Ord a => a -> a -> a
min (BlockFetchConfiguration -> Word
bfcMaxRequestsInflight BlockFetchConfiguration
blockFetchConfiguration)
                (MiniProtocolParameters -> Word
blockFetchPipeliningMax MiniProtocolParameters
miniProtocolParameters)
        }
    }