{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

-- | Setup network
module Test.ThreadNet.Network (
    CalcMessageDelay (..)
  , ForgeEbbEnv (..)
  , RekeyM
  , TestNodeInitialization (..)
  , ThreadNetworkArgs (..)
  , TracingConstraints
  , noCalcMessageDelay
  , plainTestNodeInitialization
  , runThreadNetwork
    -- * Tracers
  , MiniProtocolFatalException (..)
  , MiniProtocolState (..)
    -- * Test Output
  , NodeDBs (..)
  , NodeOutput (..)
  , TestOutput (..)
  ) where

import           Codec.CBOR.Read (DeserialiseFailure)
import qualified Control.Concurrent.Class.MonadSTM as MonadSTM
import           Control.Concurrent.Class.MonadSTM.Strict (newTMVar)
import qualified Control.Exception as Exn
import           Control.Monad
import           Control.Monad.Class.MonadTime.SI (MonadTime)
import           Control.Monad.Class.MonadTimer.SI (MonadTimer)
import qualified Control.Monad.Except as Exc
import           Control.ResourceRegistry
import           Control.Tracer
import qualified Data.ByteString.Lazy as Lazy
import           Data.Either (isRight)
import           Data.Functor.Contravariant ((>$<))
import           Data.Functor.Identity (Identity)
import qualified Data.List as List
import qualified Data.List.NonEmpty as NE
import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import           Data.Set (Set)
import qualified Data.Set as Set
import qualified Data.Typeable as Typeable
import           Data.Void (Void)
import           GHC.Stack
import           Network.TypedProtocol.Codec (AnyMessage (..), CodecFailure,
                     mapFailureCodec)
import qualified Network.TypedProtocol.Codec as Codec
import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.BlockchainTime
import           Ouroboros.Consensus.Config
import           Ouroboros.Consensus.Ledger.Abstract
import           Ouroboros.Consensus.Ledger.Extended
import           Ouroboros.Consensus.Ledger.Inspect
import           Ouroboros.Consensus.Ledger.SupportsMempool
import           Ouroboros.Consensus.Ledger.SupportsProtocol
import           Ouroboros.Consensus.Mempool
import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client as CSClient
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.NodeToNode as NTN
import           Ouroboros.Consensus.Node.ExitPolicy
import           Ouroboros.Consensus.Node.Genesis
import qualified Ouroboros.Consensus.Node.GSM as GSM
import           Ouroboros.Consensus.Node.InitStorage
import           Ouroboros.Consensus.Node.NetworkProtocolVersion
import           Ouroboros.Consensus.Node.ProtocolInfo
import           Ouroboros.Consensus.Node.Run
import           Ouroboros.Consensus.Node.Tracers
import           Ouroboros.Consensus.NodeId
import           Ouroboros.Consensus.NodeKernel as NodeKernel
import           Ouroboros.Consensus.Protocol.Abstract
import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB
import qualified Ouroboros.Consensus.Storage.ChainDB.API.Types.InvalidBlockPunishment as InvalidBlockPunishment
import           Ouroboros.Consensus.Storage.ChainDB.Impl
import           Ouroboros.Consensus.Storage.ChainDB.Impl.Args
import qualified Ouroboros.Consensus.Storage.ChainDB.Impl.LgrDB as LedgerDB
import qualified Ouroboros.Consensus.Storage.ImmutableDB as ImmutableDB
import qualified Ouroboros.Consensus.Storage.VolatileDB as VolatileDB
import           Ouroboros.Consensus.Util.Assert
import           Ouroboros.Consensus.Util.Condense
import           Ouroboros.Consensus.Util.Enclose (pattern FallingEdge)
import           Ouroboros.Consensus.Util.IOLike
import           Ouroboros.Consensus.Util.Orphans ()
import           Ouroboros.Consensus.Util.RedundantConstraints
import           Ouroboros.Consensus.Util.STM
import           Ouroboros.Consensus.Util.Time
import qualified Ouroboros.Network.AnchoredFragment as AF
import           Ouroboros.Network.BlockFetch (BlockFetchConfiguration (..),
                     TraceLabelPeer (..))
import           Ouroboros.Network.Channel
import           Ouroboros.Network.ControlMessage (ControlMessage (..))
import           Ouroboros.Network.Mock.Chain (Chain (Genesis))
import           Ouroboros.Network.NodeToNode (ConnectionId (..),
                     ExpandedInitiatorContext (..), IsBigLedgerPeer (..),
                     MiniProtocolParameters (..), ResponderContext (..))
import           Ouroboros.Network.PeerSelection.Bootstrap
                     (UseBootstrapPeers (..))
import           Ouroboros.Network.PeerSelection.Governor
                     (makePublicPeerSelectionStateVar)
import           Ouroboros.Network.PeerSelection.PeerMetric (nullMetric)
import           Ouroboros.Network.Point (WithOrigin (..))
import qualified Ouroboros.Network.Protocol.ChainSync.Type as CS
import           Ouroboros.Network.Protocol.KeepAlive.Type
import           Ouroboros.Network.Protocol.Limits (waitForever)
import           Ouroboros.Network.Protocol.PeerSharing.Type (PeerSharing)
import           Ouroboros.Network.Protocol.TxSubmission2.Type
import qualified System.FS.Sim.MockFS as Mock
import           System.FS.Sim.MockFS (MockFS)
import           System.Random (mkStdGen, split)
import           Test.ThreadNet.TxGen
import           Test.ThreadNet.Util.NodeJoinPlan
import           Test.ThreadNet.Util.NodeRestarts
import           Test.ThreadNet.Util.NodeTopology
import           Test.ThreadNet.Util.Seed
import           Test.Util.ChainDB
import qualified Test.Util.HardFork.Future as HFF
import           Test.Util.HardFork.Future (Future)
import qualified Test.Util.HardFork.OracularClock as OracularClock
import           Test.Util.HardFork.OracularClock (OracularClock (..))
import           Test.Util.Slots (NumSlots (..))
import           Test.Util.Time
import           Test.Util.Tracer

-- | How to forge an EBB
--
data ForgeEbbEnv blk = ForgeEbbEnv
  { forall blk.
ForgeEbbEnv blk
-> TopLevelConfig blk -> SlotNo -> BlockNo -> ChainHash blk -> blk
forgeEBB ::
         TopLevelConfig blk
      -> SlotNo
         -- EBB slot
      -> BlockNo
         -- EBB block number (i.e. that of its predecessor)
      -> ChainHash blk
         -- EBB predecessor's hash
      -> blk
  }
instance Show (ForgeEbbEnv blk) where
  showsPrec :: Int -> ForgeEbbEnv blk -> ShowS
showsPrec Int
p ForgeEbbEnv blk
_ = Bool -> ShowS -> ShowS
showParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String -> ShowS
showString String
"ForgeEbbEnv _"

-- | How to rekey a node with a fresh operational key
--
-- When there is a 'NodeRekey' scheduled in the 'NodeRestarts', the test node
-- will restart and use 'tnaRekeyM' to compute its new 'ProtocolInfo'.
type RekeyM m blk =
     CoreNodeId
  -> ProtocolInfo blk
  -> m [BlockForging m blk]
  -> SlotNo
     -- ^ The slot in which the node is rekeying
  -> (SlotNo -> m EpochNo)
     -- ^ Which epoch the slot is in
  -> m (TestNodeInitialization m blk)
     -- ^ 'tniProtocolInfo' should include new delegation cert/operational key,
     -- and 'tniCrucialTxs' should include the new delegation certificate
     -- transaction

-- | Data used when starting/restarting a node
data TestNodeInitialization m blk = TestNodeInitialization
  { forall (m :: * -> *) blk.
TestNodeInitialization m blk -> [GenTx blk]
tniCrucialTxs   :: [GenTx blk]
    -- ^ these transactions are added immediately and repeatedly (whenever the
    -- 'ledgerTipSlot' changes)
    --
    -- In particular, a leading node's crucial transactions must (if valid)
    -- enter its mempool each slot /before/ the node takes the mempool snapshot
    -- that determines which transactions will be included in the block it's
    -- about to forge.
  , forall (m :: * -> *) blk.
TestNodeInitialization m blk -> ProtocolInfo blk
tniProtocolInfo :: ProtocolInfo blk
  , forall (m :: * -> *) blk.
TestNodeInitialization m blk -> m [BlockForging m blk]
tniBlockForging :: m [BlockForging m blk]
  }

plainTestNodeInitialization ::
     ProtocolInfo blk
  -> m [BlockForging m blk]
  -> TestNodeInitialization m blk
plainTestNodeInitialization :: forall blk (m :: * -> *).
ProtocolInfo blk
-> m [BlockForging m blk] -> TestNodeInitialization m blk
plainTestNodeInitialization ProtocolInfo blk
pInfo m [BlockForging m blk]
blockForging = TestNodeInitialization
    { tniCrucialTxs :: [GenTx blk]
tniCrucialTxs   = []
    , tniProtocolInfo :: ProtocolInfo blk
tniProtocolInfo = ProtocolInfo blk
pInfo
    , tniBlockForging :: m [BlockForging m blk]
tniBlockForging = m [BlockForging m blk]
blockForging
    }

-- | Compute the chain diffusion delay
--
-- This is the number of slots a 'CS.MsgRollForward' should arrive after the
-- forge slot of the header it is carrying.
--
-- It may depend on the @(sender, recipient)@, the current slot, and header.
newtype CalcMessageDelay blk = CalcMessageDelay
    ((CoreNodeId, CoreNodeId) -> SlotNo -> Header blk -> NumSlots)

noCalcMessageDelay :: CalcMessageDelay blk
noCalcMessageDelay :: forall blk. CalcMessageDelay blk
noCalcMessageDelay = ((CoreNodeId, CoreNodeId) -> SlotNo -> Header blk -> NumSlots)
-> CalcMessageDelay blk
forall blk.
((CoreNodeId, CoreNodeId) -> SlotNo -> Header blk -> NumSlots)
-> CalcMessageDelay blk
CalcMessageDelay (((CoreNodeId, CoreNodeId) -> SlotNo -> Header blk -> NumSlots)
 -> CalcMessageDelay blk)
-> ((CoreNodeId, CoreNodeId) -> SlotNo -> Header blk -> NumSlots)
-> CalcMessageDelay blk
forall a b. (a -> b) -> a -> b
$ \(CoreNodeId, CoreNodeId)
_ SlotNo
_ Header blk
_ -> Word64 -> NumSlots
NumSlots Word64
0

-- | This type occurs in records where most of the fields are data
instance Show (CalcMessageDelay blk) where
  show :: CalcMessageDelay blk -> String
show CalcMessageDelay blk
_ = String
"_CalcMessageDelay"

-- | Parameters for the test node net
--
data ThreadNetworkArgs m blk = ThreadNetworkArgs
  { forall (m :: * -> *) blk.
ThreadNetworkArgs m blk -> Maybe (ForgeEbbEnv blk)
tnaForgeEbbEnv  :: Maybe (ForgeEbbEnv blk)
  , forall (m :: * -> *) blk. ThreadNetworkArgs m blk -> Future
tnaFuture       :: Future
  , forall (m :: * -> *) blk. ThreadNetworkArgs m blk -> NodeJoinPlan
tnaJoinPlan     :: NodeJoinPlan
  , forall (m :: * -> *) blk.
ThreadNetworkArgs m blk
-> CoreNodeId -> TestNodeInitialization m blk
tnaNodeInfo     :: CoreNodeId -> TestNodeInitialization m blk
  , forall (m :: * -> *) blk. ThreadNetworkArgs m blk -> NumCoreNodes
tnaNumCoreNodes :: NumCoreNodes
  , forall (m :: * -> *) blk. ThreadNetworkArgs m blk -> NumSlots
tnaNumSlots     :: NumSlots
  , forall (m :: * -> *) blk.
ThreadNetworkArgs m blk -> CalcMessageDelay blk
tnaMessageDelay :: CalcMessageDelay blk
  , forall (m :: * -> *) blk. ThreadNetworkArgs m blk -> Seed
tnaSeed         :: Seed
  , forall (m :: * -> *) blk.
ThreadNetworkArgs m blk -> Maybe (m (RekeyM m blk))
tnaMkRekeyM     :: Maybe (m (RekeyM m blk))
  , forall (m :: * -> *) blk. ThreadNetworkArgs m blk -> NodeRestarts
tnaRestarts     :: NodeRestarts
  , forall (m :: * -> *) blk. ThreadNetworkArgs m blk -> NodeTopology
tnaTopology     :: NodeTopology
  , forall (m :: * -> *) blk. ThreadNetworkArgs m blk -> TxGenExtra blk
tnaTxGenExtra   :: TxGenExtra blk
  , forall (m :: * -> *) blk.
ThreadNetworkArgs m blk -> NodeToNodeVersion
tnaVersion      :: NodeToNodeVersion
  , forall (m :: * -> *) blk.
ThreadNetworkArgs m blk -> BlockNodeToNodeVersion blk
tnaBlockVersion :: BlockNodeToNodeVersion blk
  }

{-------------------------------------------------------------------------------
  Vertex and Edge Statuses
-------------------------------------------------------------------------------}

-- | A /vertex/ denotes the \"operator of a node\"; in production, that's
-- typically a person.
--
-- There is always exactly one vertex for each genesis key. When its current
-- node instance crashes/terminates, the vertex replaces it with a new one.
-- Every node instance created by a vertex uses the same file system.
--
-- The term \"vertex\" is only explicitly used in this module. However, the
-- concept exists throughout the project; it's usually denoted by the term
-- \"node\", which can mean either \"vertex\" or \"node instance\". We take
-- more care than usual in this module to be explicit, but still often rely on
-- context.
--
data VertexStatus m blk
  = VDown (Chain blk) (LedgerState blk)
    -- ^ The vertex does not currently have a node instance; its previous
    -- instance stopped with this chain and ledger state (empty/initial before
    -- first instance)
  | VFalling
    -- ^ The vertex has a node instance, but it is about to transition to
    -- 'VDown' as soon as its edges transition to 'EDown'.
  | VUp !(NodeKernel m NodeId Void blk) !(LimitedApp m NodeId blk)
    -- ^ The vertex currently has a node instance, with these handles.

-- | A directed /edge/ denotes the \"operator of a node-to-node connection\";
-- in production, that's generally the TCP connection and the networking layers
-- built atop it.
--
-- There are always exactly two edges between two vertices that are connected
-- by the 'NodeTopology': one for the client-server relationship in each
-- direction. When the mini protocol instances crash, the edge replaces them
-- with new instances, possibly after a delay (see 'RestartCause').
--
-- (We do not need 'EFalling' because node instances can exist without mini
-- protocols; we only need 'VFalling' because mini protocol instances cannot
-- exist without node instances.)
--
data EdgeStatus
  = EDown
    -- ^ The edge does not currently have mini protocol instances.
  | EUp
    -- ^ The edge currently has mini protocol instances.
  deriving (EdgeStatus -> EdgeStatus -> Bool
(EdgeStatus -> EdgeStatus -> Bool)
-> (EdgeStatus -> EdgeStatus -> Bool) -> Eq EdgeStatus
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: EdgeStatus -> EdgeStatus -> Bool
== :: EdgeStatus -> EdgeStatus -> Bool
$c/= :: EdgeStatus -> EdgeStatus -> Bool
/= :: EdgeStatus -> EdgeStatus -> Bool
Eq)

type VertexStatusVar m blk = StrictTVar m (VertexStatus m blk)
type EdgeStatusVar m = StrictTVar m EdgeStatus

{-------------------------------------------------------------------------------
  Running the node net
-------------------------------------------------------------------------------}

-- | Setup a network of core nodes, where each joins according to the node join
-- plan and is interconnected according to the node topology
--
-- We run for the specified number of blocks, then return the final state of
-- each node.
runThreadNetwork :: forall m blk.
                    ( IOLike m
                    , MonadTime m
                    , MonadTimer m
                    , RunNode blk
                    , TxGen blk
                    , TracingConstraints blk
                    , HasCallStack
                    )
                 => SystemTime m -> ThreadNetworkArgs m blk -> m (TestOutput blk)
runThreadNetwork :: forall (m :: * -> *) blk.
(IOLike m, MonadTime m, MonadTimer m, RunNode blk, TxGen blk,
 TracingConstraints blk, HasCallStack) =>
SystemTime m -> ThreadNetworkArgs m blk -> m (TestOutput blk)
runThreadNetwork SystemTime m
systemTime ThreadNetworkArgs
  { tnaForgeEbbEnv :: forall (m :: * -> *) blk.
ThreadNetworkArgs m blk -> Maybe (ForgeEbbEnv blk)
tnaForgeEbbEnv    = Maybe (ForgeEbbEnv blk)
mbForgeEbbEnv
  , tnaFuture :: forall (m :: * -> *) blk. ThreadNetworkArgs m blk -> Future
tnaFuture         = Future
future
  , tnaJoinPlan :: forall (m :: * -> *) blk. ThreadNetworkArgs m blk -> NodeJoinPlan
tnaJoinPlan       = NodeJoinPlan
nodeJoinPlan
  , tnaNodeInfo :: forall (m :: * -> *) blk.
ThreadNetworkArgs m blk
-> CoreNodeId -> TestNodeInitialization m blk
tnaNodeInfo       = CoreNodeId -> TestNodeInitialization m blk
mkProtocolInfo
  , tnaNumCoreNodes :: forall (m :: * -> *) blk. ThreadNetworkArgs m blk -> NumCoreNodes
tnaNumCoreNodes   = NumCoreNodes
numCoreNodes
  , tnaNumSlots :: forall (m :: * -> *) blk. ThreadNetworkArgs m blk -> NumSlots
tnaNumSlots       = NumSlots
numSlots
  , tnaMessageDelay :: forall (m :: * -> *) blk.
ThreadNetworkArgs m blk -> CalcMessageDelay blk
tnaMessageDelay   = CalcMessageDelay blk
calcMessageDelay
  , tnaSeed :: forall (m :: * -> *) blk. ThreadNetworkArgs m blk -> Seed
tnaSeed           = Seed
seed
  , tnaMkRekeyM :: forall (m :: * -> *) blk.
ThreadNetworkArgs m blk -> Maybe (m (RekeyM m blk))
tnaMkRekeyM       = Maybe (m (RekeyM m blk))
mbMkRekeyM
  , tnaRestarts :: forall (m :: * -> *) blk. ThreadNetworkArgs m blk -> NodeRestarts
tnaRestarts       = NodeRestarts
nodeRestarts
  , tnaTopology :: forall (m :: * -> *) blk. ThreadNetworkArgs m blk -> NodeTopology
tnaTopology       = NodeTopology
nodeTopology
  , tnaTxGenExtra :: forall (m :: * -> *) blk. ThreadNetworkArgs m blk -> TxGenExtra blk
tnaTxGenExtra     = TxGenExtra blk
txGenExtra
  , tnaVersion :: forall (m :: * -> *) blk.
ThreadNetworkArgs m blk -> NodeToNodeVersion
tnaVersion        = NodeToNodeVersion
version
  , tnaBlockVersion :: forall (m :: * -> *) blk.
ThreadNetworkArgs m blk -> BlockNodeToNodeVersion blk
tnaBlockVersion   = BlockNodeToNodeVersion blk
blockVersion
  } = (ResourceRegistry m -> m (TestOutput blk)) -> m (TestOutput blk)
forall (m :: * -> *) a.
(MonadSTM m, MonadMask m, MonadThread m, HasCallStack) =>
(ResourceRegistry m -> m a) -> m a
withRegistry ((ResourceRegistry m -> m (TestOutput blk)) -> m (TestOutput blk))
-> (ResourceRegistry m -> m (TestOutput blk)) -> m (TestOutput blk)
forall a b. (a -> b) -> a -> b
$ \ResourceRegistry m
sharedRegistry -> do
    Maybe (RekeyM m blk)
mbRekeyM <- Maybe (m (RekeyM m blk)) -> m (Maybe (RekeyM m blk))
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => Maybe (m a) -> m (Maybe a)
sequence Maybe (m (RekeyM m blk))
mbMkRekeyM

    -- This shared registry is used for 'newTestBlockchainTime' and the
    -- network communication threads. Each node will create its own registry
    -- for its ChainDB.
    -- TODO each node should run in its own thread and have its own (single
    -- top-level, bracketed) registry used to spawn all of the node's threads,
    -- including its own BlockchainTime. This will allow us to use
    -- ChainDB.withDB and avoid issues with termination and using registries
    -- from the wrong thread. To stop the network, wait for all the nodes'
    -- blockchain times to be done and then kill the main thread of each node,
    -- which should terminate all other threads it spawned.
    let clock :: OracularClock m
clock = SystemTime m -> NumSlots -> Future -> OracularClock m
forall (m :: * -> *).
IOLike m =>
SystemTime m -> NumSlots -> Future -> OracularClock m
OracularClock.mkOracularClock SystemTime m
systemTime NumSlots
numSlots Future
future
    -- This function is organized around the notion of a network of nodes as a
    -- simple graph with no loops. The graph topology is determined by
    -- @nodeTopology@.
    --
    -- Each graph vertex is a node operator, and maintains its own Ouroboros
    -- core node, which in turn has its own private threads managing its
    -- internal state. Some nodes join the network later than others, according
    -- to @nodeJoinPlan@.
    --
    -- Each undirected edge denotes two opposing directed edges. Each directed
    -- edge denotes a bundle of mini protocols with client threads on the tail
    -- node and server threads on the head node. These mini protocols begin as
    -- soon as both nodes have joined the network, according to @nodeJoinPlan@.

    -- allocate the status variable for each vertex
    Map CoreNodeId (StrictTVar m (VertexStatus m blk))
vertexStatusVars <- ([(CoreNodeId, StrictTVar m (VertexStatus m blk))]
 -> Map CoreNodeId (StrictTVar m (VertexStatus m blk)))
-> m [(CoreNodeId, StrictTVar m (VertexStatus m blk))]
-> m (Map CoreNodeId (StrictTVar m (VertexStatus m blk)))
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(CoreNodeId, StrictTVar m (VertexStatus m blk))]
-> Map CoreNodeId (StrictTVar m (VertexStatus m blk))
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (m [(CoreNodeId, StrictTVar m (VertexStatus m blk))]
 -> m (Map CoreNodeId (StrictTVar m (VertexStatus m blk))))
-> m [(CoreNodeId, StrictTVar m (VertexStatus m blk))]
-> m (Map CoreNodeId (StrictTVar m (VertexStatus m blk)))
forall a b. (a -> b) -> a -> b
$ do
      [CoreNodeId]
-> (CoreNodeId
    -> m (CoreNodeId, StrictTVar m (VertexStatus m blk)))
-> m [(CoreNodeId, StrictTVar m (VertexStatus m blk))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [CoreNodeId]
coreNodeIds ((CoreNodeId -> m (CoreNodeId, StrictTVar m (VertexStatus m blk)))
 -> m [(CoreNodeId, StrictTVar m (VertexStatus m blk))])
-> (CoreNodeId
    -> m (CoreNodeId, StrictTVar m (VertexStatus m blk)))
-> m [(CoreNodeId, StrictTVar m (VertexStatus m blk))]
forall a b. (a -> b) -> a -> b
$ \CoreNodeId
nid -> do
        -- assume they all start with the empty chain and the same initial
        -- ledger
        let nodeInitData :: TestNodeInitialization m blk
nodeInitData = CoreNodeId -> TestNodeInitialization m blk
mkProtocolInfo (Word64 -> CoreNodeId
CoreNodeId Word64
0)
            TestNodeInitialization{ProtocolInfo blk
tniProtocolInfo :: forall (m :: * -> *) blk.
TestNodeInitialization m blk -> ProtocolInfo blk
tniProtocolInfo :: ProtocolInfo blk
tniProtocolInfo} = TestNodeInitialization m blk
nodeInitData
            ProtocolInfo{ExtLedgerState blk
pInfoInitLedger :: ExtLedgerState blk
pInfoInitLedger :: forall b. ProtocolInfo b -> ExtLedgerState b
pInfoInitLedger} = ProtocolInfo blk
tniProtocolInfo
            ExtLedgerState{LedgerState blk
ledgerState :: LedgerState blk
ledgerState :: forall blk. ExtLedgerState blk -> LedgerState blk
ledgerState} = ExtLedgerState blk
pInfoInitLedger
        StrictTVar m (VertexStatus m blk)
v <- VertexStatus m blk -> m (StrictTVar m (VertexStatus m blk))
forall (m :: * -> *) a. MonadSTM m => a -> m (StrictTVar m a)
uncheckedNewTVarM (Chain blk -> LedgerState blk -> VertexStatus m blk
forall (m :: * -> *) blk.
Chain blk -> LedgerState blk -> VertexStatus m blk
VDown Chain blk
forall block. Chain block
Genesis LedgerState blk
ledgerState)
        (CoreNodeId, StrictTVar m (VertexStatus m blk))
-> m (CoreNodeId, StrictTVar m (VertexStatus m blk))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CoreNodeId
nid, StrictTVar m (VertexStatus m blk)
v)

    -- fork the directed edges, which also allocates their status variables
    let uedges :: [(CoreNodeId, CoreNodeId)]
uedges = NodeTopology -> [(CoreNodeId, CoreNodeId)]
edgesNodeTopology NodeTopology
nodeTopology
    Map (CoreNodeId, CoreNodeId) (EdgeStatusVar m)
edgeStatusVars <- ([[((CoreNodeId, CoreNodeId), EdgeStatusVar m)]]
 -> Map (CoreNodeId, CoreNodeId) (EdgeStatusVar m))
-> m [[((CoreNodeId, CoreNodeId), EdgeStatusVar m)]]
-> m (Map (CoreNodeId, CoreNodeId) (EdgeStatusVar m))
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([((CoreNodeId, CoreNodeId), EdgeStatusVar m)]
-> Map (CoreNodeId, CoreNodeId) (EdgeStatusVar m)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([((CoreNodeId, CoreNodeId), EdgeStatusVar m)]
 -> Map (CoreNodeId, CoreNodeId) (EdgeStatusVar m))
-> ([[((CoreNodeId, CoreNodeId), EdgeStatusVar m)]]
    -> [((CoreNodeId, CoreNodeId), EdgeStatusVar m)])
-> [[((CoreNodeId, CoreNodeId), EdgeStatusVar m)]]
-> Map (CoreNodeId, CoreNodeId) (EdgeStatusVar m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[((CoreNodeId, CoreNodeId), EdgeStatusVar m)]]
-> [((CoreNodeId, CoreNodeId), EdgeStatusVar m)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat) (m [[((CoreNodeId, CoreNodeId), EdgeStatusVar m)]]
 -> m (Map (CoreNodeId, CoreNodeId) (EdgeStatusVar m)))
-> m [[((CoreNodeId, CoreNodeId), EdgeStatusVar m)]]
-> m (Map (CoreNodeId, CoreNodeId) (EdgeStatusVar m))
forall a b. (a -> b) -> a -> b
$ do
      -- assume they all use the same CodecConfig
      let nodeInitData :: TestNodeInitialization m blk
nodeInitData = CoreNodeId -> TestNodeInitialization m blk
mkProtocolInfo (Word64 -> CoreNodeId
CoreNodeId Word64
0)
          TestNodeInitialization{ProtocolInfo blk
tniProtocolInfo :: forall (m :: * -> *) blk.
TestNodeInitialization m blk -> ProtocolInfo blk
tniProtocolInfo :: ProtocolInfo blk
tniProtocolInfo} = TestNodeInitialization m blk
nodeInitData
          ProtocolInfo{TopLevelConfig blk
pInfoConfig :: TopLevelConfig blk
pInfoConfig :: forall b. ProtocolInfo b -> TopLevelConfig b
pInfoConfig} = ProtocolInfo blk
tniProtocolInfo
          codecConfig :: CodecConfig blk
codecConfig = TopLevelConfig blk -> CodecConfig blk
forall blk. TopLevelConfig blk -> CodecConfig blk
configCodec TopLevelConfig blk
pInfoConfig
      [(CoreNodeId, CoreNodeId)]
-> ((CoreNodeId, CoreNodeId)
    -> m [((CoreNodeId, CoreNodeId), EdgeStatusVar m)])
-> m [[((CoreNodeId, CoreNodeId), EdgeStatusVar m)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(CoreNodeId, CoreNodeId)]
uedges (((CoreNodeId, CoreNodeId)
  -> m [((CoreNodeId, CoreNodeId), EdgeStatusVar m)])
 -> m [[((CoreNodeId, CoreNodeId), EdgeStatusVar m)]])
-> ((CoreNodeId, CoreNodeId)
    -> m [((CoreNodeId, CoreNodeId), EdgeStatusVar m)])
-> m [[((CoreNodeId, CoreNodeId), EdgeStatusVar m)]]
forall a b. (a -> b) -> a -> b
$ \(CoreNodeId, CoreNodeId)
uedge -> do
        ResourceRegistry m
-> OracularClock m
-> Tracer m (SlotNo, MiniProtocolState)
-> (NodeToNodeVersion, BlockNodeToNodeVersion blk)
-> (CodecConfig blk, CalcMessageDelay blk)
-> Map CoreNodeId (StrictTVar m (VertexStatus m blk))
-> (CoreNodeId, CoreNodeId)
-> m [((CoreNodeId, CoreNodeId), EdgeStatusVar m)]
forall (m :: * -> *) blk.
(IOLike m, RunNode blk, HasCallStack) =>
ResourceRegistry m
-> OracularClock m
-> Tracer m (SlotNo, MiniProtocolState)
-> (NodeToNodeVersion, BlockNodeToNodeVersion blk)
-> (CodecConfig blk, CalcMessageDelay blk)
-> Map CoreNodeId (VertexStatusVar m blk)
-> (CoreNodeId, CoreNodeId)
-> m [((CoreNodeId, CoreNodeId), EdgeStatusVar m)]
forkBothEdges
          ResourceRegistry m
sharedRegistry
          OracularClock m
clock
          -- traces when/why the mini protocol instances start and stop
          Tracer m (SlotNo, MiniProtocolState)
forall (m :: * -> *) a. (Applicative m, Show a) => Tracer m a
nullDebugTracer
          (NodeToNodeVersion
version, BlockNodeToNodeVersion blk
blockVersion)
          (CodecConfig blk
codecConfig, CalcMessageDelay blk
calcMessageDelay)
          Map CoreNodeId (StrictTVar m (VertexStatus m blk))
vertexStatusVars
          (CoreNodeId, CoreNodeId)
uedge

    -- fork the vertices
    let nodesByJoinSlot :: [(SlotNo, (CoreNodeId, StrictTVar m (VertexStatus m blk)))]
nodesByJoinSlot =
          ((SlotNo, (CoreNodeId, StrictTVar m (VertexStatus m blk)))
 -> SlotNo)
-> [(SlotNo, (CoreNodeId, StrictTVar m (VertexStatus m blk)))]
-> [(SlotNo, (CoreNodeId, StrictTVar m (VertexStatus m blk)))]
forall b a. Ord b => (a -> b) -> [a] -> [a]
List.sortOn (SlotNo, (CoreNodeId, StrictTVar m (VertexStatus m blk))) -> SlotNo
forall a b. (a, b) -> a
fst ([(SlotNo, (CoreNodeId, StrictTVar m (VertexStatus m blk)))]
 -> [(SlotNo, (CoreNodeId, StrictTVar m (VertexStatus m blk)))])
-> [(SlotNo, (CoreNodeId, StrictTVar m (VertexStatus m blk)))]
-> [(SlotNo, (CoreNodeId, StrictTVar m (VertexStatus m blk)))]
forall a b. (a -> b) -> a -> b
$   -- sort non-descending by join slot
          ((CoreNodeId, StrictTVar m (VertexStatus m blk))
 -> (SlotNo, (CoreNodeId, StrictTVar m (VertexStatus m blk))))
-> [(CoreNodeId, StrictTVar m (VertexStatus m blk))]
-> [(SlotNo, (CoreNodeId, StrictTVar m (VertexStatus m blk)))]
forall a b. (a -> b) -> [a] -> [b]
map (\nv :: (CoreNodeId, StrictTVar m (VertexStatus m blk))
nv@(CoreNodeId
n, StrictTVar m (VertexStatus m blk)
_) -> (CoreNodeId -> SlotNo
joinSlotOf CoreNodeId
n, (CoreNodeId, StrictTVar m (VertexStatus m blk))
nv)) ([(CoreNodeId, StrictTVar m (VertexStatus m blk))]
 -> [(SlotNo, (CoreNodeId, StrictTVar m (VertexStatus m blk)))])
-> [(CoreNodeId, StrictTVar m (VertexStatus m blk))]
-> [(SlotNo, (CoreNodeId, StrictTVar m (VertexStatus m blk)))]
forall a b. (a -> b) -> a -> b
$
          Map CoreNodeId (StrictTVar m (VertexStatus m blk))
-> [(CoreNodeId, StrictTVar m (VertexStatus m blk))]
forall k a. Map k a -> [(k, a)]
Map.toList Map CoreNodeId (StrictTVar m (VertexStatus m blk))
vertexStatusVars
    [(CoreNodeId, StrictTVar m (VertexStatus m blk),
  m (NodeInfo blk MockFS []))]
vertexInfos0 <- [(SlotNo, (CoreNodeId, StrictTVar m (VertexStatus m blk)))]
-> ((SlotNo, (CoreNodeId, StrictTVar m (VertexStatus m blk)))
    -> m (CoreNodeId, StrictTVar m (VertexStatus m blk),
          m (NodeInfo blk MockFS [])))
-> m [(CoreNodeId, StrictTVar m (VertexStatus m blk),
       m (NodeInfo blk MockFS []))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(SlotNo, (CoreNodeId, StrictTVar m (VertexStatus m blk)))]
nodesByJoinSlot (((SlotNo, (CoreNodeId, StrictTVar m (VertexStatus m blk)))
  -> m (CoreNodeId, StrictTVar m (VertexStatus m blk),
        m (NodeInfo blk MockFS [])))
 -> m [(CoreNodeId, StrictTVar m (VertexStatus m blk),
        m (NodeInfo blk MockFS []))])
-> ((SlotNo, (CoreNodeId, StrictTVar m (VertexStatus m blk)))
    -> m (CoreNodeId, StrictTVar m (VertexStatus m blk),
          m (NodeInfo blk MockFS [])))
-> m [(CoreNodeId, StrictTVar m (VertexStatus m blk),
       m (NodeInfo blk MockFS []))]
forall a b. (a -> b) -> a -> b
$ \(SlotNo, (CoreNodeId, StrictTVar m (VertexStatus m blk)))
vertexData -> do
      let (SlotNo
joinSlot, (CoreNodeId
coreNodeId, StrictTVar m (VertexStatus m blk)
vertexStatusVar)) = (SlotNo, (CoreNodeId, StrictTVar m (VertexStatus m blk)))
vertexData

      -- the vertex cannot create its first node instance until the
      -- 'NodeJoinPlan' allows
      Bool
tooLate <- OracularClock m -> SlotNo -> m Bool
forall (m :: * -> *). OracularClock m -> SlotNo -> m Bool
OracularClock.blockUntilSlot OracularClock m
clock SlotNo
joinSlot
      Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
tooLate (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
        String -> m ()
forall a. HasCallStack => String -> a
error (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"unsatisfiable nodeJoinPlan: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ CoreNodeId -> String
forall a. Show a => a -> String
show CoreNodeId
coreNodeId

      -- fork the per-vertex state variables, including the mock filesystem
      (NodeInfo blk (StrictTMVar m MockFS) (Tracer m)
nodeInfo, m (NodeInfo blk MockFS [])
readNodeInfo) <- m (NodeInfo blk (StrictTMVar m MockFS) (Tracer m),
   m (NodeInfo blk MockFS []))
forall blk (m :: * -> *).
IOLike m =>
m (NodeInfo blk (StrictTMVar m MockFS) (Tracer m),
   m (NodeInfo blk MockFS []))
newNodeInfo

      -- a tvar containing the next slot to be recorded in
      -- nodeEventsTipBlockNos
      StrictTVar m SlotNo
nextInstrSlotVar <- SlotNo -> m (StrictTVar m SlotNo)
forall (m :: * -> *) a. MonadSTM m => a -> m (StrictTVar m a)
uncheckedNewTVarM SlotNo
joinSlot

      let myEdgeStatusVars :: [EdgeStatusVar m]
myEdgeStatusVars =
            [ EdgeStatusVar m
v
            | ((CoreNodeId
n1, CoreNodeId
n2), EdgeStatusVar m
v) <- Map (CoreNodeId, CoreNodeId) (EdgeStatusVar m)
-> [((CoreNodeId, CoreNodeId), EdgeStatusVar m)]
forall k a. Map k a -> [(k, a)]
Map.toList Map (CoreNodeId, CoreNodeId) (EdgeStatusVar m)
edgeStatusVars
            , CoreNodeId
coreNodeId CoreNodeId -> [CoreNodeId] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [CoreNodeId
n1, CoreNodeId
n2]
            ]
      Maybe (RekeyM m blk)
-> OracularClock m
-> SlotNo
-> ResourceRegistry m
-> CoreNodeId
-> StrictTVar m (VertexStatus m blk)
-> [EdgeStatusVar m]
-> NodeInfo blk (StrictTMVar m MockFS) (Tracer m)
-> StrictTVar m SlotNo
-> m ()
forkVertex
        Maybe (RekeyM m blk)
mbRekeyM
        OracularClock m
clock
        SlotNo
joinSlot
        ResourceRegistry m
sharedRegistry
        CoreNodeId
coreNodeId
        StrictTVar m (VertexStatus m blk)
vertexStatusVar
        [EdgeStatusVar m]
myEdgeStatusVars
        NodeInfo blk (StrictTMVar m MockFS) (Tracer m)
nodeInfo
        StrictTVar m SlotNo
nextInstrSlotVar

      OracularClock m
-> ResourceRegistry m
-> StrictTVar m (VertexStatus m blk)
-> NodeInfo blk (StrictTMVar m MockFS) (Tracer m)
-> StrictTVar m SlotNo
-> m ()
forkInstrumentation
        OracularClock m
clock
        ResourceRegistry m
sharedRegistry
        StrictTVar m (VertexStatus m blk)
vertexStatusVar
        NodeInfo blk (StrictTMVar m MockFS) (Tracer m)
nodeInfo
        StrictTVar m SlotNo
nextInstrSlotVar

      (CoreNodeId, StrictTVar m (VertexStatus m blk),
 m (NodeInfo blk MockFS []))
-> m (CoreNodeId, StrictTVar m (VertexStatus m blk),
      m (NodeInfo blk MockFS []))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreNodeId
coreNodeId, StrictTVar m (VertexStatus m blk)
vertexStatusVar, m (NodeInfo blk MockFS [])
readNodeInfo)

    -- Wait for the last slot to end
    OracularClock m -> m ()
forall (m :: * -> *). OracularClock m -> m ()
OracularClock.waitUntilDone OracularClock m
clock

    -- Collect all nodes' final chains
    [(CoreNodeId, m (NodeInfo blk MockFS []), Chain blk,
  LedgerState blk)]
vertexInfos <-
      STM
  m
  [(CoreNodeId, m (NodeInfo blk MockFS []), Chain blk,
    LedgerState blk)]
-> m [(CoreNodeId, m (NodeInfo blk MockFS []), Chain blk,
       LedgerState blk)]
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM
   m
   [(CoreNodeId, m (NodeInfo blk MockFS []), Chain blk,
     LedgerState blk)]
 -> m [(CoreNodeId, m (NodeInfo blk MockFS []), Chain blk,
        LedgerState blk)])
-> STM
     m
     [(CoreNodeId, m (NodeInfo blk MockFS []), Chain blk,
       LedgerState blk)]
-> m [(CoreNodeId, m (NodeInfo blk MockFS []), Chain blk,
       LedgerState blk)]
forall a b. (a -> b) -> a -> b
$
      [(CoreNodeId, StrictTVar m (VertexStatus m blk),
  m (NodeInfo blk MockFS []))]
-> ((CoreNodeId, StrictTVar m (VertexStatus m blk),
     m (NodeInfo blk MockFS []))
    -> STM
         m
         (CoreNodeId, m (NodeInfo blk MockFS []), Chain blk,
          LedgerState blk))
-> STM
     m
     [(CoreNodeId, m (NodeInfo blk MockFS []), Chain blk,
       LedgerState blk)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(CoreNodeId, StrictTVar m (VertexStatus m blk),
  m (NodeInfo blk MockFS []))]
vertexInfos0 (((CoreNodeId, StrictTVar m (VertexStatus m blk),
   m (NodeInfo blk MockFS []))
  -> STM
       m
       (CoreNodeId, m (NodeInfo blk MockFS []), Chain blk,
        LedgerState blk))
 -> STM
      m
      [(CoreNodeId, m (NodeInfo blk MockFS []), Chain blk,
        LedgerState blk)])
-> ((CoreNodeId, StrictTVar m (VertexStatus m blk),
     m (NodeInfo blk MockFS []))
    -> STM
         m
         (CoreNodeId, m (NodeInfo blk MockFS []), Chain blk,
          LedgerState blk))
-> STM
     m
     [(CoreNodeId, m (NodeInfo blk MockFS []), Chain blk,
       LedgerState blk)]
forall a b. (a -> b) -> a -> b
$ \(CoreNodeId
coreNodeId, StrictTVar m (VertexStatus m blk)
vertexStatusVar, m (NodeInfo blk MockFS [])
readNodeInfo) -> do
        StrictTVar m (VertexStatus m blk) -> STM m (VertexStatus m blk)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (VertexStatus m blk)
vertexStatusVar STM m (VertexStatus m blk)
-> (VertexStatus m blk
    -> STM
         m
         (CoreNodeId, m (NodeInfo blk MockFS []), Chain blk,
          LedgerState blk))
-> STM
     m
     (CoreNodeId, m (NodeInfo blk MockFS []), Chain blk,
      LedgerState blk)
forall a b. STM m a -> (a -> STM m b) -> STM m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          VDown Chain blk
ch LedgerState blk
ldgr -> (CoreNodeId, m (NodeInfo blk MockFS []), Chain blk,
 LedgerState blk)
-> STM
     m
     (CoreNodeId, m (NodeInfo blk MockFS []), Chain blk,
      LedgerState blk)
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CoreNodeId
coreNodeId, m (NodeInfo blk MockFS [])
readNodeInfo, Chain blk
ch, LedgerState blk
ldgr)
          VertexStatus m blk
_             -> STM
  m
  (CoreNodeId, m (NodeInfo blk MockFS []), Chain blk,
   LedgerState blk)
forall a. STM m a
forall (m :: * -> *) a. MonadSTM m => STM m a
retry

    [(CoreNodeId, m (NodeInfo blk MockFS []), Chain blk,
  LedgerState blk)]
-> m (TestOutput blk)
forall (m :: * -> *) blk.
(IOLike m, HasHeader blk) =>
[(CoreNodeId, m (NodeInfo blk MockFS []), Chain blk,
  LedgerState blk)]
-> m (TestOutput blk)
mkTestOutput [(CoreNodeId, m (NodeInfo blk MockFS []), Chain blk,
  LedgerState blk)]
vertexInfos
  where
    ()
_ = Proxy (Show (LedgerView (BlockProtocol blk))) -> ()
forall (c :: Constraint) (proxy :: Constraint -> *).
c =>
proxy c -> ()
keepRedundantConstraint (forall {k} (t :: k). Proxy t
forall (t :: Constraint). Proxy t
Proxy @(Show (LedgerView (BlockProtocol blk))))

    -- epoch size of the first era (ie the one that might have EBBs)
    epochSize0 :: EpochSize
    epochSize0 :: EpochSize
epochSize0 = Future -> EpochSize
HFF.futureFirstEpochSize Future
future

    coreNodeIds :: [CoreNodeId]
    coreNodeIds :: [CoreNodeId]
coreNodeIds = NumCoreNodes -> [CoreNodeId]
enumCoreNodes NumCoreNodes
numCoreNodes

    joinSlotOf :: CoreNodeId -> SlotNo
    joinSlotOf :: CoreNodeId -> SlotNo
joinSlotOf = HasCallStack => NodeJoinPlan -> CoreNodeId -> SlotNo
NodeJoinPlan -> CoreNodeId -> SlotNo
coreNodeIdJoinSlot NodeJoinPlan
nodeJoinPlan

    forkVertex
      :: Maybe (RekeyM m blk)
      -> OracularClock m
      -> SlotNo
      -> ResourceRegistry m
      -> CoreNodeId
      -> VertexStatusVar m blk
      -> [EdgeStatusVar m]
      -> NodeInfo blk (StrictTMVar m MockFS) (Tracer m)
      -> StrictTVar m SlotNo
      -> m ()
    forkVertex :: Maybe (RekeyM m blk)
-> OracularClock m
-> SlotNo
-> ResourceRegistry m
-> CoreNodeId
-> StrictTVar m (VertexStatus m blk)
-> [EdgeStatusVar m]
-> NodeInfo blk (StrictTMVar m MockFS) (Tracer m)
-> StrictTVar m SlotNo
-> m ()
forkVertex
      Maybe (RekeyM m blk)
mbRekeyM
      OracularClock m
clock
      SlotNo
joinSlot
      ResourceRegistry m
sharedRegistry
      CoreNodeId
coreNodeId
      StrictTVar m (VertexStatus m blk)
vertexStatusVar
      [EdgeStatusVar m]
edgeStatusVars
      NodeInfo blk (StrictTMVar m MockFS) (Tracer m)
nodeInfo
      StrictTVar m SlotNo
nextInstrSlotVar =
        m (Thread m ()) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (Thread m ()) -> m ()) -> m (Thread m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ ResourceRegistry m -> String -> m () -> m (Thread m ())
forall (m :: * -> *) a.
(MonadAsync m, MonadFork m, MonadMask m, HasCallStack) =>
ResourceRegistry m -> String -> m a -> m (Thread m a)
forkLinkedThread ResourceRegistry m
sharedRegistry String
label (m () -> m (Thread m ())) -> m () -> m (Thread m ())
forall a b. (a -> b) -> a -> b
$ do
          SlotNo
-> ProtocolInfo blk
-> m [BlockForging m blk]
-> NodeRestart
-> Map SlotNo NodeRestart
-> m ()
loop SlotNo
0 ProtocolInfo blk
tniProtocolInfo m [BlockForging m blk]
tniBlockForging NodeRestart
NodeRestart Map SlotNo NodeRestart
restarts0
      where
        label :: String
label = String
"vertex-" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> CoreNodeId -> String
forall a. Condense a => a -> String
condense CoreNodeId
coreNodeId

        TestNodeInitialization
           { [GenTx blk]
tniCrucialTxs :: forall (m :: * -> *) blk.
TestNodeInitialization m blk -> [GenTx blk]
tniCrucialTxs :: [GenTx blk]
tniCrucialTxs
           , ProtocolInfo blk
tniProtocolInfo :: forall (m :: * -> *) blk.
TestNodeInitialization m blk -> ProtocolInfo blk
tniProtocolInfo :: ProtocolInfo blk
tniProtocolInfo
           , m [BlockForging m blk]
tniBlockForging :: forall (m :: * -> *) blk.
TestNodeInitialization m blk -> m [BlockForging m blk]
tniBlockForging :: m [BlockForging m blk]
tniBlockForging
           } = CoreNodeId -> TestNodeInitialization m blk
mkProtocolInfo CoreNodeId
coreNodeId

        restarts0 :: Map SlotNo NodeRestart
        restarts0 :: Map SlotNo NodeRestart
restarts0 = (Map CoreNodeId NodeRestart -> Maybe NodeRestart)
-> Map SlotNo (Map CoreNodeId NodeRestart)
-> Map SlotNo NodeRestart
forall a b k. (a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybe (CoreNodeId -> Map CoreNodeId NodeRestart -> Maybe NodeRestart
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup CoreNodeId
coreNodeId) Map SlotNo (Map CoreNodeId NodeRestart)
m
          where
            NodeRestarts Map SlotNo (Map CoreNodeId NodeRestart)
m = NodeRestarts
nodeRestarts

        loop :: SlotNo
             -> ProtocolInfo blk
             -> m [BlockForging m blk]
             -> NodeRestart
             -> Map SlotNo NodeRestart -> m ()
        loop :: SlotNo
-> ProtocolInfo blk
-> m [BlockForging m blk]
-> NodeRestart
-> Map SlotNo NodeRestart
-> m ()
loop SlotNo
s ProtocolInfo blk
pInfo m [BlockForging m blk]
blockForging NodeRestart
nr Map SlotNo NodeRestart
rs = do
          -- a registry solely for the resources of this specific node instance
          (Maybe
  (SlotNo, ProtocolInfo blk, m [BlockForging m blk], NodeRestart,
   Map SlotNo NodeRestart)
again, Chain blk
finalChain, LedgerState blk
finalLdgr) <- (ResourceRegistry m
 -> m (Maybe
         (SlotNo, ProtocolInfo blk, m [BlockForging m blk], NodeRestart,
          Map SlotNo NodeRestart),
       Chain blk, LedgerState blk))
-> m (Maybe
        (SlotNo, ProtocolInfo blk, m [BlockForging m blk], NodeRestart,
         Map SlotNo NodeRestart),
      Chain blk, LedgerState blk)
forall (m :: * -> *) a.
(MonadSTM m, MonadMask m, MonadThread m, HasCallStack) =>
(ResourceRegistry m -> m a) -> m a
withRegistry ((ResourceRegistry m
  -> m (Maybe
          (SlotNo, ProtocolInfo blk, m [BlockForging m blk], NodeRestart,
           Map SlotNo NodeRestart),
        Chain blk, LedgerState blk))
 -> m (Maybe
         (SlotNo, ProtocolInfo blk, m [BlockForging m blk], NodeRestart,
          Map SlotNo NodeRestart),
       Chain blk, LedgerState blk))
-> (ResourceRegistry m
    -> m (Maybe
            (SlotNo, ProtocolInfo blk, m [BlockForging m blk], NodeRestart,
             Map SlotNo NodeRestart),
          Chain blk, LedgerState blk))
-> m (Maybe
        (SlotNo, ProtocolInfo blk, m [BlockForging m blk], NodeRestart,
         Map SlotNo NodeRestart),
      Chain blk, LedgerState blk)
forall a b. (a -> b) -> a -> b
$ \ResourceRegistry m
nodeRegistry -> do
            -- change the node's key and prepare a delegation transaction if
            -- the node is restarting because it just rekeyed
            TestNodeInitialization m blk
tni' <- case (NodeRestart
nr, Maybe (RekeyM m blk)
mbRekeyM) of
              (NodeRestart
NodeRekey, Just RekeyM m blk
rekeyM) -> do
                RekeyM m blk
rekeyM CoreNodeId
coreNodeId ProtocolInfo blk
pInfo m [BlockForging m blk]
blockForging SlotNo
s (EpochNo -> m EpochNo
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EpochNo -> m EpochNo)
-> (SlotNo -> EpochNo) -> SlotNo -> m EpochNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Future -> SlotNo -> EpochNo
HFF.futureSlotToEpoch Future
future)
              (NodeRestart, Maybe (RekeyM m blk))
_                        ->
                  TestNodeInitialization m blk -> m (TestNodeInitialization m blk)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TestNodeInitialization m blk -> m (TestNodeInitialization m blk))
-> TestNodeInitialization m blk -> m (TestNodeInitialization m blk)
forall a b. (a -> b) -> a -> b
$ ProtocolInfo blk
-> m [BlockForging m blk] -> TestNodeInitialization m blk
forall blk (m :: * -> *).
ProtocolInfo blk
-> m [BlockForging m blk] -> TestNodeInitialization m blk
plainTestNodeInitialization ProtocolInfo blk
pInfo m [BlockForging m blk]
blockForging
            let TestNodeInitialization
                  { tniCrucialTxs :: forall (m :: * -> *) blk.
TestNodeInitialization m blk -> [GenTx blk]
tniCrucialTxs   = [GenTx blk]
crucialTxs'
                  , tniProtocolInfo :: forall (m :: * -> *) blk.
TestNodeInitialization m blk -> ProtocolInfo blk
tniProtocolInfo = ProtocolInfo blk
pInfo'
                  , tniBlockForging :: forall (m :: * -> *) blk.
TestNodeInitialization m blk -> m [BlockForging m blk]
tniBlockForging = m [BlockForging m blk]
blockForging'
                  } = TestNodeInitialization m blk
tni'

            -- allocate the node's internal state and fork its internal threads
            -- (specifically not the communication threads running the Mini
            -- Protocols, like the ChainSync Client)
            (NodeKernel m NodeId Void blk
kernel, LimitedApp m NodeId blk
app) <- HasCallStack =>
CoreNodeId
-> OracularClock m
-> SlotNo
-> ResourceRegistry m
-> ProtocolInfo blk
-> m [BlockForging m blk]
-> NodeInfo blk (StrictTMVar m MockFS) (Tracer m)
-> [GenTx blk]
-> m (NodeKernel m NodeId Void blk, LimitedApp m NodeId blk)
CoreNodeId
-> OracularClock m
-> SlotNo
-> ResourceRegistry m
-> ProtocolInfo blk
-> m [BlockForging m blk]
-> NodeInfo blk (StrictTMVar m MockFS) (Tracer m)
-> [GenTx blk]
-> m (NodeKernel m NodeId Void blk, LimitedApp m NodeId blk)
forkNode
              CoreNodeId
coreNodeId
              OracularClock m
clock
              SlotNo
joinSlot
              ResourceRegistry m
nodeRegistry
              ProtocolInfo blk
pInfo'
              m [BlockForging m blk]
blockForging'
              NodeInfo blk (StrictTMVar m MockFS) (Tracer m)
nodeInfo
              ([GenTx blk]
crucialTxs' [GenTx blk] -> [GenTx blk] -> [GenTx blk]
forall a. [a] -> [a] -> [a]
++ [GenTx blk]
tniCrucialTxs)
            STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ StrictTVar m (VertexStatus m blk) -> VertexStatus m blk -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (VertexStatus m blk)
vertexStatusVar (VertexStatus m blk -> STM m ()) -> VertexStatus m blk -> STM m ()
forall a b. (a -> b) -> a -> b
$ NodeKernel m NodeId Void blk
-> LimitedApp m NodeId blk -> VertexStatus m blk
forall (m :: * -> *) blk.
NodeKernel m NodeId Void blk
-> LimitedApp m NodeId blk -> VertexStatus m blk
VUp NodeKernel m NodeId Void blk
kernel LimitedApp m NodeId blk
app

            -- wait until this node instance should stop
            Maybe
  (SlotNo, ProtocolInfo blk, m [BlockForging m blk], NodeRestart,
   Map SlotNo NodeRestart)
again <- case Map SlotNo NodeRestart
-> Maybe ((SlotNo, NodeRestart), Map SlotNo NodeRestart)
forall k a. Map k a -> Maybe ((k, a), Map k a)
Map.minViewWithKey Map SlotNo NodeRestart
rs of
              -- end of test
              Maybe ((SlotNo, NodeRestart), Map SlotNo NodeRestart)
Nothing               -> do
                OracularClock m -> m ()
forall (m :: * -> *). OracularClock m -> m ()
OracularClock.waitUntilDone OracularClock m
clock
                Maybe
  (SlotNo, ProtocolInfo blk, m [BlockForging m blk], NodeRestart,
   Map SlotNo NodeRestart)
-> m (Maybe
        (SlotNo, ProtocolInfo blk, m [BlockForging m blk], NodeRestart,
         Map SlotNo NodeRestart))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe
  (SlotNo, ProtocolInfo blk, m [BlockForging m blk], NodeRestart,
   Map SlotNo NodeRestart)
forall a. Maybe a
Nothing
              -- onset of schedule restart slot
              Just ((SlotNo
s', NodeRestart
nr'), Map SlotNo NodeRestart
rs') -> do
                -- wait until the node should stop
                Bool
tooLate <- OracularClock m -> SlotNo -> m Bool
forall (m :: * -> *). OracularClock m -> SlotNo -> m Bool
OracularClock.blockUntilSlot OracularClock m
clock SlotNo
s'
                Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
tooLate (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
                  String -> m ()
forall a. HasCallStack => String -> a
error (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"unsatisfiable nodeRestarts: "
                    String -> ShowS
forall a. [a] -> [a] -> [a]
++ (CoreNodeId, SlotNo) -> String
forall a. Show a => a -> String
show (CoreNodeId
coreNodeId, SlotNo
s')

                -- this synchronization prevents a race with the
                -- instrumentation thread: we it want to record the current
                -- block number at the start of the slot, before this vertex
                -- restarts the node
                STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
                  SlotNo
nextSlot <- StrictTVar m SlotNo -> STM m SlotNo
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m SlotNo
nextInstrSlotVar
                  Bool -> STM m ()
forall (m :: * -> *). MonadSTM m => Bool -> STM m ()
check (Bool -> STM m ()) -> Bool -> STM m ()
forall a b. (a -> b) -> a -> b
$ SlotNo
nextSlot SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
> SlotNo
s'

                Maybe
  (SlotNo, ProtocolInfo blk, m [BlockForging m blk], NodeRestart,
   Map SlotNo NodeRestart)
-> m (Maybe
        (SlotNo, ProtocolInfo blk, m [BlockForging m blk], NodeRestart,
         Map SlotNo NodeRestart))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe
   (SlotNo, ProtocolInfo blk, m [BlockForging m blk], NodeRestart,
    Map SlotNo NodeRestart)
 -> m (Maybe
         (SlotNo, ProtocolInfo blk, m [BlockForging m blk], NodeRestart,
          Map SlotNo NodeRestart)))
-> Maybe
     (SlotNo, ProtocolInfo blk, m [BlockForging m blk], NodeRestart,
      Map SlotNo NodeRestart)
-> m (Maybe
        (SlotNo, ProtocolInfo blk, m [BlockForging m blk], NodeRestart,
         Map SlotNo NodeRestart))
forall a b. (a -> b) -> a -> b
$ (SlotNo, ProtocolInfo blk, m [BlockForging m blk], NodeRestart,
 Map SlotNo NodeRestart)
-> Maybe
     (SlotNo, ProtocolInfo blk, m [BlockForging m blk], NodeRestart,
      Map SlotNo NodeRestart)
forall a. a -> Maybe a
Just (SlotNo
s', ProtocolInfo blk
pInfo', m [BlockForging m blk]
blockForging', NodeRestart
nr', Map SlotNo NodeRestart
rs')

            -- stop threads that depend on/stimulate the kernel
            STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ StrictTVar m (VertexStatus m blk) -> VertexStatus m blk -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (VertexStatus m blk)
vertexStatusVar VertexStatus m blk
forall (m :: * -> *) blk. VertexStatus m blk
VFalling
            [EdgeStatusVar m] -> (EdgeStatusVar m -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [EdgeStatusVar m]
edgeStatusVars ((EdgeStatusVar m -> m ()) -> m ())
-> (EdgeStatusVar m -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \EdgeStatusVar m
edgeStatusVar -> STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
              EdgeStatusVar m -> STM m EdgeStatus
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar EdgeStatusVar m
edgeStatusVar STM m EdgeStatus -> (EdgeStatus -> STM m ()) -> STM m ()
forall a b. STM m a -> (a -> STM m b) -> STM m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> STM m ()
forall (m :: * -> *). MonadSTM m => Bool -> STM m ()
check (Bool -> STM m ())
-> (EdgeStatus -> Bool) -> EdgeStatus -> STM m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (EdgeStatus -> EdgeStatus -> Bool
forall a. Eq a => a -> a -> Bool
== EdgeStatus
EDown)

            -- assuming nothing else is changing it, read the final chain
            let chainDB :: ChainDB m blk
chainDB = NodeKernel m NodeId Void blk -> ChainDB m blk
forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernel m addrNTN addrNTC blk -> ChainDB m blk
getChainDB NodeKernel m NodeId Void blk
kernel
            ExtLedgerState{LedgerState blk
ledgerState :: forall blk. ExtLedgerState blk -> LedgerState blk
ledgerState :: LedgerState blk
ledgerState} <- STM m (ExtLedgerState blk) -> m (ExtLedgerState blk)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (ExtLedgerState blk) -> m (ExtLedgerState blk))
-> STM m (ExtLedgerState blk) -> m (ExtLedgerState blk)
forall a b. (a -> b) -> a -> b
$
              ChainDB m blk -> STM m (ExtLedgerState blk)
forall (m :: * -> *) blk.
(Monad (STM m), IsLedger (LedgerState blk)) =>
ChainDB m blk -> STM m (ExtLedgerState blk)
ChainDB.getCurrentLedger ChainDB m blk
chainDB
            Chain blk
finalChain <- ChainDB m blk -> m (Chain blk)
forall (m :: * -> *) blk.
(HasCallStack, IOLike m, HasHeader blk) =>
ChainDB m blk -> m (Chain blk)
ChainDB.toChain ChainDB m blk
chainDB

            (Maybe
   (SlotNo, ProtocolInfo blk, m [BlockForging m blk], NodeRestart,
    Map SlotNo NodeRestart),
 Chain blk, LedgerState blk)
-> m (Maybe
        (SlotNo, ProtocolInfo blk, m [BlockForging m blk], NodeRestart,
         Map SlotNo NodeRestart),
      Chain blk, LedgerState blk)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe
  (SlotNo, ProtocolInfo blk, m [BlockForging m blk], NodeRestart,
   Map SlotNo NodeRestart)
again, Chain blk
finalChain, LedgerState blk
ledgerState)
            -- end of the node's withRegistry

          STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ StrictTVar m (VertexStatus m blk) -> VertexStatus m blk -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (VertexStatus m blk)
vertexStatusVar (VertexStatus m blk -> STM m ()) -> VertexStatus m blk -> STM m ()
forall a b. (a -> b) -> a -> b
$
            Chain blk -> LedgerState blk -> VertexStatus m blk
forall (m :: * -> *) blk.
Chain blk -> LedgerState blk -> VertexStatus m blk
VDown Chain blk
finalChain LedgerState blk
finalLdgr

          case Maybe
  (SlotNo, ProtocolInfo blk, m [BlockForging m blk], NodeRestart,
   Map SlotNo NodeRestart)
again of
            Maybe
  (SlotNo, ProtocolInfo blk, m [BlockForging m blk], NodeRestart,
   Map SlotNo NodeRestart)
Nothing                                    -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            Just (SlotNo
s', ProtocolInfo blk
pInfo', m [BlockForging m blk]
blockForging', NodeRestart
nr', Map SlotNo NodeRestart
rs') -> SlotNo
-> ProtocolInfo blk
-> m [BlockForging m blk]
-> NodeRestart
-> Map SlotNo NodeRestart
-> m ()
loop SlotNo
s' ProtocolInfo blk
pInfo' m [BlockForging m blk]
blockForging' NodeRestart
nr' Map SlotNo NodeRestart
rs'

    -- | Instrumentation: record the tip's block number at the onset of the
    -- slot.
    --
    -- With such a short transaction (read a few TVars) we assume this runs (1)
    -- before anything else in the slot and (2) once per slot.
    forkInstrumentation
      :: OracularClock m
      -> ResourceRegistry m
      -> VertexStatusVar m blk
      -> NodeInfo blk (StrictTMVar m MockFS) (Tracer m)
      -> StrictTVar m SlotNo
      -> m ()
    forkInstrumentation :: OracularClock m
-> ResourceRegistry m
-> StrictTVar m (VertexStatus m blk)
-> NodeInfo blk (StrictTMVar m MockFS) (Tracer m)
-> StrictTVar m SlotNo
-> m ()
forkInstrumentation
      OracularClock m
clock
      ResourceRegistry m
registry
      StrictTVar m (VertexStatus m blk)
vertexStatusVar
      NodeInfo blk (StrictTMVar m MockFS) (Tracer m)
nodeInfo
      StrictTVar m SlotNo
nextInstrSlotVar =
        m (m ()) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (m ()) -> m ()) -> m (m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ ResourceRegistry m
-> OracularClock m -> String -> (SlotNo -> m ()) -> m (m ())
forall (m :: * -> *).
HasCallStack =>
ResourceRegistry m
-> OracularClock m -> String -> (SlotNo -> m ()) -> m (m ())
OracularClock.forkEachSlot ResourceRegistry m
registry OracularClock m
clock String
lbl ((SlotNo -> m ()) -> m (m ())) -> (SlotNo -> m ()) -> m (m ())
forall a b. (a -> b) -> a -> b
$ \SlotNo
s -> do
          WithOrigin BlockNo
bno <- STM m (WithOrigin BlockNo) -> m (WithOrigin BlockNo)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (WithOrigin BlockNo) -> m (WithOrigin BlockNo))
-> STM m (WithOrigin BlockNo) -> m (WithOrigin BlockNo)
forall a b. (a -> b) -> a -> b
$ StrictTVar m (VertexStatus m blk) -> STM m (VertexStatus m blk)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (VertexStatus m blk)
vertexStatusVar STM m (VertexStatus m blk)
-> (VertexStatus m blk -> STM m (WithOrigin BlockNo))
-> STM m (WithOrigin BlockNo)
forall a b. STM m a -> (a -> STM m b) -> STM m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            VUp NodeKernel m NodeId Void blk
kernel LimitedApp m NodeId blk
_ -> ChainDB m blk -> STM m (WithOrigin BlockNo)
forall (m :: * -> *) blk.
(Monad (STM m), HasHeader (Header blk)) =>
ChainDB m blk -> STM m (WithOrigin BlockNo)
ChainDB.getTipBlockNo (NodeKernel m NodeId Void blk -> ChainDB m blk
forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernel m addrNTN addrNTC blk -> ChainDB m blk
getChainDB NodeKernel m NodeId Void blk
kernel)
            VertexStatus m blk
_            -> STM m (WithOrigin BlockNo)
forall a. STM m a
forall (m :: * -> *) a. MonadSTM m => STM m a
retry
          Tracer m (SlotNo, WithOrigin BlockNo)
-> (SlotNo, WithOrigin BlockNo) -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (SlotNo, WithOrigin BlockNo)
nodeEventsTipBlockNos (SlotNo
s, WithOrigin BlockNo
bno)
          STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ StrictTVar m SlotNo -> (SlotNo -> SlotNo) -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar StrictTVar m SlotNo
nextInstrSlotVar ((SlotNo -> SlotNo) -> STM m ()) -> (SlotNo -> SlotNo) -> STM m ()
forall a b. (a -> b) -> a -> b
$ SlotNo -> SlotNo -> SlotNo
forall a. Ord a => a -> a -> a
max (SlotNo -> SlotNo
forall a. Enum a => a -> a
succ SlotNo
s)
      where
        NodeInfo{NodeEvents blk (Tracer m)
nodeInfoEvents :: NodeEvents blk (Tracer m)
nodeInfoEvents :: forall blk db (ev :: * -> *).
NodeInfo blk db ev -> NodeEvents blk ev
nodeInfoEvents}          = NodeInfo blk (StrictTMVar m MockFS) (Tracer m)
nodeInfo
        NodeEvents{Tracer m (SlotNo, WithOrigin BlockNo)
nodeEventsTipBlockNos :: Tracer m (SlotNo, WithOrigin BlockNo)
nodeEventsTipBlockNos :: forall blk (ev :: * -> *).
NodeEvents blk ev -> ev (SlotNo, WithOrigin BlockNo)
nodeEventsTipBlockNos} = NodeEvents blk (Tracer m)
nodeInfoEvents
        lbl :: String
lbl                               = String
"instrumentation"

    -- | Persistently attempt to add the given transactions to the mempool
    -- every time the ledger slot changes, even if successful!
    --
    -- If we add the transaction and then the mempools discards it for some
    -- reason, this thread will add it again.
    --
    forkCrucialTxs
      :: HasCallStack
      => OracularClock m
      -> SlotNo
      -> ResourceRegistry m
      -> (SlotNo -> STM m ())
      -> LedgerConfig blk
      -> STM m (LedgerState blk)
      -> Mempool m blk
      -> [GenTx blk]
         -- ^ valid transactions the node should immediately propagate
      -> m ()
    forkCrucialTxs :: HasCallStack =>
OracularClock m
-> SlotNo
-> ResourceRegistry m
-> (SlotNo -> STM m ())
-> LedgerConfig blk
-> STM m (LedgerState blk)
-> Mempool m blk
-> [GenTx blk]
-> m ()
forkCrucialTxs OracularClock m
clock SlotNo
s0 ResourceRegistry m
registry SlotNo -> STM m ()
unblockForge LedgerConfig blk
lcfg STM m (LedgerState blk)
getLdgr Mempool m blk
mempool [GenTx blk]
txs0 =
      m (Thread m Any) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (Thread m Any) -> m ()) -> m (Thread m Any) -> m ()
forall a b. (a -> b) -> a -> b
$ ResourceRegistry m -> String -> m Any -> m (Thread m Any)
forall (m :: * -> *) a.
(MonadAsync m, MonadFork m, MonadMask m, HasCallStack) =>
ResourceRegistry m -> String -> m a -> m (Thread m a)
forkLinkedThread ResourceRegistry m
registry String
"crucialTxs" (m Any -> m (Thread m Any)) -> m Any -> m (Thread m Any)
forall a b. (a -> b) -> a -> b
$ do
        let wouldBeValid :: SlotNo -> Ticked (LedgerState blk) -> GenTx blk -> Bool
wouldBeValid SlotNo
slot Ticked (LedgerState blk)
st GenTx blk
tx =
                Either
  (ApplyTxErr blk) (Ticked (LedgerState blk), Validated (GenTx blk))
-> Bool
forall a b. Either a b -> Bool
isRight (Either
   (ApplyTxErr blk) (Ticked (LedgerState blk), Validated (GenTx blk))
 -> Bool)
-> Either
     (ApplyTxErr blk) (Ticked (LedgerState blk), Validated (GenTx blk))
-> Bool
forall a b. (a -> b) -> a -> b
$ Except
  (ApplyTxErr blk) (Ticked (LedgerState blk), Validated (GenTx blk))
-> Either
     (ApplyTxErr blk) (Ticked (LedgerState blk), Validated (GenTx blk))
forall e a. Except e a -> Either e a
Exc.runExcept (Except
   (ApplyTxErr blk) (Ticked (LedgerState blk), Validated (GenTx blk))
 -> Either
      (ApplyTxErr blk) (Ticked (LedgerState blk), Validated (GenTx blk)))
-> Except
     (ApplyTxErr blk) (Ticked (LedgerState blk), Validated (GenTx blk))
-> Either
     (ApplyTxErr blk) (Ticked (LedgerState blk), Validated (GenTx blk))
forall a b. (a -> b) -> a -> b
$ LedgerConfig blk
-> WhetherToIntervene
-> SlotNo
-> GenTx blk
-> Ticked (LedgerState blk)
-> Except
     (ApplyTxErr blk) (Ticked (LedgerState blk), Validated (GenTx blk))
forall blk.
LedgerSupportsMempool blk =>
LedgerConfig blk
-> WhetherToIntervene
-> SlotNo
-> GenTx blk
-> TickedLedgerState blk
-> Except
     (ApplyTxErr blk) (TickedLedgerState blk, Validated (GenTx blk))
applyTx LedgerConfig blk
lcfg WhetherToIntervene
DoNotIntervene SlotNo
slot GenTx blk
tx Ticked (LedgerState blk)
st

            checkSt :: SlotNo -> MempoolSnapshot blk -> Bool
checkSt SlotNo
slot MempoolSnapshot blk
snap =
                (GenTx blk -> Bool) -> [GenTx blk] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (SlotNo -> Ticked (LedgerState blk) -> GenTx blk -> Bool
wouldBeValid SlotNo
slot (MempoolSnapshot blk -> Ticked (LedgerState blk)
forall blk. MempoolSnapshot blk -> TickedLedgerState blk
snapshotLedgerState MempoolSnapshot blk
snap)) [GenTx blk]
txs0

        let loop :: (SlotNo, LedgerState blk, [TicketNo]) -> m Any
loop (SlotNo
slot, LedgerState blk
ledger, [TicketNo]
mempFp) = do
              (MempoolSnapshot blk
snap1, MempoolSnapshot blk
snap2) <- STM m (MempoolSnapshot blk, MempoolSnapshot blk)
-> m (MempoolSnapshot blk, MempoolSnapshot blk)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (MempoolSnapshot blk, MempoolSnapshot blk)
 -> m (MempoolSnapshot blk, MempoolSnapshot blk))
-> STM m (MempoolSnapshot blk, MempoolSnapshot blk)
-> m (MempoolSnapshot blk, MempoolSnapshot blk)
forall a b. (a -> b) -> a -> b
$ do
                MempoolSnapshot blk
snap1 <- Mempool m blk
-> ForgeLedgerState blk -> STM m (MempoolSnapshot blk)
forall (m :: * -> *) blk.
Mempool m blk
-> ForgeLedgerState blk -> STM m (MempoolSnapshot blk)
getSnapshotFor Mempool m blk
mempool (ForgeLedgerState blk -> STM m (MempoolSnapshot blk))
-> ForgeLedgerState blk -> STM m (MempoolSnapshot blk)
forall a b. (a -> b) -> a -> b
$
                  -- This node would include these crucial txs if it leads in
                  -- this slot.
                  SlotNo -> Ticked (LedgerState blk) -> ForgeLedgerState blk
forall blk. SlotNo -> TickedLedgerState blk -> ForgeLedgerState blk
ForgeInKnownSlot SlotNo
slot (Ticked (LedgerState blk) -> ForgeLedgerState blk)
-> Ticked (LedgerState blk) -> ForgeLedgerState blk
forall a b. (a -> b) -> a -> b
$ LedgerConfig blk
-> SlotNo -> LedgerState blk -> Ticked (LedgerState blk)
forall l. IsLedger l => LedgerCfg l -> SlotNo -> l -> Ticked l
applyChainTick LedgerConfig blk
lcfg SlotNo
slot LedgerState blk
ledger
                MempoolSnapshot blk
snap2 <- Mempool m blk
-> ForgeLedgerState blk -> STM m (MempoolSnapshot blk)
forall (m :: * -> *) blk.
Mempool m blk
-> ForgeLedgerState blk -> STM m (MempoolSnapshot blk)
getSnapshotFor Mempool m blk
mempool (ForgeLedgerState blk -> STM m (MempoolSnapshot blk))
-> ForgeLedgerState blk -> STM m (MempoolSnapshot blk)
forall a b. (a -> b) -> a -> b
$
                  -- Other nodes might include these crucial txs when leading
                  -- in the next slot.
                  SlotNo -> Ticked (LedgerState blk) -> ForgeLedgerState blk
forall blk. SlotNo -> TickedLedgerState blk -> ForgeLedgerState blk
ForgeInKnownSlot (SlotNo -> SlotNo
forall a. Enum a => a -> a
succ SlotNo
slot) (Ticked (LedgerState blk) -> ForgeLedgerState blk)
-> Ticked (LedgerState blk) -> ForgeLedgerState blk
forall a b. (a -> b) -> a -> b
$ LedgerConfig blk
-> SlotNo -> LedgerState blk -> Ticked (LedgerState blk)
forall l. IsLedger l => LedgerCfg l -> SlotNo -> l -> Ticked l
applyChainTick LedgerConfig blk
lcfg (SlotNo -> SlotNo
forall a. Enum a => a -> a
succ SlotNo
slot) LedgerState blk
ledger
                -- This loop will repeat for the next slot, so we only need to
                -- check for this one and the next.
                (MempoolSnapshot blk, MempoolSnapshot blk)
-> STM m (MempoolSnapshot blk, MempoolSnapshot blk)
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MempoolSnapshot blk
snap1, MempoolSnapshot blk
snap2)

              -- Don't attempt to add them if we're sure they'll be invalid.
              -- That just risks blocking on a full mempool unnecessarily.
              Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SlotNo -> MempoolSnapshot blk -> Bool
checkSt SlotNo
slot MempoolSnapshot blk
snap1 Bool -> Bool -> Bool
|| SlotNo -> MempoolSnapshot blk -> Bool
checkSt (SlotNo -> SlotNo
forall a. Enum a => a -> a
succ SlotNo
slot) MempoolSnapshot blk
snap2) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
                [MempoolAddTxResult blk]
_ <- Mempool m blk -> [GenTx blk] -> m [MempoolAddTxResult blk]
forall (m :: * -> *) blk (t :: * -> *).
(MonadSTM m, Traversable t) =>
Mempool m blk -> t (GenTx blk) -> m (t (MempoolAddTxResult blk))
addTxs Mempool m blk
mempool [GenTx blk]
txs0
                () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

              -- See 'unblockForge' in 'forkNode'
              STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ SlotNo -> STM m ()
unblockForge SlotNo
slot

              let
                -- a clock tick might render a crucial transaction valid
                slotChanged :: m (SlotNo, LedgerState blk, [TicketNo])
slotChanged = do
                  let slot' :: SlotNo
slot' = SlotNo -> SlotNo
forall a. Enum a => a -> a
succ SlotNo
slot
                  Bool
_ <- OracularClock m -> SlotNo -> m Bool
forall (m :: * -> *). OracularClock m -> SlotNo -> m Bool
OracularClock.blockUntilSlot OracularClock m
clock SlotNo
slot'
                  (SlotNo, LedgerState blk, [TicketNo])
-> m (SlotNo, LedgerState blk, [TicketNo])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SlotNo
slot', LedgerState blk
ledger, [TicketNo]
mempFp)

                -- a new tx (e.g. added by TxSubmission) might render a crucial
                -- transaction valid
                mempChanged :: m (SlotNo, LedgerState blk, [TicketNo])
mempChanged = do
                  let prjTno :: (a, TicketNo, c) -> TicketNo
prjTno (a
_a, TicketNo
b, c
_c) = TicketNo
b :: TicketNo
                      getMemp :: STM m [TicketNo]
getMemp = (((Validated (GenTx blk), TicketNo, ByteSize32) -> TicketNo)
-> [(Validated (GenTx blk), TicketNo, ByteSize32)] -> [TicketNo]
forall a b. (a -> b) -> [a] -> [b]
map (Validated (GenTx blk), TicketNo, ByteSize32) -> TicketNo
forall {a} {c}. (a, TicketNo, c) -> TicketNo
prjTno ([(Validated (GenTx blk), TicketNo, ByteSize32)] -> [TicketNo])
-> (MempoolSnapshot blk
    -> [(Validated (GenTx blk), TicketNo, ByteSize32)])
-> MempoolSnapshot blk
-> [TicketNo]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MempoolSnapshot blk
-> [(Validated (GenTx blk), TicketNo, ByteSize32)]
forall blk.
MempoolSnapshot blk
-> [(Validated (GenTx blk), TicketNo, ByteSize32)]
snapshotTxs) (MempoolSnapshot blk -> [TicketNo])
-> STM m (MempoolSnapshot blk) -> STM m [TicketNo]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Mempool m blk -> STM m (MempoolSnapshot blk)
forall (m :: * -> *) blk.
Mempool m blk -> STM m (MempoolSnapshot blk)
getSnapshot Mempool m blk
mempool
                  ([TicketNo]
mempFp', [TicketNo]
_) <- STM m ([TicketNo], [TicketNo]) -> m ([TicketNo], [TicketNo])
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m ([TicketNo], [TicketNo]) -> m ([TicketNo], [TicketNo]))
-> STM m ([TicketNo], [TicketNo]) -> m ([TicketNo], [TicketNo])
forall a b. (a -> b) -> a -> b
$ ([TicketNo] -> [TicketNo])
-> [TicketNo] -> STM m [TicketNo] -> STM m ([TicketNo], [TicketNo])
forall (m :: * -> *) a b.
(MonadSTM m, Eq b) =>
(a -> b) -> b -> STM m a -> STM m (a, b)
blockUntilChanged [TicketNo] -> [TicketNo]
forall a. a -> a
id [TicketNo]
mempFp STM m [TicketNo]
getMemp
                  (SlotNo, LedgerState blk, [TicketNo])
-> m (SlotNo, LedgerState blk, [TicketNo])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SlotNo
slot, LedgerState blk
ledger, [TicketNo]
mempFp')

                -- a new ledger state might render a crucial transaction valid
                ldgrChanged :: m (SlotNo, LedgerState blk, [TicketNo])
ldgrChanged = do
                  (LedgerState blk
ledger', Point blk
_) <- STM m (LedgerState blk, Point blk)
-> m (LedgerState blk, Point blk)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (LedgerState blk, Point blk)
 -> m (LedgerState blk, Point blk))
-> STM m (LedgerState blk, Point blk)
-> m (LedgerState blk, Point blk)
forall a b. (a -> b) -> a -> b
$ (LedgerState blk -> Point blk)
-> Point blk
-> STM m (LedgerState blk)
-> STM m (LedgerState blk, Point blk)
forall (m :: * -> *) a b.
(MonadSTM m, Eq b) =>
(a -> b) -> b -> STM m a -> STM m (a, b)
blockUntilChanged LedgerState blk -> Point blk
forall blk. UpdateLedger blk => LedgerState blk -> Point blk
ledgerTipPoint (LedgerState blk -> Point blk
forall blk. UpdateLedger blk => LedgerState blk -> Point blk
ledgerTipPoint LedgerState blk
ledger) STM m (LedgerState blk)
getLdgr
                  (SlotNo, LedgerState blk, [TicketNo])
-> m (SlotNo, LedgerState blk, [TicketNo])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SlotNo
slot, LedgerState blk
ledger', [TicketNo]
mempFp)

              -- wake up when any of those change
              --
              -- key observation: it's OK to add the crucial txs too often
              (SlotNo, LedgerState blk, [TicketNo])
fps' <- (Either
   (Either
      (SlotNo, LedgerState blk, [TicketNo])
      (SlotNo, LedgerState blk, [TicketNo]))
   (SlotNo, LedgerState blk, [TicketNo])
 -> (SlotNo, LedgerState blk, [TicketNo]))
-> m (Either
        (Either
           (SlotNo, LedgerState blk, [TicketNo])
           (SlotNo, LedgerState blk, [TicketNo]))
        (SlotNo, LedgerState blk, [TicketNo]))
-> m (SlotNo, LedgerState blk, [TicketNo])
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Either
   (SlotNo, LedgerState blk, [TicketNo])
   (SlotNo, LedgerState blk, [TicketNo])
 -> (SlotNo, LedgerState blk, [TicketNo]))
-> ((SlotNo, LedgerState blk, [TicketNo])
    -> (SlotNo, LedgerState blk, [TicketNo]))
-> Either
     (Either
        (SlotNo, LedgerState blk, [TicketNo])
        (SlotNo, LedgerState blk, [TicketNo]))
     (SlotNo, LedgerState blk, [TicketNo])
-> (SlotNo, LedgerState blk, [TicketNo])
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (((SlotNo, LedgerState blk, [TicketNo])
 -> (SlotNo, LedgerState blk, [TicketNo]))
-> ((SlotNo, LedgerState blk, [TicketNo])
    -> (SlotNo, LedgerState blk, [TicketNo]))
-> Either
     (SlotNo, LedgerState blk, [TicketNo])
     (SlotNo, LedgerState blk, [TicketNo])
-> (SlotNo, LedgerState blk, [TicketNo])
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (SlotNo, LedgerState blk, [TicketNo])
-> (SlotNo, LedgerState blk, [TicketNo])
forall a. a -> a
id (SlotNo, LedgerState blk, [TicketNo])
-> (SlotNo, LedgerState blk, [TicketNo])
forall a. a -> a
id) (SlotNo, LedgerState blk, [TicketNo])
-> (SlotNo, LedgerState blk, [TicketNo])
forall a. a -> a
id) (m (Either
      (Either
         (SlotNo, LedgerState blk, [TicketNo])
         (SlotNo, LedgerState blk, [TicketNo]))
      (SlotNo, LedgerState blk, [TicketNo]))
 -> m (SlotNo, LedgerState blk, [TicketNo]))
-> m (Either
        (Either
           (SlotNo, LedgerState blk, [TicketNo])
           (SlotNo, LedgerState blk, [TicketNo]))
        (SlotNo, LedgerState blk, [TicketNo]))
-> m (SlotNo, LedgerState blk, [TicketNo])
forall a b. (a -> b) -> a -> b
$
                m (SlotNo, LedgerState blk, [TicketNo])
slotChanged m (SlotNo, LedgerState blk, [TicketNo])
-> m (SlotNo, LedgerState blk, [TicketNo])
-> m (Either
        (SlotNo, LedgerState blk, [TicketNo])
        (SlotNo, LedgerState blk, [TicketNo]))
forall a b. m a -> m b -> m (Either a b)
forall (m :: * -> *) a b.
MonadAsync m =>
m a -> m b -> m (Either a b)
`race` m (SlotNo, LedgerState blk, [TicketNo])
mempChanged m (Either
     (SlotNo, LedgerState blk, [TicketNo])
     (SlotNo, LedgerState blk, [TicketNo]))
-> m (SlotNo, LedgerState blk, [TicketNo])
-> m (Either
        (Either
           (SlotNo, LedgerState blk, [TicketNo])
           (SlotNo, LedgerState blk, [TicketNo]))
        (SlotNo, LedgerState blk, [TicketNo]))
forall a b. m a -> m b -> m (Either a b)
forall (m :: * -> *) a b.
MonadAsync m =>
m a -> m b -> m (Either a b)
`race` m (SlotNo, LedgerState blk, [TicketNo])
ldgrChanged

              -- avoid the race in which we wake up before the mempool's
              -- background thread wakes up by mimicking it before we do
              -- anything else
              m (MempoolSnapshot blk) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (MempoolSnapshot blk) -> m ())
-> m (MempoolSnapshot blk) -> m ()
forall a b. (a -> b) -> a -> b
$ Mempool m blk -> m (MempoolSnapshot blk)
forall (m :: * -> *) blk. Mempool m blk -> m (MempoolSnapshot blk)
syncWithLedger Mempool m blk
mempool

              (SlotNo, LedgerState blk, [TicketNo]) -> m Any
loop (SlotNo, LedgerState blk, [TicketNo])
fps'
        LedgerState blk
ledger0 <- STM m (LedgerState blk) -> m (LedgerState blk)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (LedgerState blk) -> m (LedgerState blk))
-> STM m (LedgerState blk) -> m (LedgerState blk)
forall a b. (a -> b) -> a -> b
$ STM m (LedgerState blk)
getLdgr
        (SlotNo, LedgerState blk, [TicketNo]) -> m Any
loop (SlotNo
s0, LedgerState blk
ledger0, [])

    -- | Produce transactions every time the slot changes and submit them to
    -- the mempool.
    forkTxProducer :: HasCallStack
                   => CoreNodeId
                   -> ResourceRegistry m
                   -> OracularClock m
                   -> TopLevelConfig blk
                   -> Seed
                   -> STM m (ExtLedgerState blk)
                      -- ^ How to get the current ledger state
                   -> Mempool m blk
                   -> m ()
    forkTxProducer :: HasCallStack =>
CoreNodeId
-> ResourceRegistry m
-> OracularClock m
-> TopLevelConfig blk
-> Seed
-> STM m (ExtLedgerState blk)
-> Mempool m blk
-> m ()
forkTxProducer CoreNodeId
coreNodeId ResourceRegistry m
registry OracularClock m
clock TopLevelConfig blk
cfg Seed
nodeSeed STM m (ExtLedgerState blk)
getExtLedger Mempool m blk
mempool =
      m (m ()) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (m ()) -> m ()) -> m (m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ ResourceRegistry m
-> OracularClock m -> String -> (SlotNo -> m ()) -> m (m ())
forall (m :: * -> *).
HasCallStack =>
ResourceRegistry m
-> OracularClock m -> String -> (SlotNo -> m ()) -> m (m ())
OracularClock.forkEachSlot ResourceRegistry m
registry OracularClock m
clock String
"txProducer" ((SlotNo -> m ()) -> m (m ())) -> (SlotNo -> m ()) -> m (m ())
forall a b. (a -> b) -> a -> b
$ \SlotNo
curSlotNo -> do
        LedgerState blk
ledger <- STM m (LedgerState blk) -> m (LedgerState blk)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (LedgerState blk) -> m (LedgerState blk))
-> STM m (LedgerState blk) -> m (LedgerState blk)
forall a b. (a -> b) -> a -> b
$ ExtLedgerState blk -> LedgerState blk
forall blk. ExtLedgerState blk -> LedgerState blk
ledgerState (ExtLedgerState blk -> LedgerState blk)
-> STM m (ExtLedgerState blk) -> STM m (LedgerState blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM m (ExtLedgerState blk)
getExtLedger
        -- Combine the node's seed with the current slot number, to make sure
        -- we generate different transactions in each slot.
        let txs :: [GenTx blk]
txs = Seed -> Gen [GenTx blk] -> [GenTx blk]
forall a. Seed -> Gen a -> a
runGen
                (Seed
nodeSeed Seed -> Word64 -> Seed
forall a. Integral a => Seed -> a -> Seed
`combineWith` SlotNo -> Word64
unSlotNo SlotNo
curSlotNo)
                (CoreNodeId
-> NumCoreNodes
-> SlotNo
-> TopLevelConfig blk
-> TxGenExtra blk
-> LedgerState blk
-> Gen [GenTx blk]
forall blk.
TxGen blk =>
CoreNodeId
-> NumCoreNodes
-> SlotNo
-> TopLevelConfig blk
-> TxGenExtra blk
-> LedgerState blk
-> Gen [GenTx blk]
testGenTxs CoreNodeId
coreNodeId NumCoreNodes
numCoreNodes SlotNo
curSlotNo TopLevelConfig blk
cfg TxGenExtra blk
txGenExtra LedgerState blk
ledger)

        m [MempoolAddTxResult blk] -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m [MempoolAddTxResult blk] -> m ())
-> m [MempoolAddTxResult blk] -> m ()
forall a b. (a -> b) -> a -> b
$ Mempool m blk -> [GenTx blk] -> m [MempoolAddTxResult blk]
forall (m :: * -> *) blk (t :: * -> *).
(MonadSTM m, Traversable t) =>
Mempool m blk -> t (GenTx blk) -> m (t (MempoolAddTxResult blk))
addTxs Mempool m blk
mempool [GenTx blk]
txs

    mkArgs :: ResourceRegistry m
           -> TopLevelConfig blk
           -> ExtLedgerState blk
           -> Tracer m (RealPoint blk, ExtValidationError blk)
              -- ^ invalid block tracer
           -> Tracer m (RealPoint blk, BlockNo)
              -- ^ added block tracer
           -> Tracer m (RealPoint blk, BlockNo)
              -- ^ block selection tracer
           -> Tracer m (LedgerUpdate blk)
              -- ^ ledger updates tracer
           -> Tracer m (ChainDB.TracePipeliningEvent blk)
           -> NodeDBs (StrictTMVar m MockFS)
           -> CoreNodeId
           -> ChainDbArgs Identity m blk
    mkArgs :: ResourceRegistry m
-> TopLevelConfig blk
-> ExtLedgerState blk
-> Tracer m (RealPoint blk, ExtValidationError blk)
-> Tracer m (RealPoint blk, BlockNo)
-> Tracer m (RealPoint blk, BlockNo)
-> Tracer m (LedgerUpdate blk)
-> Tracer m (TracePipeliningEvent blk)
-> NodeDBs (StrictTMVar m MockFS)
-> CoreNodeId
-> ChainDbArgs Identity m blk
mkArgs
      ResourceRegistry m
registry
      TopLevelConfig blk
cfg ExtLedgerState blk
initLedger
      Tracer m (RealPoint blk, ExtValidationError blk)
invalidTracer Tracer m (RealPoint blk, BlockNo)
addTracer Tracer m (RealPoint blk, BlockNo)
selTracer Tracer m (LedgerUpdate blk)
updatesTracer Tracer m (TracePipeliningEvent blk)
pipeliningTracer
      NodeDBs (StrictTMVar m MockFS)
nodeDBs CoreNodeId
_coreNodeId =
        let args :: ChainDbArgs Identity m blk
args = MinimalChainDbArgs m blk -> ChainDbArgs Identity m blk
forall (m :: * -> *) blk.
(MonadThrow m, MonadSTM m, ConsensusProtocol (BlockProtocol blk),
 PrimMonad m) =>
MinimalChainDbArgs m blk -> Complete ChainDbArgs m blk
fromMinimalChainDbArgs MinimalChainDbArgs {
                mcdbTopLevelConfig :: TopLevelConfig blk
mcdbTopLevelConfig = TopLevelConfig blk
cfg
              , mcdbChunkInfo :: ChunkInfo
mcdbChunkInfo      = EpochSize -> ChunkInfo
ImmutableDB.simpleChunkInfo EpochSize
epochSize0
              , mcdbInitLedger :: ExtLedgerState blk
mcdbInitLedger     = ExtLedgerState blk
initLedger
              , mcdbRegistry :: ResourceRegistry m
mcdbRegistry       = ResourceRegistry m
registry
              , mcdbNodeDBs :: NodeDBs (StrictTMVar m MockFS)
mcdbNodeDBs        = NodeDBs (StrictTMVar m MockFS)
nodeDBs
              }
            tr :: Tracer m (TraceEvent blk)
tr = Tracer m (TraceEvent blk)
instrumentationTracer Tracer m (TraceEvent blk)
-> Tracer m (TraceEvent blk) -> Tracer m (TraceEvent blk)
forall a. Semigroup a => a -> a -> a
<> Tracer m (TraceEvent blk)
forall (m :: * -> *) a. (Applicative m, Show a) => Tracer m a
nullDebugTracer
        in ChainDbArgs Identity m blk
args { cdbImmDbArgs = (cdbImmDbArgs args) {
                      ImmutableDB.immCheckIntegrity = nodeCheckIntegrity (configStorage cfg)
                    , ImmutableDB.immTracer = TraceImmutableDBEvent >$< tr
                    }
                , cdbVolDbArgs = (cdbVolDbArgs args) {
                      VolatileDB.volCheckIntegrity = nodeCheckIntegrity (configStorage cfg)
                    , VolatileDB.volTracer = TraceVolatileDBEvent >$< tr
                    }
                , cdbLgrDbArgs = (cdbLgrDbArgs args) {
                      LedgerDB.lgrTracer = TraceSnapshotEvent >$< tr
                    }
                , cdbsArgs = (cdbsArgs args) {
                     -- TODO: Vary cdbsGcDelay, cdbsGcInterval, cdbsBlockToAddSize
                      cdbsGcDelay = 0
                    , cdbsTracer = instrumentationTracer <> nullDebugTracer
                    }
                }
      where
        prj :: AnchoredFragment block -> BlockNo
prj AnchoredFragment block
af = case AnchoredFragment block -> WithOrigin BlockNo
forall block.
HasHeader block =>
AnchoredFragment block -> WithOrigin BlockNo
AF.headBlockNo AnchoredFragment block
af of
            At BlockNo
bno -> BlockNo
bno
            WithOrigin BlockNo
Origin -> String -> BlockNo
forall a. HasCallStack => String -> a
error String
"selTracer"

        -- prop_general relies on this tracer
        instrumentationTracer :: Tracer m (TraceEvent blk)
instrumentationTracer = (TraceEvent blk -> m ()) -> Tracer m (TraceEvent blk)
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer ((TraceEvent blk -> m ()) -> Tracer m (TraceEvent blk))
-> (TraceEvent blk -> m ()) -> Tracer m (TraceEvent blk)
forall a b. (a -> b) -> a -> b
$ \case
          ChainDB.TraceAddBlockEvent
              (ChainDB.AddBlockValidation (ChainDB.InvalidBlock ExtValidationError blk
e RealPoint blk
p))
              -> Tracer m (RealPoint blk, ExtValidationError blk)
-> (RealPoint blk, ExtValidationError blk) -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (RealPoint blk, ExtValidationError blk)
invalidTracer (RealPoint blk
p, ExtValidationError blk
e)

          ChainDB.TraceAddBlockEvent
              (ChainDB.AddedBlockToVolatileDB RealPoint blk
p BlockNo
bno IsEBB
IsNotEBB Enclosing' ()
FallingEdge)
              -> Tracer m (RealPoint blk, BlockNo)
-> (RealPoint blk, BlockNo) -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (RealPoint blk, BlockNo)
addTracer (RealPoint blk
p, BlockNo
bno)

          ChainDB.TraceAddBlockEvent
              (ChainDB.AddedToCurrentChain [LedgerEvent blk]
events SelectionChangedInfo blk
p AnchoredFragment (Header blk)
_old AnchoredFragment (Header blk)
new)
              -> let ([LedgerWarning blk]
warnings, [LedgerUpdate blk]
updates) = [LedgerEvent blk] -> ([LedgerWarning blk], [LedgerUpdate blk])
forall blk.
[LedgerEvent blk] -> ([LedgerWarning blk], [LedgerUpdate blk])
partitionLedgerEvents [LedgerEvent blk]
events in
                 Either String () -> m () -> m ()
forall a. HasCallStack => Either String () -> a -> a
assertWithMsg ([LedgerWarning blk] -> Either String ()
forall a. Show a => [a] -> Either String ()
noWarnings [LedgerWarning blk]
warnings) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
                   (LedgerUpdate blk -> m ()) -> [LedgerUpdate blk] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Tracer m (LedgerUpdate blk) -> LedgerUpdate blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (LedgerUpdate blk)
updatesTracer) [LedgerUpdate blk]
updates
                   Tracer m (RealPoint blk, BlockNo)
-> (RealPoint blk, BlockNo) -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (RealPoint blk, BlockNo)
selTracer (SelectionChangedInfo blk -> RealPoint blk
forall blk. SelectionChangedInfo blk -> RealPoint blk
ChainDB.newTipPoint SelectionChangedInfo blk
p, AnchoredFragment (Header blk) -> BlockNo
forall {block}.
HasHeader block =>
AnchoredFragment block -> BlockNo
prj AnchoredFragment (Header blk)
new)
          ChainDB.TraceAddBlockEvent
              (ChainDB.SwitchedToAFork [LedgerEvent blk]
events SelectionChangedInfo blk
p AnchoredFragment (Header blk)
_old AnchoredFragment (Header blk)
new)
              -> let ([LedgerWarning blk]
warnings, [LedgerUpdate blk]
updates) = [LedgerEvent blk] -> ([LedgerWarning blk], [LedgerUpdate blk])
forall blk.
[LedgerEvent blk] -> ([LedgerWarning blk], [LedgerUpdate blk])
partitionLedgerEvents [LedgerEvent blk]
events in
                 Either String () -> m () -> m ()
forall a. HasCallStack => Either String () -> a -> a
assertWithMsg ([LedgerWarning blk] -> Either String ()
forall a. Show a => [a] -> Either String ()
noWarnings [LedgerWarning blk]
warnings) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
                   (LedgerUpdate blk -> m ()) -> [LedgerUpdate blk] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Tracer m (LedgerUpdate blk) -> LedgerUpdate blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (LedgerUpdate blk)
updatesTracer) [LedgerUpdate blk]
updates
                   Tracer m (RealPoint blk, BlockNo)
-> (RealPoint blk, BlockNo) -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (RealPoint blk, BlockNo)
selTracer (SelectionChangedInfo blk -> RealPoint blk
forall blk. SelectionChangedInfo blk -> RealPoint blk
ChainDB.newTipPoint SelectionChangedInfo blk
p, AnchoredFragment (Header blk) -> BlockNo
forall {block}.
HasHeader block =>
AnchoredFragment block -> BlockNo
prj AnchoredFragment (Header blk)
new)

          ChainDB.TraceAddBlockEvent
              (ChainDB.PipeliningEvent TracePipeliningEvent blk
e)
              -> Tracer m (TracePipeliningEvent blk)
-> TracePipeliningEvent blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TracePipeliningEvent blk)
pipeliningTracer TracePipeliningEvent blk
e

          TraceEvent blk
_   -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

    -- We don't expect any ledger warnings
    -- (that would indicate node misconfiguration in the tests)
    noWarnings :: Show a => [a] -> Either String ()
    noWarnings :: forall a. Show a => [a] -> Either String ()
noWarnings [] = () -> Either String ()
forall a b. b -> Either a b
Right ()
    noWarnings [a]
ws = String -> Either String ()
forall a b. a -> Either a b
Left (String -> Either String ()) -> String -> Either String ()
forall a b. (a -> b) -> a -> b
$ String
"Unexpected warnings: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [a] -> String
forall a. Show a => a -> String
show [a]
ws

    -- Augment a tracer message with the node which produces it.
    _decorateId :: CoreNodeId -> Tracer m String -> Tracer m String
    _decorateId :: CoreNodeId -> Tracer m String -> Tracer m String
_decorateId (CoreNodeId Word64
cid) = ShowS -> Tracer m String -> Tracer m String
forall a' a. (a' -> a) -> Tracer m a -> Tracer m a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap (ShowS -> Tracer m String -> Tracer m String)
-> ShowS -> Tracer m String -> Tracer m String
forall a b. (a -> b) -> a -> b
$ \String
s ->
        Word64 -> String
forall a. Show a => a -> String
show Word64
cid String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" | " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
s

    forkNode
      :: HasCallStack
      => CoreNodeId
      -> OracularClock m
      -> SlotNo
      -> ResourceRegistry m
      -> ProtocolInfo blk
      -> m [BlockForging m blk]
      -> NodeInfo blk (StrictTMVar m MockFS) (Tracer m)
      -> [GenTx blk]
         -- ^ valid transactions the node should immediately propagate
      -> m ( NodeKernel m NodeId Void blk
           , LimitedApp m NodeId      blk
           )
    forkNode :: HasCallStack =>
CoreNodeId
-> OracularClock m
-> SlotNo
-> ResourceRegistry m
-> ProtocolInfo blk
-> m [BlockForging m blk]
-> NodeInfo blk (StrictTMVar m MockFS) (Tracer m)
-> [GenTx blk]
-> m (NodeKernel m NodeId Void blk, LimitedApp m NodeId blk)
forkNode CoreNodeId
coreNodeId OracularClock m
clock SlotNo
joinSlot ResourceRegistry m
registry ProtocolInfo blk
pInfo m [BlockForging m blk]
blockForging NodeInfo blk (StrictTMVar m MockFS) (Tracer m)
nodeInfo [GenTx blk]
txs0 = do
      let ProtocolInfo{TopLevelConfig blk
ExtLedgerState blk
pInfoInitLedger :: forall b. ProtocolInfo b -> ExtLedgerState b
pInfoConfig :: forall b. ProtocolInfo b -> TopLevelConfig b
pInfoConfig :: TopLevelConfig blk
pInfoInitLedger :: ExtLedgerState blk
..} = ProtocolInfo blk
pInfo

      let NodeInfo
            { NodeEvents blk (Tracer m)
nodeInfoEvents :: forall blk db (ev :: * -> *).
NodeInfo blk db ev -> NodeEvents blk ev
nodeInfoEvents :: NodeEvents blk (Tracer m)
nodeInfoEvents
            , NodeDBs (StrictTMVar m MockFS)
nodeInfoDBs :: NodeDBs (StrictTMVar m MockFS)
nodeInfoDBs :: forall blk db (ev :: * -> *). NodeInfo blk db ev -> NodeDBs db
nodeInfoDBs
            } = NodeInfo blk (StrictTMVar m MockFS) (Tracer m)
nodeInfo

      -- prop_general relies on these tracers
      let invalidTracer :: Tracer m (RealPoint blk, ExtValidationError blk)
invalidTracer = NodeEvents blk (Tracer m)
-> Tracer m (RealPoint blk, ExtValidationError blk)
forall blk (ev :: * -> *).
NodeEvents blk ev -> ev (RealPoint blk, ExtValidationError blk)
nodeEventsInvalids NodeEvents blk (Tracer m)
nodeInfoEvents
          updatesTracer :: Tracer m (LedgerUpdate blk)
updatesTracer = NodeEvents blk (Tracer m) -> Tracer m (LedgerUpdate blk)
forall blk (ev :: * -> *).
NodeEvents blk ev -> ev (LedgerUpdate blk)
nodeEventsUpdates  NodeEvents blk (Tracer m)
nodeInfoEvents
          wrapTracer :: Tracer m (SlotNo, RealPoint blk, BlockNo)
-> Tracer m (RealPoint blk, BlockNo)
wrapTracer Tracer m (SlotNo, RealPoint blk, BlockNo)
tr   = ((RealPoint blk, BlockNo) -> m ())
-> Tracer m (RealPoint blk, BlockNo)
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer (((RealPoint blk, BlockNo) -> m ())
 -> Tracer m (RealPoint blk, BlockNo))
-> ((RealPoint blk, BlockNo) -> m ())
-> Tracer m (RealPoint blk, BlockNo)
forall a b. (a -> b) -> a -> b
$ \(RealPoint blk
p, BlockNo
bno) -> do
            SlotNo
s <- OracularClock m -> m SlotNo
forall (m :: * -> *). OracularClock m -> m SlotNo
OracularClock.getCurrentSlot OracularClock m
clock
            Tracer m (SlotNo, RealPoint blk, BlockNo)
-> (SlotNo, RealPoint blk, BlockNo) -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (SlotNo, RealPoint blk, BlockNo)
tr (SlotNo
s, RealPoint blk
p, BlockNo
bno)
          addTracer :: Tracer m (RealPoint blk, BlockNo)
addTracer        = Tracer m (SlotNo, RealPoint blk, BlockNo)
-> Tracer m (RealPoint blk, BlockNo)
wrapTracer (Tracer m (SlotNo, RealPoint blk, BlockNo)
 -> Tracer m (RealPoint blk, BlockNo))
-> Tracer m (SlotNo, RealPoint blk, BlockNo)
-> Tracer m (RealPoint blk, BlockNo)
forall a b. (a -> b) -> a -> b
$ NodeEvents blk (Tracer m)
-> Tracer m (SlotNo, RealPoint blk, BlockNo)
forall blk (ev :: * -> *).
NodeEvents blk ev -> ev (SlotNo, RealPoint blk, BlockNo)
nodeEventsAdds NodeEvents blk (Tracer m)
nodeInfoEvents
          selTracer :: Tracer m (RealPoint blk, BlockNo)
selTracer        = Tracer m (SlotNo, RealPoint blk, BlockNo)
-> Tracer m (RealPoint blk, BlockNo)
wrapTracer (Tracer m (SlotNo, RealPoint blk, BlockNo)
 -> Tracer m (RealPoint blk, BlockNo))
-> Tracer m (SlotNo, RealPoint blk, BlockNo)
-> Tracer m (RealPoint blk, BlockNo)
forall a b. (a -> b) -> a -> b
$ NodeEvents blk (Tracer m)
-> Tracer m (SlotNo, RealPoint blk, BlockNo)
forall blk (ev :: * -> *).
NodeEvents blk ev -> ev (SlotNo, RealPoint blk, BlockNo)
nodeEventsSelects NodeEvents blk (Tracer m)
nodeInfoEvents
          headerAddTracer :: Tracer m (RealPoint blk, BlockNo)
headerAddTracer  = Tracer m (SlotNo, RealPoint blk, BlockNo)
-> Tracer m (RealPoint blk, BlockNo)
wrapTracer (Tracer m (SlotNo, RealPoint blk, BlockNo)
 -> Tracer m (RealPoint blk, BlockNo))
-> Tracer m (SlotNo, RealPoint blk, BlockNo)
-> Tracer m (RealPoint blk, BlockNo)
forall a b. (a -> b) -> a -> b
$ NodeEvents blk (Tracer m)
-> Tracer m (SlotNo, RealPoint blk, BlockNo)
forall blk (ev :: * -> *).
NodeEvents blk ev -> ev (SlotNo, RealPoint blk, BlockNo)
nodeEventsHeaderAdds NodeEvents blk (Tracer m)
nodeInfoEvents
          pipeliningTracer :: Tracer m (TracePipeliningEvent blk)
pipeliningTracer = NodeEvents blk (Tracer m) -> Tracer m (TracePipeliningEvent blk)
forall blk (ev :: * -> *).
NodeEvents blk ev -> ev (TracePipeliningEvent blk)
nodeEventsPipelining NodeEvents blk (Tracer m)
nodeInfoEvents
      let chainDbArgs :: ChainDbArgs Identity m blk
chainDbArgs = ResourceRegistry m
-> TopLevelConfig blk
-> ExtLedgerState blk
-> Tracer m (RealPoint blk, ExtValidationError blk)
-> Tracer m (RealPoint blk, BlockNo)
-> Tracer m (RealPoint blk, BlockNo)
-> Tracer m (LedgerUpdate blk)
-> Tracer m (TracePipeliningEvent blk)
-> NodeDBs (StrictTMVar m MockFS)
-> CoreNodeId
-> ChainDbArgs Identity m blk
mkArgs
            ResourceRegistry m
registry
            TopLevelConfig blk
pInfoConfig ExtLedgerState blk
pInfoInitLedger
            Tracer m (RealPoint blk, ExtValidationError blk)
invalidTracer
            Tracer m (RealPoint blk, BlockNo)
addTracer
            Tracer m (RealPoint blk, BlockNo)
selTracer
            Tracer m (LedgerUpdate blk)
updatesTracer
            Tracer m (TracePipeliningEvent blk)
pipeliningTracer
            NodeDBs (StrictTMVar m MockFS)
nodeInfoDBs
            CoreNodeId
coreNodeId
      ChainDB m blk
chainDB <- (ResourceKey m, ChainDB m blk) -> ChainDB m blk
forall a b. (a, b) -> b
snd ((ResourceKey m, ChainDB m blk) -> ChainDB m blk)
-> m (ResourceKey m, ChainDB m blk) -> m (ChainDB m blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        ResourceRegistry m
-> (ResourceId -> m (ChainDB m blk))
-> (ChainDB m blk -> m ())
-> m (ResourceKey m, ChainDB m blk)
forall (m :: * -> *) a.
(MonadSTM m, MonadMask m, MonadThread m, HasCallStack) =>
ResourceRegistry m
-> (ResourceId -> m a) -> (a -> m ()) -> m (ResourceKey m, a)
allocate ResourceRegistry m
registry (m (ChainDB m blk) -> ResourceId -> m (ChainDB m blk)
forall a b. a -> b -> a
const (ChainDbArgs Identity m blk -> m (ChainDB m blk)
forall (m :: * -> *) blk.
(IOLike m, LedgerSupportsProtocol blk,
 BlockSupportsDiffusionPipelining blk, InspectLedger blk,
 HasHardForkHistory blk, ConvertRawHash blk,
 SerialiseDiskConstraints blk) =>
ChainDbArgs Identity m blk -> m (ChainDB m blk)
ChainDB.openDB ChainDbArgs Identity m blk
chainDbArgs)) ChainDB m blk -> m ()
forall (m :: * -> *) blk. ChainDB m blk -> m ()
ChainDB.closeDB

      let customForgeBlock ::
               BlockForging m blk
            -> TopLevelConfig blk
            -> BlockNo
            -> SlotNo
            -> TickedLedgerState blk
            -> [Validated (GenTx blk)]
            -> IsLeader (BlockProtocol blk)
            -> m blk
          customForgeBlock :: BlockForging m blk
-> TopLevelConfig blk
-> BlockNo
-> SlotNo
-> Ticked (LedgerState blk)
-> [Validated (GenTx blk)]
-> IsLeader (BlockProtocol blk)
-> m blk
customForgeBlock BlockForging m blk
origBlockForging TopLevelConfig blk
cfg' BlockNo
currentBno SlotNo
currentSlot Ticked (LedgerState blk)
tickedLdgSt [Validated (GenTx blk)]
txs IsLeader (BlockProtocol blk)
prf = do
            let currentEpoch :: EpochNo
currentEpoch = Future -> SlotNo -> EpochNo
HFF.futureSlotToEpoch Future
future SlotNo
currentSlot

            -- EBBs are only ever possible in the first era
            let inFirstEra :: Bool
inFirstEra = Future -> EpochNo -> Bool
HFF.futureEpochInFirstEra Future
future EpochNo
currentEpoch

            let ebbSlot :: SlotNo
                ebbSlot :: SlotNo
ebbSlot = Word64 -> SlotNo
SlotNo (Word64 -> SlotNo) -> Word64 -> SlotNo
forall a b. (a -> b) -> a -> b
$ Word64
x Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
y
                  where
                    EpochNo   Word64
x = EpochNo
currentEpoch
                    EpochSize Word64
y = EpochSize
epochSize0

            let p :: Point blk
                p :: Point blk
p = Point (Ticked (LedgerState blk)) -> Point blk
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (Point (Ticked (LedgerState blk)) -> Point blk)
-> Point (Ticked (LedgerState blk)) -> Point blk
forall a b. (a -> b) -> a -> b
$ Ticked (LedgerState blk) -> Point (Ticked (LedgerState blk))
forall l. GetTip l => l -> Point l
getTip Ticked (LedgerState blk)
tickedLdgSt

            let needEBB :: Bool
needEBB = Bool
inFirstEra Bool -> Bool -> Bool
&& SlotNo -> WithOrigin SlotNo
forall t. t -> WithOrigin t
NotOrigin SlotNo
ebbSlot WithOrigin SlotNo -> WithOrigin SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
> Point blk -> WithOrigin SlotNo
forall {k} (block :: k). Point block -> WithOrigin SlotNo
pointSlot Point blk
p
            case Maybe (ForgeEbbEnv blk)
mbForgeEbbEnv Maybe (ForgeEbbEnv blk) -> Maybe () -> Maybe (ForgeEbbEnv blk)
forall a b. Maybe a -> Maybe b -> Maybe a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard Bool
needEBB of
              Maybe (ForgeEbbEnv blk)
Nothing ->
                 -- no EBB needed, forge without making one
                 BlockForging m blk
-> TopLevelConfig blk
-> BlockNo
-> SlotNo
-> Ticked (LedgerState blk)
-> [Validated (GenTx blk)]
-> IsLeader (BlockProtocol blk)
-> m blk
forall (m :: * -> *) blk.
BlockForging m blk
-> TopLevelConfig blk
-> BlockNo
-> SlotNo
-> TickedLedgerState blk
-> [Validated (GenTx blk)]
-> IsLeader (BlockProtocol blk)
-> m blk
forgeBlock
                   BlockForging m blk
origBlockForging
                   TopLevelConfig blk
cfg'
                   BlockNo
currentBno
                   SlotNo
currentSlot
                   Ticked (LedgerState blk)
tickedLdgSt
                   [Validated (GenTx blk)]
txs
                   IsLeader (BlockProtocol blk)
prf
              Just ForgeEbbEnv blk
forgeEbbEnv -> do
                  -- The EBB shares its BlockNo with its predecessor (if
                  -- there is one)
                  let ebbBno :: BlockNo
ebbBno = case BlockNo
currentBno of
                        -- We assume this invariant:
                        --
                        -- If forging of EBBs is enabled then the node
                        -- initialization is responsible for producing any
                        -- proper non-EBB blocks with block number 0.
                        --
                        -- So this case is unreachable.
                        BlockNo
0 -> String -> BlockNo
forall a. HasCallStack => String -> a
error String
"Error, only node initialization can forge non-EBB with block number 0."
                        BlockNo
n -> BlockNo -> BlockNo
forall a. Enum a => a -> a
pred BlockNo
n
                  let ebb :: blk
ebb = ForgeEbbEnv blk
-> TopLevelConfig blk -> SlotNo -> BlockNo -> ChainHash blk -> blk
forall blk.
ForgeEbbEnv blk
-> TopLevelConfig blk -> SlotNo -> BlockNo -> ChainHash blk -> blk
forgeEBB ForgeEbbEnv blk
forgeEbbEnv TopLevelConfig blk
pInfoConfig
                              SlotNo
ebbSlot BlockNo
ebbBno (Point blk -> ChainHash blk
forall {k} (block :: k). Point block -> ChainHash block
pointHash Point blk
p)

                  -- fail if the EBB is invalid
                  -- if it is valid, we retick to the /same/ slot
                  let apply :: blk
-> Ticked (LedgerState blk)
-> Except (LedgerErr (LedgerState blk)) (LedgerState blk)
apply = LedgerConfig blk
-> blk
-> Ticked (LedgerState blk)
-> Except (LedgerErr (LedgerState blk)) (LedgerState blk)
forall l blk.
(ApplyBlock l blk, HasCallStack) =>
LedgerCfg l -> blk -> Ticked l -> Except (LedgerErr l) l
applyLedgerBlock (TopLevelConfig blk -> LedgerConfig blk
forall blk. TopLevelConfig blk -> LedgerConfig blk
configLedger TopLevelConfig blk
pInfoConfig)
                  Ticked (LedgerState blk)
tickedLdgSt' <- case Except (LedgerErr (LedgerState blk)) (LedgerState blk)
-> Either (LedgerErr (LedgerState blk)) (LedgerState blk)
forall e a. Except e a -> Either e a
Exc.runExcept (Except (LedgerErr (LedgerState blk)) (LedgerState blk)
 -> Either (LedgerErr (LedgerState blk)) (LedgerState blk))
-> Except (LedgerErr (LedgerState blk)) (LedgerState blk)
-> Either (LedgerErr (LedgerState blk)) (LedgerState blk)
forall a b. (a -> b) -> a -> b
$ blk
-> Ticked (LedgerState blk)
-> Except (LedgerErr (LedgerState blk)) (LedgerState blk)
apply blk
ebb Ticked (LedgerState blk)
tickedLdgSt of
                    Left LedgerErr (LedgerState blk)
e   -> JitEbbError blk -> m (Ticked (LedgerState blk))
forall a e. Exception e => e -> a
Exn.throw (JitEbbError blk -> m (Ticked (LedgerState blk)))
-> JitEbbError blk -> m (Ticked (LedgerState blk))
forall a b. (a -> b) -> a -> b
$ forall blk. LedgerError blk -> JitEbbError blk
JitEbbError @blk LedgerErr (LedgerState blk)
e
                    Right LedgerState blk
st -> Ticked (LedgerState blk) -> m (Ticked (LedgerState blk))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ticked (LedgerState blk) -> m (Ticked (LedgerState blk)))
-> Ticked (LedgerState blk) -> m (Ticked (LedgerState blk))
forall a b. (a -> b) -> a -> b
$ LedgerConfig blk
-> SlotNo -> LedgerState blk -> Ticked (LedgerState blk)
forall l. IsLedger l => LedgerCfg l -> SlotNo -> l -> Ticked l
applyChainTick
                                        (TopLevelConfig blk -> LedgerConfig blk
forall blk. TopLevelConfig blk -> LedgerConfig blk
configLedger TopLevelConfig blk
pInfoConfig)
                                        SlotNo
currentSlot
                                        LedgerState blk
st

                  -- forge the block usings the ledger state that includes
                  -- the EBB
                  blk
blk <- BlockForging m blk
-> TopLevelConfig blk
-> BlockNo
-> SlotNo
-> Ticked (LedgerState blk)
-> [Validated (GenTx blk)]
-> IsLeader (BlockProtocol blk)
-> m blk
forall (m :: * -> *) blk.
BlockForging m blk
-> TopLevelConfig blk
-> BlockNo
-> SlotNo
-> TickedLedgerState blk
-> [Validated (GenTx blk)]
-> IsLeader (BlockProtocol blk)
-> m blk
forgeBlock
                           BlockForging m blk
origBlockForging
                           TopLevelConfig blk
cfg'
                           BlockNo
currentBno
                           SlotNo
currentSlot
                           Ticked (LedgerState blk)
tickedLdgSt'
                           [Validated (GenTx blk)]
txs
                           IsLeader (BlockProtocol blk)
prf

                  -- If the EBB or the subsequent block is invalid, then the
                  -- ChainDB will reject it as invalid, and
                  -- 'Test.ThreadNet.General.prop_general' will eventually fail
                  -- because of a block rejection.
                  m (AddBlockResult blk) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (AddBlockResult blk) -> m ()) -> m (AddBlockResult blk) -> m ()
forall a b. (a -> b) -> a -> b
$ ChainDB m blk
-> InvalidBlockPunishment m -> blk -> m (AddBlockResult blk)
forall (m :: * -> *) blk.
IOLike m =>
ChainDB m blk
-> InvalidBlockPunishment m -> blk -> m (AddBlockResult blk)
ChainDB.addBlock ChainDB m blk
chainDB InvalidBlockPunishment m
forall (m :: * -> *). Applicative m => InvalidBlockPunishment m
InvalidBlockPunishment.noPunishment blk
ebb
                  blk -> m blk
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure blk
blk

      -- This variable holds the number of the earliest slot in which the
      -- crucial txs have not yet been added. In other words, it holds the
      -- successor of the number of the latest slot in which the crucial txs
      -- have been added.
      --
      -- Key facts: The thread that adds the crucial transactions updates this
      -- variable, and the forge tracer for 'TraceNodeIsLeader' blocks on it.
      (SlotNo -> STM m ()
unblockForge, SlotNo -> STM m ()
blockOnCrucial) <- do
        StrictTVar m SlotNo
var <- SlotNo -> m (StrictTVar m SlotNo)
forall (m :: * -> *) a. MonadSTM m => a -> m (StrictTVar m a)
uncheckedNewTVarM SlotNo
0
        (SlotNo -> STM m (), SlotNo -> STM m ())
-> m (SlotNo -> STM m (), SlotNo -> STM m ())
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
          ( \SlotNo
s -> do
              StrictTVar m SlotNo -> (SlotNo -> SlotNo) -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar StrictTVar m SlotNo
var (SlotNo -> SlotNo
forall a. Enum a => a -> a
succ SlotNo
s SlotNo -> SlotNo -> SlotNo
forall a. Ord a => a -> a -> a
`max`)
          , \SlotNo
s -> do
              SlotNo
sentinel <- StrictTVar m SlotNo -> STM m SlotNo
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m SlotNo
var
              Bool -> STM m ()
forall (m :: * -> *). MonadSTM m => Bool -> STM m ()
check (Bool -> STM m ()) -> Bool -> STM m ()
forall a b. (a -> b) -> a -> b
$ SlotNo
s SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
< SlotNo
sentinel
          )

      let -- prop_general relies on these tracers
          instrumentationTracers :: Tracers' (ConnectionId NodeId) Void blk (Tracer m)
instrumentationTracers = Tracers m (ConnectionId NodeId) Any blk
forall (m :: * -> *) remotePeer localPeer blk.
Monad m =>
Tracers m remotePeer localPeer blk
nullTracers
                { chainSyncClientTracer = Tracer $ \case
                    TraceLabelPeer ConnectionId NodeId
_ (CSClient.TraceDownloadedHeader Header blk
hdr)
                      -> case Header blk -> Point (Header blk)
forall block. HasHeader block => block -> Point block
blockPoint Header blk
hdr of
                            Point (Header blk)
GenesisPoint   -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                            BlockPoint SlotNo
s HeaderHash (Header blk)
h ->
                                -- TODO include tip in TraceDownloadedHeader
                                -- and only trace if hdr == tip?
                                Tracer m (RealPoint blk, BlockNo)
-> (RealPoint blk, BlockNo) -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (RealPoint blk, BlockNo)
headerAddTracer
                                  (SlotNo -> HeaderHash blk -> RealPoint blk
forall blk. SlotNo -> HeaderHash blk -> RealPoint blk
RealPoint SlotNo
s HeaderHash blk
HeaderHash (Header blk)
h, Header blk -> BlockNo
forall b. HasHeader b => b -> BlockNo
blockNo Header blk
hdr)
                    TraceLabelPeer
  (ConnectionId NodeId) (TraceChainSyncClientEvent blk)
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                , forgeTracer           = Tracer $ \(TraceLabelCreds Text
_ TraceForgeEvent blk
ev) -> do
                    Tracer m (TraceForgeEvent blk) -> TraceForgeEvent blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith (NodeEvents blk (Tracer m) -> Tracer m (TraceForgeEvent blk)
forall blk (ev :: * -> *).
NodeEvents blk ev -> ev (TraceForgeEvent blk)
nodeEventsForges NodeEvents blk (Tracer m)
nodeInfoEvents) TraceForgeEvent blk
ev
                    case TraceForgeEvent blk
ev of
                      TraceNodeIsLeader SlotNo
s -> STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ SlotNo -> STM m ()
blockOnCrucial SlotNo
s
                      TraceForgeEvent blk
_                   -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                }

          -- traces the node's local events other than those from the -- ChainDB
          tracers :: Tracers' (ConnectionId NodeId) Void blk (Tracer m)
tracers = Tracers' (ConnectionId NodeId) Void blk (Tracer m)
instrumentationTracers Tracers' (ConnectionId NodeId) Void blk (Tracer m)
-> Tracers' (ConnectionId NodeId) Void blk (Tracer m)
-> Tracers' (ConnectionId NodeId) Void blk (Tracer m)
forall a. Semigroup a => a -> a -> a
<> Tracers' (ConnectionId NodeId) Void blk (Tracer m)
forall (m :: * -> *) peer blk.
(Monad m, Show peer, LedgerSupportsProtocol blk,
 TracingConstraints blk) =>
Tracers m peer Void blk
nullDebugTracers

      let -- use a backoff delay of exactly one slot length (which the
          -- 'OracularClock' always knows) for the following reasons
          --
          -- o It gives the node a chance to sync some blocks so that it will
          --   eventually not need to backoff
          --
          -- o It maintains the invariant that the node's activities all happen "
          --   during " a slot onset
          --
          -- o It avoids causing the node to miss a slot it could have
          --   nominally lead. EG If we used a backoff of two slot durations,
          --   then it might have synced during the first slot and then been
          --   able to productively lead the second slot had it not still been
          --   asleep.
          --
          -- o We assume a node will only backoff when it joins late and only
          --   until it syncs enough of the net's existing common prefix.
          hfbtBackoffDelay :: m BackoffDelay
hfbtBackoffDelay =
              NominalDiffTime -> BackoffDelay
BackoffDelay (NominalDiffTime -> BackoffDelay)
-> m NominalDiffTime -> m BackoffDelay
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> OracularClock m -> m NominalDiffTime
forall (m :: * -> *). OracularClock m -> m NominalDiffTime
OracularClock.delayUntilNextSlot OracularClock m
clock
      BlockchainTime m
btime <- HardForkBlockchainTimeArgs m blk -> m (BlockchainTime m)
forall (m :: * -> *) blk.
(IOLike m, HasHardForkHistory blk, HasCallStack) =>
HardForkBlockchainTimeArgs m blk -> m (BlockchainTime m)
hardForkBlockchainTime HardForkBlockchainTimeArgs
        { m BackoffDelay
hfbtBackoffDelay :: m BackoffDelay
hfbtBackoffDelay :: m BackoffDelay
hfbtBackoffDelay
        , hfbtGetLedgerState :: STM m (LedgerState blk)
hfbtGetLedgerState =
            ExtLedgerState blk -> LedgerState blk
forall blk. ExtLedgerState blk -> LedgerState blk
ledgerState (ExtLedgerState blk -> LedgerState blk)
-> STM m (ExtLedgerState blk) -> STM m (LedgerState blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChainDB m blk -> STM m (ExtLedgerState blk)
forall (m :: * -> *) blk.
(Monad (STM m), IsLedger (LedgerState blk)) =>
ChainDB m blk -> STM m (ExtLedgerState blk)
ChainDB.getCurrentLedger ChainDB m blk
chainDB
        , hfbtLedgerConfig :: LedgerConfig blk
hfbtLedgerConfig   = TopLevelConfig blk -> LedgerConfig blk
forall blk. TopLevelConfig blk -> LedgerConfig blk
configLedger TopLevelConfig blk
pInfoConfig
        , hfbtRegistry :: ResourceRegistry m
hfbtRegistry       = ResourceRegistry m
registry
        , hfbtSystemTime :: SystemTime m
hfbtSystemTime     = OracularClock m -> SystemTime m
forall (m :: * -> *). OracularClock m -> SystemTime m
OracularClock.finiteSystemTime OracularClock m
clock
        , hfbtTracer :: Tracer m (TraceBlockchainTimeEvent RelativeTime)
hfbtTracer         =
            (TraceBlockchainTimeEvent RelativeTime
 -> TraceBlockchainTimeEvent UTCTime)
-> Tracer m (TraceBlockchainTimeEvent UTCTime)
-> Tracer m (TraceBlockchainTimeEvent RelativeTime)
forall a' a. (a' -> a) -> Tracer m a -> Tracer m a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap
              -- We don't really have a SystemStart in the tests
              ((RelativeTime -> UTCTime)
-> TraceBlockchainTimeEvent RelativeTime
-> TraceBlockchainTimeEvent UTCTime
forall a b.
(a -> b)
-> TraceBlockchainTimeEvent a -> TraceBlockchainTimeEvent b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SystemStart -> RelativeTime -> UTCTime
fromRelativeTime (UTCTime -> SystemStart
SystemStart UTCTime
dawnOfTime)))
              (Tracers' (ConnectionId NodeId) Void blk (Tracer m)
-> Tracer m (TraceBlockchainTimeEvent UTCTime)
forall remotePeer localPeer blk (f :: * -> *).
Tracers' remotePeer localPeer blk f
-> f (TraceBlockchainTimeEvent UTCTime)
blockchainTimeTracer Tracers' (ConnectionId NodeId) Void blk (Tracer m)
tracers)
        , hfbtMaxClockRewind :: NominalDiffTime
hfbtMaxClockRewind = Double -> NominalDiffTime
secondsToNominalDiffTime Double
0
        }

      let rng :: StdGen
rng = case Seed
seed of
                    Seed Int
s -> Int -> StdGen
mkStdGen Int
s
          (StdGen
kaRng, StdGen
psRng) = StdGen -> (StdGen, StdGen)
forall g. RandomGen g => g -> (g, g)
split StdGen
rng
      StrictTVar m (PublicPeerSelectionState NodeId)
publicPeerSelectionStateVar <- m (StrictTVar m (PublicPeerSelectionState NodeId))
forall (m :: * -> *) peeraddr.
(MonadSTM m, Ord peeraddr) =>
m (StrictTVar m (PublicPeerSelectionState peeraddr))
makePublicPeerSelectionStateVar
      let nodeKernelArgs :: NodeKernelArgs m NodeId Void blk
nodeKernelArgs = NodeKernelArgs
            { Tracers' (ConnectionId NodeId) Void blk (Tracer m)
tracers :: Tracers' (ConnectionId NodeId) Void blk (Tracer m)
$sel:tracers:NodeKernelArgs :: Tracers' (ConnectionId NodeId) Void blk (Tracer m)
tracers
            , ResourceRegistry m
registry :: ResourceRegistry m
$sel:registry:NodeKernelArgs :: ResourceRegistry m
registry
            , $sel:cfg:NodeKernelArgs :: TopLevelConfig blk
cfg                     = TopLevelConfig blk
pInfoConfig
            , BlockchainTime m
btime :: BlockchainTime m
$sel:btime:NodeKernelArgs :: BlockchainTime m
btime
            , ChainDB m blk
chainDB :: ChainDB m blk
$sel:chainDB:NodeKernelArgs :: ChainDB m blk
chainDB
            , $sel:initChainDB:NodeKernelArgs :: 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
            , $sel:chainSyncFutureCheck:NodeKernelArgs :: SomeHeaderInFutureCheck m blk
chainSyncFutureCheck    =
                  ClockSkew -> SystemTime m -> SomeHeaderInFutureCheck m blk
forall blk (m :: * -> *).
(HasHeader blk, HasHeader (Header blk), HasHardForkHistory blk,
 MonadDelay m) =>
ClockSkew -> SystemTime m -> SomeHeaderInFutureCheck m blk
InFutureCheck.realHeaderInFutureCheck
                    ClockSkew
InFutureCheck.defaultClockSkew
                    (OracularClock m -> SystemTime m
forall (m :: * -> *). OracularClock m -> SystemTime m
OracularClock.finiteSystemTime OracularClock m
clock)
            , $sel:chainSyncHistoricityCheck:NodeKernelArgs :: m GsmState -> HistoricityCheck m blk
chainSyncHistoricityCheck = \m GsmState
_getGsmState -> HistoricityCheck m blk
forall (m :: * -> *) blk. Applicative m => HistoricityCheck m blk
HistoricityCheck.noCheck
            , $sel:blockFetchSize:NodeKernelArgs :: Header blk -> SizeInBytes
blockFetchSize          = Header blk -> SizeInBytes
forall blk.
SerialiseNodeToNodeConstraints blk =>
Header blk -> SizeInBytes
estimateBlockSize
            , $sel:mempoolCapacityOverride:NodeKernelArgs :: MempoolCapacityBytesOverride
mempoolCapacityOverride = MempoolCapacityBytesOverride
NoMempoolCapacityBytesOverride
            , $sel:keepAliveRng:NodeKernelArgs :: StdGen
keepAliveRng            = StdGen
kaRng
            , $sel:peerSharingRng:NodeKernelArgs :: StdGen
peerSharingRng          = StdGen
psRng
            , $sel:miniProtocolParameters:NodeKernelArgs :: MiniProtocolParameters
miniProtocolParameters  = MiniProtocolParameters {
                  chainSyncPipeliningHighMark :: Word16
chainSyncPipeliningHighMark = Word16
4,
                  chainSyncPipeliningLowMark :: Word16
chainSyncPipeliningLowMark  = Word16
2,
                  blockFetchPipeliningMax :: Word16
blockFetchPipeliningMax     = Word16
10,
                  txSubmissionMaxUnacked :: NumTxIdsToAck
txSubmissionMaxUnacked      = NumTxIdsToAck
1000 -- TODO ?
                }
            , $sel:blockFetchConfiguration:NodeKernelArgs :: BlockFetchConfiguration
blockFetchConfiguration = BlockFetchConfiguration {
                  bfcMaxConcurrencyBulkSync :: Word
bfcMaxConcurrencyBulkSync = Word
1
                , bfcMaxConcurrencyDeadline :: Word
bfcMaxConcurrencyDeadline = Word
2
                , bfcMaxRequestsInflight :: Word
bfcMaxRequestsInflight    = Word
10
                , bfcDecisionLoopInterval :: DiffTime
bfcDecisionLoopInterval   = DiffTime
0.0 -- Mock testsuite can use sub-second slot
                                                  -- interval which doesn't play nice with
                                                  -- blockfetch descision interval.
                , bfcSalt :: Int
bfcSalt                   = Int
0
                }
            , $sel:gsmArgs:NodeKernelArgs :: GsmNodeKernelArgs m blk
gsmArgs                 = GSM.GsmNodeKernelArgs {
                  gsmAntiThunderingHerd :: StdGen
gsmAntiThunderingHerd  = StdGen
kaRng
                , gsmDurationUntilTooOld :: Maybe (WrapDurationUntilTooOld m blk)
gsmDurationUntilTooOld = Maybe (WrapDurationUntilTooOld m blk)
forall a. Maybe a
Nothing
                , gsmMarkerFileView :: MarkerFileView m
gsmMarkerFileView      = GSM.MarkerFileView {
                      touchMarkerFile :: m ()
touchMarkerFile  = () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                    , removeMarkerFile :: m ()
removeMarkerFile = () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                    , hasMarkerFile :: m Bool
hasMarkerFile    = Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
                    }
                , gsmMinCaughtUpDuration :: NominalDiffTime
gsmMinCaughtUpDuration = NominalDiffTime
0
                }
            , $sel:getUseBootstrapPeers:NodeKernelArgs :: STM m UseBootstrapPeers
getUseBootstrapPeers = UseBootstrapPeers -> STM m UseBootstrapPeers
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure UseBootstrapPeers
DontUseBootstrapPeers
            , StrictTVar m (PublicPeerSelectionState NodeId)
publicPeerSelectionStateVar :: StrictTVar m (PublicPeerSelectionState NodeId)
$sel:publicPeerSelectionStateVar:NodeKernelArgs :: StrictTVar m (PublicPeerSelectionState NodeId)
publicPeerSelectionStateVar
            , $sel:genesisArgs:NodeKernelArgs :: GenesisNodeKernelArgs m blk
genesisArgs          = GenesisNodeKernelArgs {
                  gnkaGetLoEFragment :: LoEAndGDDConfig (StrictTVar m (GetLoEFragment m blk))
gnkaGetLoEFragment = LoEAndGDDConfig (StrictTVar m (GetLoEFragment m blk))
forall a. LoEAndGDDConfig a
LoEAndGDDDisabled
                }
            , $sel:getDiffusionPipeliningSupport:NodeKernelArgs :: DiffusionPipeliningSupport
getDiffusionPipeliningSupport = DiffusionPipeliningSupport
DiffusionPipeliningOn
            }

      NodeKernel m NodeId Void blk
nodeKernel <- NodeKernelArgs m NodeId Void blk
-> m (NodeKernel m NodeId Void blk)
forall (m :: * -> *) addrNTN addrNTC blk.
(IOLike m, MonadTimer m, RunNode blk, Ord addrNTN,
 Hashable addrNTN, Typeable addrNTN) =>
NodeKernelArgs m addrNTN addrNTC blk
-> m (NodeKernel m addrNTN addrNTC blk)
initNodeKernel NodeKernelArgs m NodeId Void blk
nodeKernelArgs

      [BlockForging m blk]
blockForging' <-
            (BlockForging m blk -> BlockForging m blk)
-> [BlockForging m blk] -> [BlockForging m blk]
forall a b. (a -> b) -> [a] -> [b]
map (\BlockForging m blk
bf -> BlockForging m blk
bf { forgeBlock = customForgeBlock bf })
        ([BlockForging m blk] -> [BlockForging m blk])
-> m [BlockForging m blk] -> m [BlockForging m blk]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m [BlockForging m blk]
blockForging
      NodeKernel m NodeId Void blk -> [BlockForging m blk] -> m ()
forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernel m addrNTN addrNTC blk -> [BlockForging m blk] -> m ()
setBlockForging NodeKernel m NodeId Void blk
nodeKernel [BlockForging m blk]
blockForging'

      let mempool :: Mempool m blk
mempool = NodeKernel m NodeId Void blk -> Mempool m blk
forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernel m addrNTN addrNTC blk -> Mempool m blk
getMempool NodeKernel m NodeId Void blk
nodeKernel
      let app :: Apps
  m
  NodeId
  ByteString
  ByteString
  (AnyMessage (TxSubmission2 (TxId (GenTx blk)) (GenTx blk)))
  (AnyMessage KeepAlive)
  (AnyMessage (PeerSharing NodeId))
  NodeToNodeInitiatorResult
  ()
app = NodeKernel m NodeId Void blk
-> Tracers m (ConnectionId NodeId) blk CodecError
-> (NodeToNodeVersion
    -> Codecs
         blk
         NodeId
         CodecError
         m
         ByteString
         ByteString
         ByteString
         ByteString
         (AnyMessage (TxSubmission2 (TxId (GenTx blk)) (GenTx blk)))
         (AnyMessage KeepAlive)
         (AnyMessage (PeerSharing NodeId)))
-> ByteLimits
     ByteString
     ByteString
     (AnyMessage (TxSubmission2 (TxId (GenTx blk)) (GenTx blk)))
     (AnyMessage KeepAlive)
-> m ChainSyncTimeout
-> ChainSyncLoPBucketConfig
-> CSJConfig
-> ReportPeerMetrics m (ConnectionId NodeId)
-> Handlers m NodeId blk
-> Apps
     m
     NodeId
     ByteString
     ByteString
     (AnyMessage (TxSubmission2 (TxId (GenTx blk)) (GenTx blk)))
     (AnyMessage KeepAlive)
     (AnyMessage (PeerSharing NodeId))
     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
-> Tracers m (ConnectionId addrNTN) blk e
-> (NodeToNodeVersion
    -> Codecs blk addrNTN e m bCS bCS bBF bBF bTX bKA bPS)
-> ByteLimits bCS bBF bTX bKA
-> m ChainSyncTimeout
-> ChainSyncLoPBucketConfig
-> CSJConfig
-> ReportPeerMetrics m (ConnectionId addrNTN)
-> Handlers m addrNTN blk
-> Apps m addrNTN bCS bBF bTX bKA bPS NodeToNodeInitiatorResult ()
NTN.mkApps
                  NodeKernel m NodeId Void blk
nodeKernel
                  -- these tracers report every message sent/received by this
                  -- node
                  Tracers m (ConnectionId NodeId) blk CodecError
forall (m :: * -> *) blk peer failure.
(Monad m, HasHeader blk, TracingConstraints blk, Show peer) =>
Tracers m peer blk failure
nullDebugProtocolTracers
                  (TopLevelConfig blk
-> NodeToNodeVersion
-> Codecs
     blk
     NodeId
     CodecError
     m
     ByteString
     ByteString
     ByteString
     ByteString
     (AnyMessage (TxSubmission2 (TxId (GenTx blk)) (GenTx blk)))
     (AnyMessage KeepAlive)
     (AnyMessage (PeerSharing NodeId))
customNodeToNodeCodecs TopLevelConfig blk
pInfoConfig)
                  ByteLimits
  ByteString
  ByteString
  (AnyMessage (TxSubmission2 (TxId (GenTx blk)) (GenTx blk)))
  (AnyMessage KeepAlive)
forall bCS bBF bTX bKA. ByteLimits bCS bBF bTX bKA
NTN.noByteLimits
                  -- see #1882, tests that can't cope with timeouts.
                  (ChainSyncTimeout -> m ChainSyncTimeout
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ChainSyncTimeout -> m ChainSyncTimeout)
-> ChainSyncTimeout -> m ChainSyncTimeout
forall a b. (a -> b) -> a -> b
$ NTN.ChainSyncTimeout
                     { canAwaitTimeout :: Maybe DiffTime
canAwaitTimeout  = Maybe DiffTime
waitForever
                     , intersectTimeout :: Maybe DiffTime
intersectTimeout = Maybe DiffTime
waitForever
                     , mustReplyTimeout :: Maybe DiffTime
mustReplyTimeout = Maybe DiffTime
waitForever
                     , idleTimeout :: Maybe DiffTime
idleTimeout      = Maybe DiffTime
waitForever
                     })
                  ChainSyncLoPBucketConfig
CSClient.ChainSyncLoPBucketDisabled
                  CSJConfig
CSClient.CSJDisabled
                  ReportPeerMetrics m (ConnectionId NodeId)
forall (m :: * -> *) p. MonadSTM m => ReportPeerMetrics m p
nullMetric
                  -- The purpose of this test is not testing protocols, so
                  -- returning constant empty list is fine if we have thorough
                  -- tests about the peer sharing protocol itself.
                  (NodeKernelArgs m NodeId Void blk
-> NodeKernel m NodeId Void blk -> Handlers m NodeId 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 NodeId Void blk
nodeKernelArgs NodeKernel m NodeId Void blk
nodeKernel)

      -- In practice, a robust wallet/user can persistently add a transaction
      -- until it appears on the chain. This thread adds robustness for the
      -- @txs0@ argument, which in practice contains delegation certificates
      -- that the node operator would very insistently add.
      --
      -- It's necessary here because under some circumstances a transaction in
      -- the mempool can be \"lost\" due to no fault of its own. If a dlg cert
      -- is lost, a node that rekeyed can never lead again. Moreover,
      -- promptness of certain transactions simplifies the definition of
      -- corresponding test properties: it's easier to predict whether a
      -- proposal will expire if we're ensured all votes are as prompt as
      -- possible. Lastly, the \"wallet\" might simply need to wait until
      -- enough of the chain is synced that the transaction is valid.
      --
      -- TODO Is there a risk that this will block because the 'forkTxProducer'
      -- fills up the mempool too quickly?
      HasCallStack =>
OracularClock m
-> SlotNo
-> ResourceRegistry m
-> (SlotNo -> STM m ())
-> LedgerConfig blk
-> STM m (LedgerState blk)
-> Mempool m blk
-> [GenTx blk]
-> m ()
OracularClock m
-> SlotNo
-> ResourceRegistry m
-> (SlotNo -> STM m ())
-> LedgerConfig blk
-> STM m (LedgerState blk)
-> Mempool m blk
-> [GenTx blk]
-> m ()
forkCrucialTxs
        OracularClock m
clock
        SlotNo
joinSlot
        ResourceRegistry m
registry
        SlotNo -> STM m ()
unblockForge
        (TopLevelConfig blk -> LedgerConfig blk
forall blk. TopLevelConfig blk -> LedgerConfig blk
configLedger TopLevelConfig blk
pInfoConfig)
        (ExtLedgerState blk -> LedgerState blk
forall blk. ExtLedgerState blk -> LedgerState blk
ledgerState (ExtLedgerState blk -> LedgerState blk)
-> STM m (ExtLedgerState blk) -> STM m (LedgerState blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChainDB m blk -> STM m (ExtLedgerState blk)
forall (m :: * -> *) blk.
(Monad (STM m), IsLedger (LedgerState blk)) =>
ChainDB m blk -> STM m (ExtLedgerState blk)
ChainDB.getCurrentLedger ChainDB m blk
chainDB)
        Mempool m blk
mempool
        [GenTx blk]
txs0

      HasCallStack =>
CoreNodeId
-> ResourceRegistry m
-> OracularClock m
-> TopLevelConfig blk
-> Seed
-> STM m (ExtLedgerState blk)
-> Mempool m blk
-> m ()
CoreNodeId
-> ResourceRegistry m
-> OracularClock m
-> TopLevelConfig blk
-> Seed
-> STM m (ExtLedgerState blk)
-> Mempool m blk
-> m ()
forkTxProducer
        CoreNodeId
coreNodeId
        ResourceRegistry m
registry
        OracularClock m
clock
        TopLevelConfig blk
pInfoConfig
        -- Combine with the CoreNodeId, otherwise each node would generate the
        -- same transactions.
        (Seed
seed Seed -> Word64 -> Seed
forall a. Integral a => Seed -> a -> Seed
`combineWith` CoreNodeId -> Word64
unCoreNodeId CoreNodeId
coreNodeId)
        -- Uses the same varRNG as the block producer, but we split the RNG
        -- each time, so this is fine.
        (ChainDB m blk -> STM m (ExtLedgerState blk)
forall (m :: * -> *) blk.
(Monad (STM m), IsLedger (LedgerState blk)) =>
ChainDB m blk -> STM m (ExtLedgerState blk)
ChainDB.getCurrentLedger ChainDB m blk
chainDB)
        Mempool m blk
mempool

      (NodeKernel m NodeId Void blk, LimitedApp m NodeId blk)
-> m (NodeKernel m NodeId Void blk, LimitedApp m NodeId blk)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (NodeKernel m NodeId Void blk
nodeKernel, Apps
  m
  NodeId
  ByteString
  ByteString
  (AnyMessage (TxSubmission2 (TxId (GenTx blk)) (GenTx blk)))
  (AnyMessage KeepAlive)
  (AnyMessage (PeerSharing NodeId))
  NodeToNodeInitiatorResult
  ()
-> LimitedApp m NodeId blk
forall (m :: * -> *) addr blk.
LimitedApp' m addr blk -> LimitedApp m addr blk
LimitedApp Apps
  m
  NodeId
  ByteString
  ByteString
  (AnyMessage (TxSubmission2 (TxId (GenTx blk)) (GenTx blk)))
  (AnyMessage KeepAlive)
  (AnyMessage (PeerSharing NodeId))
  NodeToNodeInitiatorResult
  ()
app)

    customNodeToNodeCodecs
      :: TopLevelConfig blk
      -> NodeToNodeVersion
      -> NTN.Codecs blk NodeId CodecError m
           Lazy.ByteString
           Lazy.ByteString
           Lazy.ByteString
           Lazy.ByteString
           (AnyMessage (TxSubmission2 (GenTxId blk) (GenTx blk)))
           (AnyMessage KeepAlive)
           (AnyMessage (PeerSharing NodeId))
    customNodeToNodeCodecs :: TopLevelConfig blk
-> NodeToNodeVersion
-> Codecs
     blk
     NodeId
     CodecError
     m
     ByteString
     ByteString
     ByteString
     ByteString
     (AnyMessage (TxSubmission2 (TxId (GenTx blk)) (GenTx blk)))
     (AnyMessage KeepAlive)
     (AnyMessage (PeerSharing NodeId))
customNodeToNodeCodecs TopLevelConfig blk
cfg NodeToNodeVersion
ntnVersion = NTN.Codecs
        { cChainSyncCodec :: Codec
  (ChainSync (Header blk) (Point blk) (Tip blk))
  CodecError
  m
  ByteString
cChainSyncCodec =
            (DeserialiseFailure -> CodecError)
-> Codec
     (ChainSync (Header blk) (Point blk) (Tip blk))
     DeserialiseFailure
     m
     ByteString
-> Codec
     (ChainSync (Header blk) (Point blk) (Tip blk))
     CodecError
     m
     ByteString
forall (m :: * -> *) failure failure' ps bytes.
Functor m =>
(failure -> failure')
-> Codec ps failure m bytes -> Codec ps failure' m bytes
mapFailureCodec (String -> DeserialiseFailure -> CodecError
CodecBytesFailure String
"ChainSync") (Codec
   (ChainSync (Header blk) (Point blk) (Tip blk))
   DeserialiseFailure
   m
   ByteString
 -> Codec
      (ChainSync (Header blk) (Point blk) (Tip blk))
      CodecError
      m
      ByteString)
-> Codec
     (ChainSync (Header blk) (Point blk) (Tip blk))
     DeserialiseFailure
     m
     ByteString
-> Codec
     (ChainSync (Header blk) (Point blk) (Tip blk))
     CodecError
     m
     ByteString
forall a b. (a -> b) -> a -> b
$
              Codecs
  blk
  NodeId
  DeserialiseFailure
  m
  ByteString
  ByteString
  ByteString
  ByteString
  ByteString
  ByteString
  ByteString
-> Codec
     (ChainSync (Header blk) (Point blk) (Tip blk))
     DeserialiseFailure
     m
     ByteString
forall blk addr e (m :: * -> *) bCS bSCS bBF bSBF bTX bKA bPS.
Codecs blk addr e m bCS bSCS bBF bSBF bTX bKA bPS
-> Codec (ChainSync (Header blk) (Point blk) (Tip blk)) e m bCS
NTN.cChainSyncCodec Codecs
  blk
  NodeId
  DeserialiseFailure
  m
  ByteString
  ByteString
  ByteString
  ByteString
  ByteString
  ByteString
  ByteString
binaryProtocolCodecs
        , cChainSyncCodecSerialised :: Codec
  (ChainSync (SerialisedHeader blk) (Point blk) (Tip blk))
  CodecError
  m
  ByteString
cChainSyncCodecSerialised =
            (DeserialiseFailure -> CodecError)
-> Codec
     (ChainSync (SerialisedHeader blk) (Point blk) (Tip blk))
     DeserialiseFailure
     m
     ByteString
-> Codec
     (ChainSync (SerialisedHeader blk) (Point blk) (Tip blk))
     CodecError
     m
     ByteString
forall (m :: * -> *) failure failure' ps bytes.
Functor m =>
(failure -> failure')
-> Codec ps failure m bytes -> Codec ps failure' m bytes
mapFailureCodec (String -> DeserialiseFailure -> CodecError
CodecBytesFailure String
"ChainSyncSerialised") (Codec
   (ChainSync (SerialisedHeader blk) (Point blk) (Tip blk))
   DeserialiseFailure
   m
   ByteString
 -> Codec
      (ChainSync (SerialisedHeader blk) (Point blk) (Tip blk))
      CodecError
      m
      ByteString)
-> Codec
     (ChainSync (SerialisedHeader blk) (Point blk) (Tip blk))
     DeserialiseFailure
     m
     ByteString
-> Codec
     (ChainSync (SerialisedHeader blk) (Point blk) (Tip blk))
     CodecError
     m
     ByteString
forall a b. (a -> b) -> a -> b
$
              Codecs
  blk
  NodeId
  DeserialiseFailure
  m
  ByteString
  ByteString
  ByteString
  ByteString
  ByteString
  ByteString
  ByteString
-> Codec
     (ChainSync (SerialisedHeader blk) (Point blk) (Tip blk))
     DeserialiseFailure
     m
     ByteString
forall blk addr e (m :: * -> *) bCS bSCS bBF bSBF bTX bKA bPS.
Codecs blk addr e m bCS bSCS bBF bSBF bTX bKA bPS
-> Codec
     (ChainSync (SerialisedHeader blk) (Point blk) (Tip blk)) e m bSCS
NTN.cChainSyncCodecSerialised Codecs
  blk
  NodeId
  DeserialiseFailure
  m
  ByteString
  ByteString
  ByteString
  ByteString
  ByteString
  ByteString
  ByteString
binaryProtocolCodecs
        , cBlockFetchCodec :: Codec (BlockFetch blk (Point blk)) CodecError m ByteString
cBlockFetchCodec =
            (DeserialiseFailure -> CodecError)
-> Codec
     (BlockFetch blk (Point blk)) DeserialiseFailure m ByteString
-> Codec (BlockFetch blk (Point blk)) CodecError m ByteString
forall (m :: * -> *) failure failure' ps bytes.
Functor m =>
(failure -> failure')
-> Codec ps failure m bytes -> Codec ps failure' m bytes
mapFailureCodec (String -> DeserialiseFailure -> CodecError
CodecBytesFailure String
"BlockFetch") (Codec (BlockFetch blk (Point blk)) DeserialiseFailure m ByteString
 -> Codec (BlockFetch blk (Point blk)) CodecError m ByteString)
-> Codec
     (BlockFetch blk (Point blk)) DeserialiseFailure m ByteString
-> Codec (BlockFetch blk (Point blk)) CodecError m ByteString
forall a b. (a -> b) -> a -> b
$
              Codecs
  blk
  NodeId
  DeserialiseFailure
  m
  ByteString
  ByteString
  ByteString
  ByteString
  ByteString
  ByteString
  ByteString
-> Codec
     (BlockFetch blk (Point blk)) DeserialiseFailure m ByteString
forall blk addr e (m :: * -> *) bCS bSCS bBF bSBF bTX bKA bPS.
Codecs blk addr e m bCS bSCS bBF bSBF bTX bKA bPS
-> Codec (BlockFetch blk (Point blk)) e m bBF
NTN.cBlockFetchCodec Codecs
  blk
  NodeId
  DeserialiseFailure
  m
  ByteString
  ByteString
  ByteString
  ByteString
  ByteString
  ByteString
  ByteString
binaryProtocolCodecs
        , cBlockFetchCodecSerialised :: Codec
  (BlockFetch (Serialised blk) (Point blk)) CodecError m ByteString
cBlockFetchCodecSerialised =
            (DeserialiseFailure -> CodecError)
-> Codec
     (BlockFetch (Serialised blk) (Point blk))
     DeserialiseFailure
     m
     ByteString
-> Codec
     (BlockFetch (Serialised blk) (Point blk)) CodecError m ByteString
forall (m :: * -> *) failure failure' ps bytes.
Functor m =>
(failure -> failure')
-> Codec ps failure m bytes -> Codec ps failure' m bytes
mapFailureCodec (String -> DeserialiseFailure -> CodecError
CodecBytesFailure String
"BlockFetchSerialised") (Codec
   (BlockFetch (Serialised blk) (Point blk))
   DeserialiseFailure
   m
   ByteString
 -> Codec
      (BlockFetch (Serialised blk) (Point blk)) CodecError m ByteString)
-> Codec
     (BlockFetch (Serialised blk) (Point blk))
     DeserialiseFailure
     m
     ByteString
-> Codec
     (BlockFetch (Serialised blk) (Point blk)) CodecError m ByteString
forall a b. (a -> b) -> a -> b
$
              Codecs
  blk
  NodeId
  DeserialiseFailure
  m
  ByteString
  ByteString
  ByteString
  ByteString
  ByteString
  ByteString
  ByteString
-> Codec
     (BlockFetch (Serialised blk) (Point blk))
     DeserialiseFailure
     m
     ByteString
forall blk addr e (m :: * -> *) bCS bSCS bBF bSBF bTX bKA bPS.
Codecs blk addr e m bCS bSCS bBF bSBF bTX bKA bPS
-> Codec (BlockFetch (Serialised blk) (Point blk)) e m bSBF
NTN.cBlockFetchCodecSerialised Codecs
  blk
  NodeId
  DeserialiseFailure
  m
  ByteString
  ByteString
  ByteString
  ByteString
  ByteString
  ByteString
  ByteString
binaryProtocolCodecs
        , cTxSubmission2Codec :: Codec
  (TxSubmission2 (TxId (GenTx blk)) (GenTx blk))
  CodecError
  m
  (AnyMessage (TxSubmission2 (TxId (GenTx blk)) (GenTx blk)))
cTxSubmission2Codec =
            (CodecFailure -> CodecError)
-> Codec
     (TxSubmission2 (TxId (GenTx blk)) (GenTx blk))
     CodecFailure
     m
     (AnyMessage (TxSubmission2 (TxId (GenTx blk)) (GenTx blk)))
-> Codec
     (TxSubmission2 (TxId (GenTx blk)) (GenTx blk))
     CodecError
     m
     (AnyMessage (TxSubmission2 (TxId (GenTx blk)) (GenTx blk)))
forall (m :: * -> *) failure failure' ps bytes.
Functor m =>
(failure -> failure')
-> Codec ps failure m bytes -> Codec ps failure' m bytes
mapFailureCodec CodecFailure -> CodecError
CodecIdFailure (Codec
   (TxSubmission2 (TxId (GenTx blk)) (GenTx blk))
   CodecFailure
   m
   (AnyMessage (TxSubmission2 (TxId (GenTx blk)) (GenTx blk)))
 -> Codec
      (TxSubmission2 (TxId (GenTx blk)) (GenTx blk))
      CodecError
      m
      (AnyMessage (TxSubmission2 (TxId (GenTx blk)) (GenTx blk))))
-> Codec
     (TxSubmission2 (TxId (GenTx blk)) (GenTx blk))
     CodecFailure
     m
     (AnyMessage (TxSubmission2 (TxId (GenTx blk)) (GenTx blk)))
-> Codec
     (TxSubmission2 (TxId (GenTx blk)) (GenTx blk))
     CodecError
     m
     (AnyMessage (TxSubmission2 (TxId (GenTx blk)) (GenTx blk)))
forall a b. (a -> b) -> a -> b
$
              Codecs
  blk
  Any
  CodecFailure
  m
  (AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk)))
  (AnyMessage
     (ChainSync (SerialisedHeader blk) (Point blk) (Tip blk)))
  (AnyMessage (BlockFetch blk (Point blk)))
  (AnyMessage (BlockFetch (Serialised blk) (Point blk)))
  (AnyMessage (TxSubmission2 (TxId (GenTx blk)) (GenTx blk)))
  (AnyMessage KeepAlive)
  (AnyMessage (PeerSharing Any))
-> Codec
     (TxSubmission2 (TxId (GenTx blk)) (GenTx blk))
     CodecFailure
     m
     (AnyMessage (TxSubmission2 (TxId (GenTx blk)) (GenTx blk)))
forall blk addr e (m :: * -> *) bCS bSCS bBF bSBF bTX bKA bPS.
Codecs blk addr e m bCS bSCS bBF bSBF bTX bKA bPS
-> Codec (TxSubmission2 (GenTxId blk) (GenTx blk)) e m bTX
NTN.cTxSubmission2Codec Codecs
  blk
  Any
  CodecFailure
  m
  (AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk)))
  (AnyMessage
     (ChainSync (SerialisedHeader blk) (Point blk) (Tip blk)))
  (AnyMessage (BlockFetch blk (Point blk)))
  (AnyMessage (BlockFetch (Serialised blk) (Point blk)))
  (AnyMessage (TxSubmission2 (TxId (GenTx blk)) (GenTx blk)))
  (AnyMessage KeepAlive)
  (AnyMessage (PeerSharing Any))
forall (m :: * -> *) blk addr.
Monad m =>
Codecs
  blk
  addr
  CodecFailure
  m
  (AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk)))
  (AnyMessage
     (ChainSync (SerialisedHeader blk) (Point blk) (Tip blk)))
  (AnyMessage (BlockFetch blk (Point blk)))
  (AnyMessage (BlockFetch (Serialised blk) (Point blk)))
  (AnyMessage (TxSubmission2 (GenTxId blk) (GenTx blk)))
  (AnyMessage KeepAlive)
  (AnyMessage (PeerSharing addr))
NTN.identityCodecs
        , cKeepAliveCodec :: Codec KeepAlive CodecError m (AnyMessage KeepAlive)
cKeepAliveCodec =
            (CodecFailure -> CodecError)
-> Codec KeepAlive CodecFailure m (AnyMessage KeepAlive)
-> Codec KeepAlive CodecError m (AnyMessage KeepAlive)
forall (m :: * -> *) failure failure' ps bytes.
Functor m =>
(failure -> failure')
-> Codec ps failure m bytes -> Codec ps failure' m bytes
mapFailureCodec CodecFailure -> CodecError
CodecIdFailure (Codec KeepAlive CodecFailure m (AnyMessage KeepAlive)
 -> Codec KeepAlive CodecError m (AnyMessage KeepAlive))
-> Codec KeepAlive CodecFailure m (AnyMessage KeepAlive)
-> Codec KeepAlive CodecError m (AnyMessage KeepAlive)
forall a b. (a -> b) -> a -> b
$
              Codecs
  Any
  Any
  CodecFailure
  m
  (AnyMessage (ChainSync (Header Any) (Point Any) (Tip Any)))
  (AnyMessage
     (ChainSync (SerialisedHeader Any) (Point Any) (Tip Any)))
  (AnyMessage (BlockFetch Any (Point Any)))
  (AnyMessage (BlockFetch (Serialised Any) (Point Any)))
  (AnyMessage (TxSubmission2 (GenTxId Any) (GenTx Any)))
  (AnyMessage KeepAlive)
  (AnyMessage (PeerSharing Any))
-> Codec KeepAlive CodecFailure m (AnyMessage KeepAlive)
forall blk addr e (m :: * -> *) bCS bSCS bBF bSBF bTX bKA bPS.
Codecs blk addr e m bCS bSCS bBF bSBF bTX bKA bPS
-> Codec KeepAlive e m bKA
NTN.cKeepAliveCodec Codecs
  Any
  Any
  CodecFailure
  m
  (AnyMessage (ChainSync (Header Any) (Point Any) (Tip Any)))
  (AnyMessage
     (ChainSync (SerialisedHeader Any) (Point Any) (Tip Any)))
  (AnyMessage (BlockFetch Any (Point Any)))
  (AnyMessage (BlockFetch (Serialised Any) (Point Any)))
  (AnyMessage (TxSubmission2 (GenTxId Any) (GenTx Any)))
  (AnyMessage KeepAlive)
  (AnyMessage (PeerSharing Any))
forall (m :: * -> *) blk addr.
Monad m =>
Codecs
  blk
  addr
  CodecFailure
  m
  (AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk)))
  (AnyMessage
     (ChainSync (SerialisedHeader blk) (Point blk) (Tip blk)))
  (AnyMessage (BlockFetch blk (Point blk)))
  (AnyMessage (BlockFetch (Serialised blk) (Point blk)))
  (AnyMessage (TxSubmission2 (GenTxId blk) (GenTx blk)))
  (AnyMessage KeepAlive)
  (AnyMessage (PeerSharing addr))
NTN.identityCodecs
        , cPeerSharingCodec :: Codec
  (PeerSharing NodeId) CodecError m (AnyMessage (PeerSharing NodeId))
cPeerSharingCodec =
            (CodecFailure -> CodecError)
-> Codec
     (PeerSharing NodeId)
     CodecFailure
     m
     (AnyMessage (PeerSharing NodeId))
-> Codec
     (PeerSharing NodeId) CodecError m (AnyMessage (PeerSharing NodeId))
forall (m :: * -> *) failure failure' ps bytes.
Functor m =>
(failure -> failure')
-> Codec ps failure m bytes -> Codec ps failure' m bytes
mapFailureCodec CodecFailure -> CodecError
CodecIdFailure (Codec
   (PeerSharing NodeId)
   CodecFailure
   m
   (AnyMessage (PeerSharing NodeId))
 -> Codec
      (PeerSharing NodeId)
      CodecError
      m
      (AnyMessage (PeerSharing NodeId)))
-> Codec
     (PeerSharing NodeId)
     CodecFailure
     m
     (AnyMessage (PeerSharing NodeId))
-> Codec
     (PeerSharing NodeId) CodecError m (AnyMessage (PeerSharing NodeId))
forall a b. (a -> b) -> a -> b
$
              Codecs
  Any
  NodeId
  CodecFailure
  m
  (AnyMessage (ChainSync (Header Any) (Point Any) (Tip Any)))
  (AnyMessage
     (ChainSync (SerialisedHeader Any) (Point Any) (Tip Any)))
  (AnyMessage (BlockFetch Any (Point Any)))
  (AnyMessage (BlockFetch (Serialised Any) (Point Any)))
  (AnyMessage (TxSubmission2 (GenTxId Any) (GenTx Any)))
  (AnyMessage KeepAlive)
  (AnyMessage (PeerSharing NodeId))
-> Codec
     (PeerSharing NodeId)
     CodecFailure
     m
     (AnyMessage (PeerSharing NodeId))
forall blk addr e (m :: * -> *) bCS bSCS bBF bSBF bTX bKA bPS.
Codecs blk addr e m bCS bSCS bBF bSBF bTX bKA bPS
-> Codec (PeerSharing addr) e m bPS
NTN.cPeerSharingCodec Codecs
  Any
  NodeId
  CodecFailure
  m
  (AnyMessage (ChainSync (Header Any) (Point Any) (Tip Any)))
  (AnyMessage
     (ChainSync (SerialisedHeader Any) (Point Any) (Tip Any)))
  (AnyMessage (BlockFetch Any (Point Any)))
  (AnyMessage (BlockFetch (Serialised Any) (Point Any)))
  (AnyMessage (TxSubmission2 (GenTxId Any) (GenTx Any)))
  (AnyMessage KeepAlive)
  (AnyMessage (PeerSharing NodeId))
forall (m :: * -> *) blk addr.
Monad m =>
Codecs
  blk
  addr
  CodecFailure
  m
  (AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk)))
  (AnyMessage
     (ChainSync (SerialisedHeader blk) (Point blk) (Tip blk)))
  (AnyMessage (BlockFetch blk (Point blk)))
  (AnyMessage (BlockFetch (Serialised blk) (Point blk)))
  (AnyMessage (TxSubmission2 (GenTxId blk) (GenTx blk)))
  (AnyMessage KeepAlive)
  (AnyMessage (PeerSharing addr))
NTN.identityCodecs
        }
      where
        binaryProtocolCodecs :: Codecs
  blk
  NodeId
  DeserialiseFailure
  m
  ByteString
  ByteString
  ByteString
  ByteString
  ByteString
  ByteString
  ByteString
binaryProtocolCodecs = CodecConfig blk
-> BlockNodeToNodeVersion blk
-> (NodeToNodeVersion -> NodeId -> Encoding)
-> (NodeToNodeVersion -> forall s. Decoder s NodeId)
-> NodeToNodeVersion
-> Codecs
     blk
     NodeId
     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 (TopLevelConfig blk -> CodecConfig blk
forall blk. TopLevelConfig blk -> CodecConfig blk
configCodec TopLevelConfig blk
cfg) BlockNodeToNodeVersion blk
blockVersion ((NodeId -> Encoding) -> NodeToNodeVersion -> NodeId -> Encoding
forall a b. a -> b -> a
const NodeId -> Encoding
encodeNodeId) (Decoder s NodeId -> NodeToNodeVersion -> Decoder s NodeId
forall a b. a -> b -> a
const Decoder s NodeId
forall s. Decoder s NodeId
decodeNodeId) NodeToNodeVersion
ntnVersion

-- | Sum of 'CodecFailure' (from @identityCodecs@) and 'DeserialiseFailure'
-- (from @defaultCodecs@).
data CodecError
  = CodecIdFailure CodecFailure
  | CodecBytesFailure
      String  -- ^ Extra error message, e.g., the name of the codec
      DeserialiseFailure
  deriving (Int -> CodecError -> ShowS
[CodecError] -> ShowS
CodecError -> String
(Int -> CodecError -> ShowS)
-> (CodecError -> String)
-> ([CodecError] -> ShowS)
-> Show CodecError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CodecError -> ShowS
showsPrec :: Int -> CodecError -> ShowS
$cshow :: CodecError -> String
show :: CodecError -> String
$cshowList :: [CodecError] -> ShowS
showList :: [CodecError] -> ShowS
Show, Show CodecError
Typeable CodecError
(Typeable CodecError, Show CodecError) =>
(CodecError -> SomeException)
-> (SomeException -> Maybe CodecError)
-> (CodecError -> String)
-> Exception CodecError
SomeException -> Maybe CodecError
CodecError -> String
CodecError -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e) -> (e -> String) -> Exception e
$ctoException :: CodecError -> SomeException
toException :: CodecError -> SomeException
$cfromException :: SomeException -> Maybe CodecError
fromException :: SomeException -> Maybe CodecError
$cdisplayException :: CodecError -> String
displayException :: CodecError -> String
Exception)

{-------------------------------------------------------------------------------
  Running an edge
-------------------------------------------------------------------------------}

-- | Cause for an edge to restart
--
data RestartCause
  = RestartScheduled
    -- ^ restart because at least one of the two nodes set its status to
    -- 'VFalling' because of a scheduled restart in 'tnaRestarts'
  | RestartChainSyncTerminated
    -- ^ restart because the ChainSync client terminated the mini protocol

-- | Fork two directed edges, one in each direction between the two vertices
--
forkBothEdges ::
     (IOLike m, RunNode blk, HasCallStack)
  => ResourceRegistry m
  -> OracularClock m
  -> Tracer m (SlotNo, MiniProtocolState)
  -> (NodeToNodeVersion, BlockNodeToNodeVersion blk)
  -> (CodecConfig blk, CalcMessageDelay blk)
  -> Map CoreNodeId (VertexStatusVar m blk)
  -> (CoreNodeId, CoreNodeId)
  -> m [((CoreNodeId, CoreNodeId), EdgeStatusVar m)]
forkBothEdges :: forall (m :: * -> *) blk.
(IOLike m, RunNode blk, HasCallStack) =>
ResourceRegistry m
-> OracularClock m
-> Tracer m (SlotNo, MiniProtocolState)
-> (NodeToNodeVersion, BlockNodeToNodeVersion blk)
-> (CodecConfig blk, CalcMessageDelay blk)
-> Map CoreNodeId (VertexStatusVar m blk)
-> (CoreNodeId, CoreNodeId)
-> m [((CoreNodeId, CoreNodeId), EdgeStatusVar m)]
forkBothEdges ResourceRegistry m
sharedRegistry OracularClock m
clock Tracer m (SlotNo, MiniProtocolState)
tr (NodeToNodeVersion, BlockNodeToNodeVersion blk)
version (CodecConfig blk, CalcMessageDelay blk)
cfg Map CoreNodeId (VertexStatusVar m blk)
vertexStatusVars (CoreNodeId
node1, CoreNodeId
node2) = do
  let endpoint1 :: (CoreNodeId, VertexStatusVar m blk)
endpoint1 = CoreNodeId -> (CoreNodeId, VertexStatusVar m blk)
mkEndpoint CoreNodeId
node1
      endpoint2 :: (CoreNodeId, VertexStatusVar m blk)
endpoint2 = CoreNodeId -> (CoreNodeId, VertexStatusVar m blk)
mkEndpoint CoreNodeId
node2
      mkEndpoint :: CoreNodeId -> (CoreNodeId, VertexStatusVar m blk)
mkEndpoint CoreNodeId
node = case CoreNodeId
-> Map CoreNodeId (VertexStatusVar m blk)
-> Maybe (VertexStatusVar m blk)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup CoreNodeId
node Map CoreNodeId (VertexStatusVar m blk)
vertexStatusVars of
          Maybe (VertexStatusVar m blk)
Nothing  -> String -> (CoreNodeId, VertexStatusVar m blk)
forall a. HasCallStack => String -> a
error (String -> (CoreNodeId, VertexStatusVar m blk))
-> String -> (CoreNodeId, VertexStatusVar m blk)
forall a b. (a -> b) -> a -> b
$ String
"node not found: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ CoreNodeId -> String
forall a. Show a => a -> String
show CoreNodeId
node
          Just VertexStatusVar m blk
var -> (CoreNodeId
node, VertexStatusVar m blk
var)

  let mkDirEdge :: (CoreNodeId, VertexStatusVar m blk)
-> (CoreNodeId, VertexStatusVar m blk)
-> m ((CoreNodeId, CoreNodeId), EdgeStatusVar m)
mkDirEdge (CoreNodeId, VertexStatusVar m blk)
e1 (CoreNodeId, VertexStatusVar m blk)
e2 = do
        EdgeStatusVar m
v <- EdgeStatus -> m (EdgeStatusVar m)
forall (m :: * -> *) a. MonadSTM m => a -> m (StrictTVar m a)
uncheckedNewTVarM EdgeStatus
EDown
        let label :: String
label = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
              [String
"directed-edge-", CoreNodeId -> String
forall a. Condense a => a -> String
condense ((CoreNodeId, VertexStatusVar m blk) -> CoreNodeId
forall a b. (a, b) -> a
fst (CoreNodeId, VertexStatusVar m blk)
e1), String
"-", CoreNodeId -> String
forall a. Condense a => a -> String
condense ((CoreNodeId, VertexStatusVar m blk) -> CoreNodeId
forall a b. (a, b) -> a
fst (CoreNodeId, VertexStatusVar m blk)
e2)]
        m (Thread m ()) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (Thread m ()) -> m ()) -> m (Thread m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ ResourceRegistry m -> String -> m () -> m (Thread m ())
forall (m :: * -> *) a.
(MonadAsync m, MonadFork m, MonadMask m, HasCallStack) =>
ResourceRegistry m -> String -> m a -> m (Thread m a)
forkLinkedThread ResourceRegistry m
sharedRegistry String
label (m () -> m (Thread m ())) -> m () -> m (Thread m ())
forall a b. (a -> b) -> a -> b
$ do
          ResourceRegistry m
-> Tracer m (SlotNo, MiniProtocolState)
-> (NodeToNodeVersion, BlockNodeToNodeVersion blk)
-> (CodecConfig blk, CalcMessageDelay blk)
-> OracularClock m
-> EdgeStatusVar m
-> (CoreNodeId, VertexStatusVar m blk)
-> (CoreNodeId, VertexStatusVar m blk)
-> m ()
forall (m :: * -> *) blk.
(IOLike m, RunNode blk) =>
ResourceRegistry m
-> Tracer m (SlotNo, MiniProtocolState)
-> (NodeToNodeVersion, BlockNodeToNodeVersion blk)
-> (CodecConfig blk, CalcMessageDelay blk)
-> OracularClock m
-> EdgeStatusVar m
-> (CoreNodeId, VertexStatusVar m blk)
-> (CoreNodeId, VertexStatusVar m blk)
-> m ()
directedEdge ResourceRegistry m
sharedRegistry Tracer m (SlotNo, MiniProtocolState)
tr (NodeToNodeVersion, BlockNodeToNodeVersion blk)
version (CodecConfig blk, CalcMessageDelay blk)
cfg OracularClock m
clock EdgeStatusVar m
v (CoreNodeId, VertexStatusVar m blk)
e1 (CoreNodeId, VertexStatusVar m blk)
e2
        ((CoreNodeId, CoreNodeId), EdgeStatusVar m)
-> m ((CoreNodeId, CoreNodeId), EdgeStatusVar m)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (((CoreNodeId, VertexStatusVar m blk) -> CoreNodeId
forall a b. (a, b) -> a
fst (CoreNodeId, VertexStatusVar m blk)
e1, (CoreNodeId, VertexStatusVar m blk) -> CoreNodeId
forall a b. (a, b) -> a
fst (CoreNodeId, VertexStatusVar m blk)
e2), EdgeStatusVar m
v)

  ((CoreNodeId, CoreNodeId), EdgeStatusVar m)
ev12 <- (CoreNodeId, VertexStatusVar m blk)
-> (CoreNodeId, VertexStatusVar m blk)
-> m ((CoreNodeId, CoreNodeId), EdgeStatusVar m)
mkDirEdge (CoreNodeId, VertexStatusVar m blk)
endpoint1 (CoreNodeId, VertexStatusVar m blk)
endpoint2
  ((CoreNodeId, CoreNodeId), EdgeStatusVar m)
ev21 <- (CoreNodeId, VertexStatusVar m blk)
-> (CoreNodeId, VertexStatusVar m blk)
-> m ((CoreNodeId, CoreNodeId), EdgeStatusVar m)
mkDirEdge (CoreNodeId, VertexStatusVar m blk)
endpoint2 (CoreNodeId, VertexStatusVar m blk)
endpoint1

  [((CoreNodeId, CoreNodeId), EdgeStatusVar m)]
-> m [((CoreNodeId, CoreNodeId), EdgeStatusVar m)]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [((CoreNodeId, CoreNodeId), EdgeStatusVar m)
ev12, ((CoreNodeId, CoreNodeId), EdgeStatusVar m)
ev21]

-- | Spawn all mini protocols' threads for a given directed edge in the node
-- network topology (ie an ordered pair of core nodes, with client first and
-- server second)
--
-- The edge cannot start until both nodes are simultaneously 'VUp'.
--
-- The edge may restart itself for the reasons modeled by 'RestartCause'
--
-- The actual control flow here does not faithfully model the real
-- implementation. On an exception, for example, the actual node implementation
-- kills the other threads on the same peer as the thread that threw the
-- exception, and then relies on TCP socket semantics to eventually kill the
-- corresponding threads on the remote peer. The client node recreates its
-- client threads after a delay, and they reconnect to the remote peer, thereby
-- recreating the server threads.
--
-- This model instead propagates the exception to the rest of the /un/directed
-- edge via the @async@ interface rather than relying on some sort of mock
-- socket semantics to convey the cancellation.
directedEdge ::
  forall m blk. (IOLike m, RunNode blk)
  => ResourceRegistry m
  -> Tracer m (SlotNo, MiniProtocolState)
  -> (NodeToNodeVersion, BlockNodeToNodeVersion blk)
  -> (CodecConfig blk, CalcMessageDelay blk)
  -> OracularClock m
  -> EdgeStatusVar m
  -> (CoreNodeId, VertexStatusVar m blk)
  -> (CoreNodeId, VertexStatusVar m blk)
  -> m ()
directedEdge :: forall (m :: * -> *) blk.
(IOLike m, RunNode blk) =>
ResourceRegistry m
-> Tracer m (SlotNo, MiniProtocolState)
-> (NodeToNodeVersion, BlockNodeToNodeVersion blk)
-> (CodecConfig blk, CalcMessageDelay blk)
-> OracularClock m
-> EdgeStatusVar m
-> (CoreNodeId, VertexStatusVar m blk)
-> (CoreNodeId, VertexStatusVar m blk)
-> m ()
directedEdge ResourceRegistry m
registry Tracer m (SlotNo, MiniProtocolState)
tr (NodeToNodeVersion, BlockNodeToNodeVersion blk)
version (CodecConfig blk, CalcMessageDelay blk)
cfg OracularClock m
clock EdgeStatusVar m
edgeStatusVar (CoreNodeId, VertexStatusVar m blk)
client (CoreNodeId, VertexStatusVar m blk)
server =
    m ()
loop
  where
    loop :: m ()
loop = do
        RestartCause
restart <- ResourceRegistry m
-> OracularClock m
-> (NodeToNodeVersion, BlockNodeToNodeVersion blk)
-> (CodecConfig blk, CalcMessageDelay blk)
-> EdgeStatusVar m
-> (CoreNodeId, VertexStatusVar m blk)
-> (CoreNodeId, VertexStatusVar m blk)
-> m RestartCause
forall (m :: * -> *) blk.
(IOLike m, RunNode blk) =>
ResourceRegistry m
-> OracularClock m
-> (NodeToNodeVersion, BlockNodeToNodeVersion blk)
-> (CodecConfig blk, CalcMessageDelay blk)
-> EdgeStatusVar m
-> (CoreNodeId, VertexStatusVar m blk)
-> (CoreNodeId, VertexStatusVar m blk)
-> m RestartCause
directedEdgeInner ResourceRegistry m
registry OracularClock m
clock (NodeToNodeVersion, BlockNodeToNodeVersion blk)
version (CodecConfig blk, CalcMessageDelay blk)
cfg EdgeStatusVar m
edgeStatusVar (CoreNodeId, VertexStatusVar m blk)
client (CoreNodeId, VertexStatusVar m blk)
server
          m RestartCause
-> (SomeException -> m RestartCause) -> m RestartCause
forall e a. Exception e => m a -> (e -> m a) -> m a
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` SomeException -> m RestartCause
forall a. SomeException -> m a
hUnexpected
        STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ EdgeStatusVar m -> EdgeStatus -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar EdgeStatusVar m
edgeStatusVar EdgeStatus
EDown
        case RestartCause
restart of
          RestartCause
RestartScheduled            -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          RestartCause
RestartChainSyncTerminated  -> do
            -- "error" policy: restart at beginning of next slot
            SlotNo
s <- OracularClock m -> m SlotNo
forall (m :: * -> *). OracularClock m -> m SlotNo
OracularClock.getCurrentSlot OracularClock m
clock
            let s' :: SlotNo
s' = SlotNo -> SlotNo
forall a. Enum a => a -> a
succ SlotNo
s
            Tracer m (SlotNo, MiniProtocolState)
-> (SlotNo, MiniProtocolState) -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (SlotNo, MiniProtocolState)
tr (SlotNo
s, MiniProtocolState
MiniProtocolDelayed)
            m Bool -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m Bool -> m ()) -> m Bool -> m ()
forall a b. (a -> b) -> a -> b
$ OracularClock m -> SlotNo -> m Bool
forall (m :: * -> *). OracularClock m -> SlotNo -> m Bool
OracularClock.blockUntilSlot OracularClock m
clock SlotNo
s'
            Tracer m (SlotNo, MiniProtocolState)
-> (SlotNo, MiniProtocolState) -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (SlotNo, MiniProtocolState)
tr (SlotNo
s', MiniProtocolState
MiniProtocolRestarting)
        m ()
loop
      where
        -- Wrap synchronous exceptions in 'MiniProtocolFatalException'
        --
        hUnexpected :: forall a. SomeException -> m a
        hUnexpected :: forall a. SomeException -> m a
hUnexpected e :: SomeException
e@(Exn.SomeException e
e') = case SomeException -> Maybe AsyncException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
          Just (AsyncException
_ :: Exn.AsyncException) -> SomeException -> m a
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO SomeException
e
          Maybe AsyncException
Nothing                        -> case SomeException -> Maybe SomeAsyncException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
            Just (SomeAsyncException
_ :: Exn.SomeAsyncException) -> SomeException -> m a
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO SomeException
e
            Maybe SomeAsyncException
Nothing                            -> MiniProtocolFatalException -> m a
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO MiniProtocolFatalException
              { mpfeType :: TypeRep
mpfeType   = e -> TypeRep
forall a. Typeable a => a -> TypeRep
Typeable.typeOf e
e'
              , mpfeExn :: SomeException
mpfeExn    = SomeException
e
              , mpfeClient :: CoreNodeId
mpfeClient = (CoreNodeId, VertexStatusVar m blk) -> CoreNodeId
forall a b. (a, b) -> a
fst (CoreNodeId, VertexStatusVar m blk)
client
              , mpfeServer :: CoreNodeId
mpfeServer = (CoreNodeId, VertexStatusVar m blk) -> CoreNodeId
forall a b. (a, b) -> a
fst (CoreNodeId, VertexStatusVar m blk)
server
              }

-- | Spawn threads for all of the mini protocols
--
-- See 'directedEdge'.
directedEdgeInner ::
  forall m blk. (IOLike m, RunNode blk)
  => ResourceRegistry m
  -> OracularClock m
  -> (NodeToNodeVersion, BlockNodeToNodeVersion blk)
  -> (CodecConfig blk, CalcMessageDelay blk)
  -> EdgeStatusVar m
  -> (CoreNodeId, VertexStatusVar m blk)
     -- ^ client threads on this node
  -> (CoreNodeId, VertexStatusVar m blk)
     -- ^ server threads on this node
  -> m RestartCause
directedEdgeInner :: forall (m :: * -> *) blk.
(IOLike m, RunNode blk) =>
ResourceRegistry m
-> OracularClock m
-> (NodeToNodeVersion, BlockNodeToNodeVersion blk)
-> (CodecConfig blk, CalcMessageDelay blk)
-> EdgeStatusVar m
-> (CoreNodeId, VertexStatusVar m blk)
-> (CoreNodeId, VertexStatusVar m blk)
-> m RestartCause
directedEdgeInner ResourceRegistry m
registry OracularClock m
clock (NodeToNodeVersion
version, BlockNodeToNodeVersion blk
blockVersion) (CodecConfig blk
cfg, CalcMessageDelay blk
calcMessageDelay) EdgeStatusVar m
edgeStatusVar
  (CoreNodeId
node1, VertexStatusVar m blk
vertexStatusVar1) (CoreNodeId
node2, VertexStatusVar m blk
vertexStatusVar2) = do
    -- block until both nodes are 'VUp'
    (LimitedApp LimitedApp' m NodeId blk
app1, LimitedApp LimitedApp' m NodeId blk
app2) <- STM m (LimitedApp m NodeId blk, LimitedApp m NodeId blk)
-> m (LimitedApp m NodeId blk, LimitedApp m NodeId blk)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (LimitedApp m NodeId blk, LimitedApp m NodeId blk)
 -> m (LimitedApp m NodeId blk, LimitedApp m NodeId blk))
-> STM m (LimitedApp m NodeId blk, LimitedApp m NodeId blk)
-> m (LimitedApp m NodeId blk, LimitedApp m NodeId blk)
forall a b. (a -> b) -> a -> b
$ do
      (,) (LimitedApp m NodeId blk
 -> LimitedApp m NodeId blk
 -> (LimitedApp m NodeId blk, LimitedApp m NodeId blk))
-> STM m (LimitedApp m NodeId blk)
-> STM
     m
     (LimitedApp m NodeId blk
      -> (LimitedApp m NodeId blk, LimitedApp m NodeId blk))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> VertexStatusVar m blk -> STM m (LimitedApp m NodeId blk)
forall {m :: * -> *} {m :: * -> *} {blk}.
MonadSTM m =>
StrictTVar m (VertexStatus m blk)
-> STM m (LimitedApp m NodeId blk)
getApp VertexStatusVar m blk
vertexStatusVar1 STM
  m
  (LimitedApp m NodeId blk
   -> (LimitedApp m NodeId blk, LimitedApp m NodeId blk))
-> STM m (LimitedApp m NodeId blk)
-> STM m (LimitedApp m NodeId blk, LimitedApp m NodeId blk)
forall a b. STM m (a -> b) -> STM m a -> STM m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> VertexStatusVar m blk -> STM m (LimitedApp m NodeId blk)
forall {m :: * -> *} {m :: * -> *} {blk}.
MonadSTM m =>
StrictTVar m (VertexStatus m blk)
-> STM m (LimitedApp m NodeId blk)
getApp VertexStatusVar m blk
vertexStatusVar2

    STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ EdgeStatusVar m -> EdgeStatus -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar EdgeStatusVar m
edgeStatusVar EdgeStatus
EUp

    let miniProtocol ::
             String
             -- ^ protocol name
          -> (String -> a -> RestartCause)
          -> (String -> b -> RestartCause)
          -> (  LimitedApp' m NodeId blk
             -> NodeToNodeVersion
             -> ExpandedInitiatorContext NodeId m
             -> Channel m msg
             -> m (a, trailingBytes)
             )
            -- ^ client action to run on node1
          -> (  LimitedApp' m NodeId blk
             -> NodeToNodeVersion
             -> ResponderContext NodeId
             -> Channel m msg
             -> m (b, trailingBytes)
             )
             -- ^ server action to run on node2
          -> (msg -> m ())
          -> m (m RestartCause, m RestartCause)
        miniProtocol :: forall a b msg trailingBytes.
String
-> (String -> a -> RestartCause)
-> (String -> b -> RestartCause)
-> (LimitedApp' m NodeId blk
    -> NodeToNodeVersion
    -> ExpandedInitiatorContext NodeId m
    -> Channel m msg
    -> m (a, trailingBytes))
-> (LimitedApp' m NodeId blk
    -> NodeToNodeVersion
    -> ResponderContext NodeId
    -> Channel m msg
    -> m (b, trailingBytes))
-> (msg -> m ())
-> m (m RestartCause, m RestartCause)
miniProtocol String
proto String -> a -> RestartCause
retClient String -> b -> RestartCause
retServer LimitedApp' m NodeId blk
-> NodeToNodeVersion
-> ExpandedInitiatorContext NodeId m
-> Channel m msg
-> m (a, trailingBytes)
client LimitedApp' m NodeId blk
-> NodeToNodeVersion
-> ResponderContext NodeId
-> Channel m msg
-> m (b, trailingBytes)
server msg -> m ()
middle = do
             (Channel m msg
chan, Channel m msg
dualChan) <-
               ResourceRegistry m
-> (CoreNodeId, CoreNodeId, String)
-> (msg -> m ())
-> m (Channel m msg, Channel m msg)
forall (m :: * -> *) a.
IOLike m =>
ResourceRegistry m
-> (CoreNodeId, CoreNodeId, String)
-> (a -> m ())
-> m (Channel m a, Channel m a)
createConnectedChannelsWithDelay ResourceRegistry m
registry (CoreNodeId
node1, CoreNodeId
node2, String
proto) msg -> m ()
middle
             (m RestartCause, m RestartCause)
-> m (m RestartCause, m RestartCause)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
               ( (String -> a -> RestartCause
retClient (String
proto String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
".client") (a -> RestartCause)
-> ((a, trailingBytes) -> a) -> (a, trailingBytes) -> RestartCause
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, trailingBytes) -> a
forall a b. (a, b) -> a
fst) ((a, trailingBytes) -> RestartCause)
-> m (a, trailingBytes) -> m RestartCause
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LimitedApp' m NodeId blk
-> NodeToNodeVersion
-> ExpandedInitiatorContext NodeId m
-> Channel m msg
-> m (a, trailingBytes)
client LimitedApp' m NodeId blk
app1 NodeToNodeVersion
version ExpandedInitiatorContext NodeId m
initiatorCtx Channel m msg
chan
               , (String -> b -> RestartCause
retServer (String
proto String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
".server") (b -> RestartCause)
-> ((b, trailingBytes) -> b) -> (b, trailingBytes) -> RestartCause
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b, trailingBytes) -> b
forall a b. (a, b) -> a
fst) ((b, trailingBytes) -> RestartCause)
-> m (b, trailingBytes) -> m RestartCause
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LimitedApp' m NodeId blk
-> NodeToNodeVersion
-> ResponderContext NodeId
-> Channel m msg
-> m (b, trailingBytes)
server LimitedApp' m NodeId blk
app2 NodeToNodeVersion
version ResponderContext NodeId
responderCtx Channel m msg
dualChan
               )
          where
            initiatorCtx :: ExpandedInitiatorContext NodeId m
initiatorCtx = ExpandedInitiatorContext {
                eicConnectionId :: ConnectionId NodeId
eicConnectionId    = NodeId -> NodeId -> ConnectionId NodeId
forall addr. addr -> addr -> ConnectionId addr
ConnectionId (CoreNodeId -> NodeId
fromCoreNodeId CoreNodeId
node1) (CoreNodeId -> NodeId
fromCoreNodeId CoreNodeId
node2),
                eicControlMessage :: ControlMessageSTM m
eicControlMessage  = ControlMessage -> ControlMessageSTM m
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return ControlMessage
Continue,
                eicIsBigLedgerPeer :: IsBigLedgerPeer
eicIsBigLedgerPeer = IsBigLedgerPeer
IsNotBigLedgerPeer
              }
            responderCtx :: ResponderContext NodeId
responderCtx = ResponderContext {
                rcConnectionId :: ConnectionId NodeId
rcConnectionId     = NodeId -> NodeId -> ConnectionId NodeId
forall addr. addr -> addr -> ConnectionId addr
ConnectionId (CoreNodeId -> NodeId
fromCoreNodeId CoreNodeId
node1) (CoreNodeId -> NodeId
fromCoreNodeId CoreNodeId
node2)
              }

    (m (NonEmpty (m RestartCause))
-> (NonEmpty (m RestartCause) -> m RestartCause) -> m RestartCause
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= NonEmpty (m RestartCause) -> m RestartCause
forall (m :: * -> *) a. IOLike m => NonEmpty (m a) -> m a
withAsyncsWaitAny) (m (NonEmpty (m RestartCause)) -> m RestartCause)
-> m (NonEmpty (m RestartCause)) -> m RestartCause
forall a b. (a -> b) -> a -> b
$
      (NonEmpty (m RestartCause, m RestartCause)
 -> NonEmpty (m RestartCause))
-> m (NonEmpty (m RestartCause, m RestartCause))
-> m (NonEmpty (m RestartCause))
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NonEmpty (m RestartCause, m RestartCause)
-> NonEmpty (m RestartCause)
forall a. NonEmpty (a, a) -> NonEmpty a
flattenPairs (m (NonEmpty (m RestartCause, m RestartCause))
 -> m (NonEmpty (m RestartCause)))
-> m (NonEmpty (m RestartCause, m RestartCause))
-> m (NonEmpty (m RestartCause))
forall a b. (a -> b) -> a -> b
$
      NonEmpty (m (m RestartCause, m RestartCause))
-> m (NonEmpty (m RestartCause, m RestartCause))
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => NonEmpty (m a) -> m (NonEmpty a)
sequence (NonEmpty (m (m RestartCause, m RestartCause))
 -> m (NonEmpty (m RestartCause, m RestartCause)))
-> NonEmpty (m (m RestartCause, m RestartCause))
-> m (NonEmpty (m RestartCause, m RestartCause))
forall a b. (a -> b) -> a -> b
$
        (m RestartCause, m RestartCause)
-> m (m RestartCause, m RestartCause)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (VertexStatusVar m blk -> m RestartCause
watcher VertexStatusVar m blk
vertexStatusVar1, VertexStatusVar m blk -> m RestartCause
watcher VertexStatusVar m blk
vertexStatusVar2)
        m (m RestartCause, m RestartCause)
-> [m (m RestartCause, m RestartCause)]
-> NonEmpty (m (m RestartCause, m RestartCause))
forall a. a -> [a] -> NonEmpty a
NE.:|
      [ String
-> (String -> NodeToNodeInitiatorResult -> RestartCause)
-> (String -> () -> RestartCause)
-> (LimitedApp' m NodeId blk
    -> NodeToNodeVersion
    -> ExpandedInitiatorContext NodeId m
    -> Channel m ByteString
    -> m (NodeToNodeInitiatorResult, Maybe ByteString))
-> (LimitedApp' m NodeId blk
    -> NodeToNodeVersion
    -> ResponderContext NodeId
    -> Channel m ByteString
    -> m ((), Maybe ByteString))
-> (ByteString -> m ())
-> m (m RestartCause, m RestartCause)
forall a b msg trailingBytes.
String
-> (String -> a -> RestartCause)
-> (String -> b -> RestartCause)
-> (LimitedApp' m NodeId blk
    -> NodeToNodeVersion
    -> ExpandedInitiatorContext NodeId m
    -> Channel m msg
    -> m (a, trailingBytes))
-> (LimitedApp' m NodeId blk
    -> NodeToNodeVersion
    -> ResponderContext NodeId
    -> Channel m msg
    -> m (b, trailingBytes))
-> (msg -> m ())
-> m (m RestartCause, m RestartCause)
miniProtocol String
"ChainSync"
          (\String
_s NodeToNodeInitiatorResult
_  -> RestartCause
RestartChainSyncTerminated)
          (\String
_s () -> RestartCause
RestartChainSyncTerminated)
          LimitedApp' m NodeId blk
-> NodeToNodeVersion
-> ExpandedInitiatorContext NodeId m
-> Channel m ByteString
-> m (NodeToNodeInitiatorResult, Maybe ByteString)
forall (m :: * -> *) addr bCS bBF bTX bKA bPS a b.
Apps m addr bCS bBF bTX bKA bPS a b -> ClientApp m addr bCS a
NTN.aChainSyncClient
          LimitedApp' m NodeId blk
-> NodeToNodeVersion
-> ResponderContext NodeId
-> Channel m ByteString
-> m ((), Maybe ByteString)
forall (m :: * -> *) addr bCS bBF bTX bKA bPS a b.
Apps m addr bCS bBF bTX bKA bPS a b -> ServerApp m addr bCS b
NTN.aChainSyncServer
          ByteString -> m ()
chainSyncMiddle
      , String
-> (String -> NodeToNodeInitiatorResult -> RestartCause)
-> (String -> () -> RestartCause)
-> (LimitedApp' m NodeId blk
    -> NodeToNodeVersion
    -> ExpandedInitiatorContext NodeId m
    -> Channel m ByteString
    -> m (NodeToNodeInitiatorResult, Maybe ByteString))
-> (LimitedApp' m NodeId blk
    -> NodeToNodeVersion
    -> ResponderContext NodeId
    -> Channel m ByteString
    -> m ((), Maybe ByteString))
-> (ByteString -> m ())
-> m (m RestartCause, m RestartCause)
forall a b msg trailingBytes.
String
-> (String -> a -> RestartCause)
-> (String -> b -> RestartCause)
-> (LimitedApp' m NodeId blk
    -> NodeToNodeVersion
    -> ExpandedInitiatorContext NodeId m
    -> Channel m msg
    -> m (a, trailingBytes))
-> (LimitedApp' m NodeId blk
    -> NodeToNodeVersion
    -> ResponderContext NodeId
    -> Channel m msg
    -> m (b, trailingBytes))
-> (msg -> m ())
-> m (m RestartCause, m RestartCause)
miniProtocol String
"BlockFetch"
          String -> NodeToNodeInitiatorResult -> RestartCause
forall x void. String -> x -> void
neverReturns
          String -> () -> RestartCause
forall x void. String -> x -> void
neverReturns
          LimitedApp' m NodeId blk
-> NodeToNodeVersion
-> ExpandedInitiatorContext NodeId m
-> Channel m ByteString
-> m (NodeToNodeInitiatorResult, Maybe ByteString)
forall (m :: * -> *) addr bCS bBF bTX bKA bPS a b.
Apps m addr bCS bBF bTX bKA bPS a b -> ClientApp m addr bBF a
NTN.aBlockFetchClient
          LimitedApp' m NodeId blk
-> NodeToNodeVersion
-> ResponderContext NodeId
-> Channel m ByteString
-> m ((), Maybe ByteString)
forall (m :: * -> *) addr bCS bBF bTX bKA bPS a b.
Apps m addr bCS bBF bTX bKA bPS a b -> ServerApp m addr bBF b
NTN.aBlockFetchServer
          (\ByteString
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
      , String
-> (String -> NodeToNodeInitiatorResult -> RestartCause)
-> (String -> () -> RestartCause)
-> (LimitedApp' m NodeId blk
    -> NodeToNodeVersion
    -> ExpandedInitiatorContext NodeId m
    -> Channel m (AnyMessage (TxSubmission2 (GenTxId blk) (GenTx blk)))
    -> m (NodeToNodeInitiatorResult,
          Maybe (AnyMessage (TxSubmission2 (GenTxId blk) (GenTx blk)))))
-> (LimitedApp' m NodeId blk
    -> NodeToNodeVersion
    -> ResponderContext NodeId
    -> Channel m (AnyMessage (TxSubmission2 (GenTxId blk) (GenTx blk)))
    -> m ((),
          Maybe (AnyMessage (TxSubmission2 (GenTxId blk) (GenTx blk)))))
-> (AnyMessage (TxSubmission2 (GenTxId blk) (GenTx blk)) -> m ())
-> m (m RestartCause, m RestartCause)
forall a b msg trailingBytes.
String
-> (String -> a -> RestartCause)
-> (String -> b -> RestartCause)
-> (LimitedApp' m NodeId blk
    -> NodeToNodeVersion
    -> ExpandedInitiatorContext NodeId m
    -> Channel m msg
    -> m (a, trailingBytes))
-> (LimitedApp' m NodeId blk
    -> NodeToNodeVersion
    -> ResponderContext NodeId
    -> Channel m msg
    -> m (b, trailingBytes))
-> (msg -> m ())
-> m (m RestartCause, m RestartCause)
miniProtocol String
"TxSubmission"
          String -> NodeToNodeInitiatorResult -> RestartCause
forall x void. String -> x -> void
neverReturns
          String -> () -> RestartCause
forall x void. String -> x -> void
neverReturns
          LimitedApp' m NodeId blk
-> NodeToNodeVersion
-> ExpandedInitiatorContext NodeId m
-> Channel m (AnyMessage (TxSubmission2 (GenTxId blk) (GenTx blk)))
-> m (NodeToNodeInitiatorResult,
      Maybe (AnyMessage (TxSubmission2 (GenTxId blk) (GenTx blk))))
forall (m :: * -> *) addr bCS bBF bTX bKA bPS a b.
Apps m addr bCS bBF bTX bKA bPS a b -> ClientApp m addr bTX a
NTN.aTxSubmission2Client
          LimitedApp' m NodeId blk
-> NodeToNodeVersion
-> ResponderContext NodeId
-> Channel m (AnyMessage (TxSubmission2 (GenTxId blk) (GenTx blk)))
-> m ((),
      Maybe (AnyMessage (TxSubmission2 (GenTxId blk) (GenTx blk))))
forall (m :: * -> *) addr bCS bBF bTX bKA bPS a b.
Apps m addr bCS bBF bTX bKA bPS a b -> ServerApp m addr bTX b
NTN.aTxSubmission2Server
          (\AnyMessage (TxSubmission2 (GenTxId blk) (GenTx blk))
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
      , String
-> (String -> NodeToNodeInitiatorResult -> RestartCause)
-> (String -> () -> RestartCause)
-> (LimitedApp' m NodeId blk
    -> NodeToNodeVersion
    -> ExpandedInitiatorContext NodeId m
    -> Channel m (AnyMessage KeepAlive)
    -> m (NodeToNodeInitiatorResult, Maybe (AnyMessage KeepAlive)))
-> (LimitedApp' m NodeId blk
    -> NodeToNodeVersion
    -> ResponderContext NodeId
    -> Channel m (AnyMessage KeepAlive)
    -> m ((), Maybe (AnyMessage KeepAlive)))
-> (AnyMessage KeepAlive -> m ())
-> m (m RestartCause, m RestartCause)
forall a b msg trailingBytes.
String
-> (String -> a -> RestartCause)
-> (String -> b -> RestartCause)
-> (LimitedApp' m NodeId blk
    -> NodeToNodeVersion
    -> ExpandedInitiatorContext NodeId m
    -> Channel m msg
    -> m (a, trailingBytes))
-> (LimitedApp' m NodeId blk
    -> NodeToNodeVersion
    -> ResponderContext NodeId
    -> Channel m msg
    -> m (b, trailingBytes))
-> (msg -> m ())
-> m (m RestartCause, m RestartCause)
miniProtocol String
"KeepAlive"
          String -> NodeToNodeInitiatorResult -> RestartCause
forall x void. String -> x -> void
neverReturns
          String -> () -> RestartCause
forall x void. String -> x -> void
neverReturns
          LimitedApp' m NodeId blk
-> NodeToNodeVersion
-> ExpandedInitiatorContext NodeId m
-> Channel m (AnyMessage KeepAlive)
-> m (NodeToNodeInitiatorResult, Maybe (AnyMessage KeepAlive))
forall (m :: * -> *) addr bCS bBF bTX bKA bPS a b.
Apps m addr bCS bBF bTX bKA bPS a b -> ClientApp m addr bKA a
NTN.aKeepAliveClient
          LimitedApp' m NodeId blk
-> NodeToNodeVersion
-> ResponderContext NodeId
-> Channel m (AnyMessage KeepAlive)
-> m ((), Maybe (AnyMessage KeepAlive))
forall (m :: * -> *) addr bCS bBF bTX bKA bPS a b.
Apps m addr bCS bBF bTX bKA bPS a b -> ServerApp m addr bKA b
NTN.aKeepAliveServer
          (\AnyMessage KeepAlive
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
      ]
  where
    getApp :: StrictTVar m (VertexStatus m blk)
-> STM m (LimitedApp m NodeId blk)
getApp StrictTVar m (VertexStatus m blk)
v = StrictTVar m (VertexStatus m blk) -> STM m (VertexStatus m blk)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (VertexStatus m blk)
v STM m (VertexStatus m blk)
-> (VertexStatus m blk -> STM m (LimitedApp m NodeId blk))
-> STM m (LimitedApp m NodeId blk)
forall a b. STM m a -> (a -> STM m b) -> STM m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      VUp NodeKernel m NodeId Void blk
_ LimitedApp m NodeId blk
app -> LimitedApp m NodeId blk -> STM m (LimitedApp m NodeId blk)
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LimitedApp m NodeId blk
app
      VertexStatus m blk
_         -> STM m (LimitedApp m NodeId blk)
forall a. STM m a
forall (m :: * -> *) a. MonadSTM m => STM m a
retry

    flattenPairs :: forall a. NE.NonEmpty (a, a) -> NE.NonEmpty a
    flattenPairs :: forall a. NonEmpty (a, a) -> NonEmpty a
flattenPairs = (NonEmpty a -> NonEmpty a -> NonEmpty a)
-> (NonEmpty a, NonEmpty a) -> NonEmpty a
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry NonEmpty a -> NonEmpty a -> NonEmpty a
forall a. Semigroup a => a -> a -> a
(<>) ((NonEmpty a, NonEmpty a) -> NonEmpty a)
-> (NonEmpty (a, a) -> (NonEmpty a, NonEmpty a))
-> NonEmpty (a, a)
-> NonEmpty a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (a, a) -> (NonEmpty a, NonEmpty a)
forall (f :: * -> *) a b. Functor f => f (a, b) -> (f a, f b)
neUnzip

    neverReturns :: forall x void. String -> x -> void
    neverReturns :: forall x void. String -> x -> void
neverReturns String
s !x
_ = String -> void
forall a. HasCallStack => String -> a
error (String -> void) -> String -> void
forall a b. (a -> b) -> a -> b
$ String
s String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" never returns!"

    -- terminates (by returning, not via exception) when the vertex starts
    -- 'VFalling'
    --
    -- because of 'withAsyncsWaitAny' used above, this brings down the whole
    -- edge
    watcher :: VertexStatusVar m blk -> m RestartCause
    watcher :: VertexStatusVar m blk -> m RestartCause
watcher VertexStatusVar m blk
v = do
        STM m RestartCause -> m RestartCause
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m RestartCause -> m RestartCause)
-> STM m RestartCause -> m RestartCause
forall a b. (a -> b) -> a -> b
$ VertexStatusVar m blk -> STM m (VertexStatus m blk)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar VertexStatusVar m blk
v STM m (VertexStatus m blk)
-> (VertexStatus m blk -> STM m RestartCause) -> STM m RestartCause
forall a b. STM m a -> (a -> STM m b) -> STM m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          VertexStatus m blk
VFalling -> RestartCause -> STM m RestartCause
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RestartCause
RestartScheduled
          VertexStatus m blk
_        -> STM m RestartCause
forall a. STM m a
forall (m :: * -> *) a. MonadSTM m => STM m a
retry

    -- introduce a delay for 'CS.MsgRollForward'
    --
    -- It is reasonable to delay only this message because this message is the
    -- first step in process of one node diffusing a block to another node.
    chainSyncMiddle :: Lazy.ByteString -> m ()
    chainSyncMiddle :: ByteString -> m ()
chainSyncMiddle ByteString
bs = do
        let tok :: SingChainSync ('StNext 'StMustReply)
tok = SingNextKind 'StMustReply -> SingChainSync ('StNext 'StMustReply)
forall {k} {k1} {k2} {header :: k} {point :: k1} {tip :: k2}
       (k4 :: StNextKind).
SingNextKind k4 -> SingChainSync ('StNext k4)
CS.SingNext SingNextKind 'StMustReply
CS.SingMustReply
        DecodeStep
  ByteString
  DeserialiseFailure
  m
  (SomeMessage ('StNext 'StMustReply))
decodeStep :: Codec.DecodeStep
                        Lazy.ByteString DeserialiseFailure m
                        (Codec.SomeMessage ('CS.StNext 'CS.StMustReply))
          <- Codec
  (ChainSync (Header blk) (Point blk) (Tip blk))
  DeserialiseFailure
  m
  ByteString
-> forall (st :: ChainSync (Header blk) (Point blk) (Tip blk)).
   ActiveState st =>
   StateToken st
   -> m (DecodeStep ByteString DeserialiseFailure m (SomeMessage st))
forall ps failure (m :: * -> *) bytes.
Codec ps failure m bytes
-> forall (st :: ps).
   ActiveState st =>
   StateToken st -> m (DecodeStep bytes failure m (SomeMessage st))
Codec.decode Codec
  (ChainSync (Header blk) (Point blk) (Tip blk))
  DeserialiseFailure
  m
  ByteString
codec SingChainSync ('StNext 'StMustReply)
StateToken ('StNext 'StMustReply)
forall {k} {k1} {k2} {header :: k} {point :: k1} {tip :: k2}.
SingChainSync ('StNext 'StMustReply)
tok
        [ByteString]
-> DecodeStep
     ByteString
     DeserialiseFailure
     m
     (SomeMessage ('StNext 'StMustReply))
-> m (Either
        DeserialiseFailure (SomeMessage ('StNext 'StMustReply)))
forall (m :: * -> *) bytes failure a.
Monad m =>
[bytes] -> DecodeStep bytes failure m a -> m (Either failure a)
Codec.runDecoder [ByteString
bs] DecodeStep
  ByteString
  DeserialiseFailure
  m
  (SomeMessage ('StNext 'StMustReply))
decodeStep m (Either DeserialiseFailure (SomeMessage ('StNext 'StMustReply)))
-> (Either DeserialiseFailure (SomeMessage ('StNext 'StMustReply))
    -> m ())
-> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Right (Codec.SomeMessage (CS.MsgRollForward header1
hdr tip1
_tip)) -> do
              SlotNo
s <- OracularClock m -> m SlotNo
forall (m :: * -> *). OracularClock m -> m SlotNo
OracularClock.getCurrentSlot OracularClock m
clock
              let NumSlots Word64
d = (CoreNodeId, CoreNodeId) -> SlotNo -> Header blk -> NumSlots
f (CoreNodeId
node1, CoreNodeId
node2) SlotNo
s header1
Header blk
hdr
                    where
                      CalcMessageDelay (CoreNodeId, CoreNodeId) -> SlotNo -> Header blk -> NumSlots
f = CalcMessageDelay blk
calcMessageDelay
              m Bool -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m Bool -> m ()) -> m Bool -> m ()
forall a b. (a -> b) -> a -> b
$ OracularClock m -> SlotNo -> m Bool
forall (m :: * -> *). OracularClock m -> SlotNo -> m Bool
OracularClock.blockUntilSlot OracularClock m
clock (SlotNo -> m Bool) -> SlotNo -> m Bool
forall a b. (a -> b) -> a -> b
$ header1 -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot header1
hdr SlotNo -> SlotNo -> SlotNo
forall a. Num a => a -> a -> a
+ Word64 -> SlotNo
SlotNo Word64
d
          Either DeserialiseFailure (SomeMessage ('StNext 'StMustReply))
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      where
        codec :: Codec
  (ChainSync (Header blk) (Point blk) (Tip blk))
  DeserialiseFailure
  m
  ByteString
codec =
            Codecs
  blk
  NodeId
  DeserialiseFailure
  m
  ByteString
  ByteString
  ByteString
  ByteString
  ByteString
  ByteString
  ByteString
-> Codec
     (ChainSync (Header blk) (Point blk) (Tip blk))
     DeserialiseFailure
     m
     ByteString
forall blk addr e (m :: * -> *) bCS bSCS bBF bSBF bTX bKA bPS.
Codecs blk addr e m bCS bSCS bBF bSBF bTX bKA bPS
-> Codec (ChainSync (Header blk) (Point blk) (Tip blk)) e m bCS
NTN.cChainSyncCodec (Codecs
   blk
   NodeId
   DeserialiseFailure
   m
   ByteString
   ByteString
   ByteString
   ByteString
   ByteString
   ByteString
   ByteString
 -> Codec
      (ChainSync (Header blk) (Point blk) (Tip blk))
      DeserialiseFailure
      m
      ByteString)
-> Codecs
     blk
     NodeId
     DeserialiseFailure
     m
     ByteString
     ByteString
     ByteString
     ByteString
     ByteString
     ByteString
     ByteString
-> Codec
     (ChainSync (Header blk) (Point blk) (Tip blk))
     DeserialiseFailure
     m
     ByteString
forall a b. (a -> b) -> a -> b
$ CodecConfig blk
-> BlockNodeToNodeVersion blk
-> (NodeToNodeVersion -> NodeId -> Encoding)
-> (NodeToNodeVersion -> forall s. Decoder s NodeId)
-> NodeToNodeVersion
-> Codecs
     blk
     NodeId
     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
cfg BlockNodeToNodeVersion blk
blockVersion ((NodeId -> Encoding) -> NodeToNodeVersion -> NodeId -> Encoding
forall a b. a -> b -> a
const NodeId -> Encoding
encodeNodeId) (Decoder s NodeId -> NodeToNodeVersion -> Decoder s NodeId
forall a b. a -> b -> a
const Decoder s NodeId
forall s. Decoder s NodeId
decodeNodeId) NodeToNodeVersion
version

-- | Variant of 'createConnectChannels' with intermediate queues for
-- delayed-but-in-order messages
--
-- Sending adds the message to a queue. The delaying argument should use
-- 'threadDelay' in order to delay the transfer of the given message from the
-- queue to the recipient.
createConnectedChannelsWithDelay ::
     IOLike m
  => ResourceRegistry m
  -> (CoreNodeId, CoreNodeId, String)
     -- ^ (client, server, protocol)
  -> (a -> m ())
     -- ^ per-message delay
  -> m (Channel m a, Channel m a)
createConnectedChannelsWithDelay :: forall (m :: * -> *) a.
IOLike m =>
ResourceRegistry m
-> (CoreNodeId, CoreNodeId, String)
-> (a -> m ())
-> m (Channel m a, Channel m a)
createConnectedChannelsWithDelay ResourceRegistry m
registry (CoreNodeId
client, CoreNodeId
server, String
proto) a -> m ()
middle = do
    -- queue for async send and an mvar for delayed-but-in-order reads from the
    -- queue
    TQueue m a
qA <- STM m (TQueue m a) -> m (TQueue m a)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (TQueue m a) -> m (TQueue m a))
-> STM m (TQueue m a) -> m (TQueue m a)
forall a b. (a -> b) -> a -> b
$ STM m (TQueue m a)
forall a. STM m (TQueue m a)
forall (m :: * -> *) a. MonadSTM m => STM m (TQueue m a)
MonadSTM.newTQueue
    TMVar m a
bA <- STM m (TMVar m a) -> m (TMVar m a)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (TMVar m a) -> m (TMVar m a))
-> STM m (TMVar m a) -> m (TMVar m a)
forall a b. (a -> b) -> a -> b
$ STM m (TMVar m a)
forall a. STM m (TMVar m a)
forall (m :: * -> *) a. MonadSTM m => STM m (TMVar m a)
MonadSTM.newEmptyTMVar
    (CoreNodeId, CoreNodeId) -> TQueue m a -> TMVar m a -> m ()
spawn (CoreNodeId
client, CoreNodeId
server) TQueue m a
qA TMVar m a
bA

    TQueue m a
qB <- STM m (TQueue m a) -> m (TQueue m a)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (TQueue m a) -> m (TQueue m a))
-> STM m (TQueue m a) -> m (TQueue m a)
forall a b. (a -> b) -> a -> b
$ STM m (TQueue m a)
forall a. STM m (TQueue m a)
forall (m :: * -> *) a. MonadSTM m => STM m (TQueue m a)
MonadSTM.newTQueue
    TMVar m a
bB <- STM m (TMVar m a) -> m (TMVar m a)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (TMVar m a) -> m (TMVar m a))
-> STM m (TMVar m a) -> m (TMVar m a)
forall a b. (a -> b) -> a -> b
$ STM m (TMVar m a)
forall a. STM m (TMVar m a)
forall (m :: * -> *) a. MonadSTM m => STM m (TMVar m a)
MonadSTM.newEmptyTMVar
    (CoreNodeId, CoreNodeId) -> TQueue m a -> TMVar m a -> m ()
spawn (CoreNodeId
server, CoreNodeId
client) TQueue m a
qB TMVar m a
bB

    (Channel m a, Channel m a) -> m (Channel m a, Channel m a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (TQueue m a -> TMVar m a -> Channel m a
forall {m :: * -> *} {a}.
MonadSTM m =>
TQueue m a -> TMVar m a -> Channel m a
chan TQueue m a
qA TMVar m a
bB, TQueue m a -> TMVar m a -> Channel m a
forall {m :: * -> *} {a}.
MonadSTM m =>
TQueue m a -> TMVar m a -> Channel m a
chan TQueue m a
qB TMVar m a
bA)   -- note the crossover
  where
    spawn :: (CoreNodeId, CoreNodeId) -> TQueue m a -> TMVar m a -> m ()
spawn (CoreNodeId
cid1, CoreNodeId
cid2) TQueue m a
q TMVar m a
b = do
        let label :: String
label =
                String
"delaying thread for " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
proto String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" " String -> ShowS
forall a. Semigroup a => a -> a -> a
<>
                CoreNodeId -> String
forall a. Show a => a -> String
show CoreNodeId
cid1 String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" to " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> CoreNodeId -> String
forall a. Show a => a -> String
show CoreNodeId
cid2
        m (Thread m Any) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (Thread m Any) -> m ()) -> m (Thread m Any) -> m ()
forall a b. (a -> b) -> a -> b
$ ResourceRegistry m -> String -> m Any -> m (Thread m Any)
forall (m :: * -> *) a.
(MonadAsync m, MonadFork m, MonadMask m, HasCallStack) =>
ResourceRegistry m -> String -> m a -> m (Thread m a)
forkLinkedThread ResourceRegistry m
registry String
label (m Any -> m (Thread m Any)) -> m Any -> m (Thread m Any)
forall a b. (a -> b) -> a -> b
$ m () -> m Any
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (m () -> m Any) -> m () -> m Any
forall a b. (a -> b) -> a -> b
$ do
          a
x <- STM m a -> m a
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m a -> m a) -> STM m a -> m a
forall a b. (a -> b) -> a -> b
$ TQueue m a -> STM m a
forall a. TQueue m a -> STM m a
forall (m :: * -> *) a. MonadSTM m => TQueue m a -> STM m a
MonadSTM.readTQueue TQueue m a
q
          a -> m ()
middle a
x
          STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ TMVar m a -> a -> STM m ()
forall a. TMVar m a -> a -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TMVar m a -> a -> STM m ()
MonadSTM.putTMVar TMVar m a
b a
x

    chan :: TQueue m a -> TMVar m a -> Channel m a
chan TQueue m a
q TMVar m a
b = Channel
        { recv :: m (Maybe a)
recv = (a -> Maybe a) -> m a -> m (Maybe a)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Maybe a
forall a. a -> Maybe a
Just (m a -> m (Maybe a)) -> m a -> m (Maybe a)
forall a b. (a -> b) -> a -> b
$ STM m a -> m a
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m a -> m a) -> STM m a -> m a
forall a b. (a -> b) -> a -> b
$ TMVar m a -> STM m a
forall a. TMVar m a -> STM m a
forall (m :: * -> *) a. MonadSTM m => TMVar m a -> STM m a
MonadSTM.takeTMVar TMVar m a
b
        , send :: a -> m ()
send = STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> (a -> STM m ()) -> a -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TQueue m a -> a -> STM m ()
forall a. TQueue m a -> a -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TQueue m a -> a -> STM m ()
MonadSTM.writeTQueue TQueue m a
q
        }

{-------------------------------------------------------------------------------
  Node information not bound to lifetime of a specific node instance
-------------------------------------------------------------------------------}

data NodeInfo blk db ev = NodeInfo
  { forall blk db (ev :: * -> *).
NodeInfo blk db ev -> NodeEvents blk ev
nodeInfoEvents :: NodeEvents blk ev
  , forall blk db (ev :: * -> *). NodeInfo blk db ev -> NodeDBs db
nodeInfoDBs    :: NodeDBs db
  }

-- | A vector with an @ev@-shaped element for a particular set of
-- instrumentation events
--
-- The @ev@ type parameter is instantiated by this module at types for
-- 'Tracer's and lists: actions for accumulating and lists as accumulations.
data NodeEvents blk ev = NodeEvents
  { forall blk (ev :: * -> *).
NodeEvents blk ev -> ev (SlotNo, RealPoint blk, BlockNo)
nodeEventsAdds        :: ev (SlotNo, RealPoint blk, BlockNo)
    -- ^ every 'AddedBlockToVolatileDB' excluding EBBs
  , forall blk (ev :: * -> *).
NodeEvents blk ev -> ev (TraceForgeEvent blk)
nodeEventsForges      :: ev (TraceForgeEvent blk)
    -- ^ every 'TraceForgeEvent'
  , forall blk (ev :: * -> *).
NodeEvents blk ev -> ev (SlotNo, RealPoint blk, BlockNo)
nodeEventsHeaderAdds  :: ev (SlotNo, RealPoint blk, BlockNo)
    -- ^ every 'TraceDownloadedHeader', excluding EBBs
  , forall blk (ev :: * -> *).
NodeEvents blk ev -> ev (RealPoint blk, ExtValidationError blk)
nodeEventsInvalids    :: ev (RealPoint blk, ExtValidationError blk)
    -- ^ the point of every 'ChainDB.InvalidBlock' event
  , forall blk (ev :: * -> *).
NodeEvents blk ev -> ev (SlotNo, RealPoint blk, BlockNo)
nodeEventsSelects     :: ev (SlotNo, RealPoint blk, BlockNo)
    -- ^ every 'ChainDB.AddedToCurrentChain' and 'ChainDB.SwitchedToAFork'
  , forall blk (ev :: * -> *).
NodeEvents blk ev -> ev (SlotNo, WithOrigin BlockNo)
nodeEventsTipBlockNos :: ev (SlotNo, WithOrigin BlockNo)
    -- ^ 'ChainDB.getTipBlockNo' for each node at the onset of each slot
  , forall blk (ev :: * -> *).
NodeEvents blk ev -> ev (LedgerUpdate blk)
nodeEventsUpdates     :: ev (LedgerUpdate blk)
    -- ^ Ledger updates every time we adopt a block/switch to a fork
  , forall blk (ev :: * -> *).
NodeEvents blk ev -> ev (TracePipeliningEvent blk)
nodeEventsPipelining  :: ev (ChainDB.TracePipeliningEvent blk)
    -- ^ Pipelining events tracking the tentative header
  }

newNodeInfo ::
  forall blk m.
     IOLike m
  => m ( NodeInfo blk (StrictTMVar m MockFS) (Tracer m)
       , m (NodeInfo blk MockFS [])
       )
newNodeInfo :: forall blk (m :: * -> *).
IOLike m =>
m (NodeInfo blk (StrictTMVar m MockFS) (Tracer m),
   m (NodeInfo blk MockFS []))
newNodeInfo = do
  (NodeEvents blk (Tracer m)
nodeInfoEvents, m (NodeEvents blk [])
readEvents) <- do
      (Tracer m (SlotNo, RealPoint blk, BlockNo)
t1, m [(SlotNo, RealPoint blk, BlockNo)]
m1) <- m (Tracer m (SlotNo, RealPoint blk, BlockNo),
   m [(SlotNo, RealPoint blk, BlockNo)])
forall (m :: * -> *) ev. MonadSTM m => m (Tracer m ev, m [ev])
recordingTracerTVar
      (Tracer m (TraceForgeEvent blk)
t2, m [TraceForgeEvent blk]
m2) <- m (Tracer m (TraceForgeEvent blk), m [TraceForgeEvent blk])
forall (m :: * -> *) ev. MonadSTM m => m (Tracer m ev, m [ev])
recordingTracerTVar
      (Tracer m (SlotNo, RealPoint blk, BlockNo)
t3, m [(SlotNo, RealPoint blk, BlockNo)]
m3) <- m (Tracer m (SlotNo, RealPoint blk, BlockNo),
   m [(SlotNo, RealPoint blk, BlockNo)])
forall (m :: * -> *) ev. MonadSTM m => m (Tracer m ev, m [ev])
recordingTracerTVar
      (Tracer m (RealPoint blk, ExtValidationError blk)
t4, m [(RealPoint blk, ExtValidationError blk)]
m4) <- m (Tracer m (RealPoint blk, ExtValidationError blk),
   m [(RealPoint blk, ExtValidationError blk)])
forall (m :: * -> *) ev. MonadSTM m => m (Tracer m ev, m [ev])
recordingTracerTVar
      (Tracer m (SlotNo, RealPoint blk, BlockNo)
t5, m [(SlotNo, RealPoint blk, BlockNo)]
m5) <- m (Tracer m (SlotNo, RealPoint blk, BlockNo),
   m [(SlotNo, RealPoint blk, BlockNo)])
forall (m :: * -> *) ev. MonadSTM m => m (Tracer m ev, m [ev])
recordingTracerTVar
      (Tracer m (SlotNo, WithOrigin BlockNo)
t6, m [(SlotNo, WithOrigin BlockNo)]
m6) <- m (Tracer m (SlotNo, WithOrigin BlockNo),
   m [(SlotNo, WithOrigin BlockNo)])
forall (m :: * -> *) ev. MonadSTM m => m (Tracer m ev, m [ev])
recordingTracerTVar
      (Tracer m (LedgerUpdate blk)
t7, m [LedgerUpdate blk]
m7) <- m (Tracer m (LedgerUpdate blk), m [LedgerUpdate blk])
forall (m :: * -> *) ev. MonadSTM m => m (Tracer m ev, m [ev])
recordingTracerTVar
      (Tracer m (TracePipeliningEvent blk)
t8, m [TracePipeliningEvent blk]
m8) <- m (Tracer m (TracePipeliningEvent blk),
   m [TracePipeliningEvent blk])
forall (m :: * -> *) ev. MonadSTM m => m (Tracer m ev, m [ev])
recordingTracerTVar
      (NodeEvents blk (Tracer m), m (NodeEvents blk []))
-> m (NodeEvents blk (Tracer m), m (NodeEvents blk []))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
          ( Tracer m (SlotNo, RealPoint blk, BlockNo)
-> Tracer m (TraceForgeEvent blk)
-> Tracer m (SlotNo, RealPoint blk, BlockNo)
-> Tracer m (RealPoint blk, ExtValidationError blk)
-> Tracer m (SlotNo, RealPoint blk, BlockNo)
-> Tracer m (SlotNo, WithOrigin BlockNo)
-> Tracer m (LedgerUpdate blk)
-> Tracer m (TracePipeliningEvent blk)
-> NodeEvents blk (Tracer m)
forall blk (ev :: * -> *).
ev (SlotNo, RealPoint blk, BlockNo)
-> ev (TraceForgeEvent blk)
-> ev (SlotNo, RealPoint blk, BlockNo)
-> ev (RealPoint blk, ExtValidationError blk)
-> ev (SlotNo, RealPoint blk, BlockNo)
-> ev (SlotNo, WithOrigin BlockNo)
-> ev (LedgerUpdate blk)
-> ev (TracePipeliningEvent blk)
-> NodeEvents blk ev
NodeEvents     Tracer m (SlotNo, RealPoint blk, BlockNo)
t1     Tracer m (TraceForgeEvent blk)
t2     Tracer m (SlotNo, RealPoint blk, BlockNo)
t3     Tracer m (RealPoint blk, ExtValidationError blk)
t4     Tracer m (SlotNo, RealPoint blk, BlockNo)
t5     Tracer m (SlotNo, WithOrigin BlockNo)
t6     Tracer m (LedgerUpdate blk)
t7     Tracer m (TracePipeliningEvent blk)
t8
          , [(SlotNo, RealPoint blk, BlockNo)]
-> [TraceForgeEvent blk]
-> [(SlotNo, RealPoint blk, BlockNo)]
-> [(RealPoint blk, ExtValidationError blk)]
-> [(SlotNo, RealPoint blk, BlockNo)]
-> [(SlotNo, WithOrigin BlockNo)]
-> [LedgerUpdate blk]
-> [TracePipeliningEvent blk]
-> NodeEvents blk []
forall blk (ev :: * -> *).
ev (SlotNo, RealPoint blk, BlockNo)
-> ev (TraceForgeEvent blk)
-> ev (SlotNo, RealPoint blk, BlockNo)
-> ev (RealPoint blk, ExtValidationError blk)
-> ev (SlotNo, RealPoint blk, BlockNo)
-> ev (SlotNo, WithOrigin BlockNo)
-> ev (LedgerUpdate blk)
-> ev (TracePipeliningEvent blk)
-> NodeEvents blk ev
NodeEvents ([(SlotNo, RealPoint blk, BlockNo)]
 -> [TraceForgeEvent blk]
 -> [(SlotNo, RealPoint blk, BlockNo)]
 -> [(RealPoint blk, ExtValidationError blk)]
 -> [(SlotNo, RealPoint blk, BlockNo)]
 -> [(SlotNo, WithOrigin BlockNo)]
 -> [LedgerUpdate blk]
 -> [TracePipeliningEvent blk]
 -> NodeEvents blk [])
-> m [(SlotNo, RealPoint blk, BlockNo)]
-> m ([TraceForgeEvent blk]
      -> [(SlotNo, RealPoint blk, BlockNo)]
      -> [(RealPoint blk, ExtValidationError blk)]
      -> [(SlotNo, RealPoint blk, BlockNo)]
      -> [(SlotNo, WithOrigin BlockNo)]
      -> [LedgerUpdate blk]
      -> [TracePipeliningEvent blk]
      -> NodeEvents blk [])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m [(SlotNo, RealPoint blk, BlockNo)]
m1 m ([TraceForgeEvent blk]
   -> [(SlotNo, RealPoint blk, BlockNo)]
   -> [(RealPoint blk, ExtValidationError blk)]
   -> [(SlotNo, RealPoint blk, BlockNo)]
   -> [(SlotNo, WithOrigin BlockNo)]
   -> [LedgerUpdate blk]
   -> [TracePipeliningEvent blk]
   -> NodeEvents blk [])
-> m [TraceForgeEvent blk]
-> m ([(SlotNo, RealPoint blk, BlockNo)]
      -> [(RealPoint blk, ExtValidationError blk)]
      -> [(SlotNo, RealPoint blk, BlockNo)]
      -> [(SlotNo, WithOrigin BlockNo)]
      -> [LedgerUpdate blk]
      -> [TracePipeliningEvent blk]
      -> NodeEvents blk [])
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m [TraceForgeEvent blk]
m2 m ([(SlotNo, RealPoint blk, BlockNo)]
   -> [(RealPoint blk, ExtValidationError blk)]
   -> [(SlotNo, RealPoint blk, BlockNo)]
   -> [(SlotNo, WithOrigin BlockNo)]
   -> [LedgerUpdate blk]
   -> [TracePipeliningEvent blk]
   -> NodeEvents blk [])
-> m [(SlotNo, RealPoint blk, BlockNo)]
-> m ([(RealPoint blk, ExtValidationError blk)]
      -> [(SlotNo, RealPoint blk, BlockNo)]
      -> [(SlotNo, WithOrigin BlockNo)]
      -> [LedgerUpdate blk]
      -> [TracePipeliningEvent blk]
      -> NodeEvents blk [])
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m [(SlotNo, RealPoint blk, BlockNo)]
m3 m ([(RealPoint blk, ExtValidationError blk)]
   -> [(SlotNo, RealPoint blk, BlockNo)]
   -> [(SlotNo, WithOrigin BlockNo)]
   -> [LedgerUpdate blk]
   -> [TracePipeliningEvent blk]
   -> NodeEvents blk [])
-> m [(RealPoint blk, ExtValidationError blk)]
-> m ([(SlotNo, RealPoint blk, BlockNo)]
      -> [(SlotNo, WithOrigin BlockNo)]
      -> [LedgerUpdate blk]
      -> [TracePipeliningEvent blk]
      -> NodeEvents blk [])
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m [(RealPoint blk, ExtValidationError blk)]
m4 m ([(SlotNo, RealPoint blk, BlockNo)]
   -> [(SlotNo, WithOrigin BlockNo)]
   -> [LedgerUpdate blk]
   -> [TracePipeliningEvent blk]
   -> NodeEvents blk [])
-> m [(SlotNo, RealPoint blk, BlockNo)]
-> m ([(SlotNo, WithOrigin BlockNo)]
      -> [LedgerUpdate blk]
      -> [TracePipeliningEvent blk]
      -> NodeEvents blk [])
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m [(SlotNo, RealPoint blk, BlockNo)]
m5 m ([(SlotNo, WithOrigin BlockNo)]
   -> [LedgerUpdate blk]
   -> [TracePipeliningEvent blk]
   -> NodeEvents blk [])
-> m [(SlotNo, WithOrigin BlockNo)]
-> m ([LedgerUpdate blk]
      -> [TracePipeliningEvent blk] -> NodeEvents blk [])
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m [(SlotNo, WithOrigin BlockNo)]
m6 m ([LedgerUpdate blk]
   -> [TracePipeliningEvent blk] -> NodeEvents blk [])
-> m [LedgerUpdate blk]
-> m ([TracePipeliningEvent blk] -> NodeEvents blk [])
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m [LedgerUpdate blk]
m7 m ([TracePipeliningEvent blk] -> NodeEvents blk [])
-> m [TracePipeliningEvent blk] -> m (NodeEvents blk [])
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m [TracePipeliningEvent blk]
m8
          )

  (NodeDBs (StrictTMVar m MockFS)
nodeInfoDBs, STM m (NodeDBs MockFS)
readDBs) <- do
      let mk :: m (StrictTMVar m MockFS, STM m MockFS)
          mk :: m (StrictTMVar m MockFS, STM m MockFS)
mk = do
              StrictTMVar m MockFS
v <- STM m (StrictTMVar m MockFS) -> m (StrictTMVar m MockFS)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (StrictTMVar m MockFS) -> m (StrictTMVar m MockFS))
-> STM m (StrictTMVar m MockFS) -> m (StrictTMVar m MockFS)
forall a b. (a -> b) -> a -> b
$ MockFS -> STM m (StrictTMVar m MockFS)
forall (m :: * -> *) a. MonadSTM m => a -> STM m (StrictTMVar m a)
newTMVar MockFS
Mock.empty
              (StrictTMVar m MockFS, STM m MockFS)
-> m (StrictTMVar m MockFS, STM m MockFS)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StrictTMVar m MockFS
v, StrictTMVar m MockFS -> STM m MockFS
forall (m :: * -> *) a. MonadSTM m => StrictTMVar m a -> STM m a
readTMVar StrictTMVar m MockFS
v)
      (StrictTMVar m MockFS
v1, STM m MockFS
m1) <- m (StrictTMVar m MockFS, STM m MockFS)
mk
      (StrictTMVar m MockFS
v2, STM m MockFS
m2) <- m (StrictTMVar m MockFS, STM m MockFS)
mk
      (StrictTMVar m MockFS
v3, STM m MockFS
m3) <- m (StrictTMVar m MockFS, STM m MockFS)
mk
      (StrictTMVar m MockFS
v4, STM m MockFS
m4) <- m (StrictTMVar m MockFS, STM m MockFS)
mk
      (NodeDBs (StrictTMVar m MockFS), STM m (NodeDBs MockFS))
-> m (NodeDBs (StrictTMVar m MockFS), STM m (NodeDBs MockFS))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
          ( StrictTMVar m MockFS
-> StrictTMVar m MockFS
-> StrictTMVar m MockFS
-> StrictTMVar m MockFS
-> NodeDBs (StrictTMVar m MockFS)
forall db. db -> db -> db -> db -> NodeDBs db
NodeDBs     StrictTMVar m MockFS
v1     StrictTMVar m MockFS
v2     StrictTMVar m MockFS
v3     StrictTMVar m MockFS
v4
          , MockFS -> MockFS -> MockFS -> MockFS -> NodeDBs MockFS
forall db. db -> db -> db -> db -> NodeDBs db
NodeDBs (MockFS -> MockFS -> MockFS -> MockFS -> NodeDBs MockFS)
-> STM m MockFS
-> STM m (MockFS -> MockFS -> MockFS -> NodeDBs MockFS)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM m MockFS
m1 STM m (MockFS -> MockFS -> MockFS -> NodeDBs MockFS)
-> STM m MockFS -> STM m (MockFS -> MockFS -> NodeDBs MockFS)
forall a b. STM m (a -> b) -> STM m a -> STM m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> STM m MockFS
m2 STM m (MockFS -> MockFS -> NodeDBs MockFS)
-> STM m MockFS -> STM m (MockFS -> NodeDBs MockFS)
forall a b. STM m (a -> b) -> STM m a -> STM m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> STM m MockFS
m3 STM m (MockFS -> NodeDBs MockFS)
-> STM m MockFS -> STM m (NodeDBs MockFS)
forall a b. STM m (a -> b) -> STM m a -> STM m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> STM m MockFS
m4
          )

  (NodeInfo blk (StrictTMVar m MockFS) (Tracer m),
 m (NodeInfo blk MockFS []))
-> m (NodeInfo blk (StrictTMVar m MockFS) (Tracer m),
      m (NodeInfo blk MockFS []))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      ( NodeInfo{NodeEvents blk (Tracer m)
nodeInfoEvents :: NodeEvents blk (Tracer m)
nodeInfoEvents :: NodeEvents blk (Tracer m)
nodeInfoEvents, NodeDBs (StrictTMVar m MockFS)
nodeInfoDBs :: NodeDBs (StrictTMVar m MockFS)
nodeInfoDBs :: NodeDBs (StrictTMVar m MockFS)
nodeInfoDBs}
      , NodeEvents blk [] -> NodeDBs MockFS -> NodeInfo blk MockFS []
forall blk db (ev :: * -> *).
NodeEvents blk ev -> NodeDBs db -> NodeInfo blk db ev
NodeInfo (NodeEvents blk [] -> NodeDBs MockFS -> NodeInfo blk MockFS [])
-> m (NodeEvents blk [])
-> m (NodeDBs MockFS -> NodeInfo blk MockFS [])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (NodeEvents blk [])
readEvents m (NodeDBs MockFS -> NodeInfo blk MockFS [])
-> m (NodeDBs MockFS) -> m (NodeInfo blk MockFS [])
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> STM m (NodeDBs MockFS) -> m (NodeDBs MockFS)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically STM m (NodeDBs MockFS)
readDBs
      )

{-------------------------------------------------------------------------------
  Test Output - output data about each node
-------------------------------------------------------------------------------}

data NodeOutput blk = NodeOutput
  { forall blk.
NodeOutput blk -> Map SlotNo (Set (RealPoint blk, BlockNo))
nodeOutputAdds         :: Map SlotNo (Set (RealPoint blk, BlockNo))
  , forall blk. NodeOutput blk -> Map SlotNo [CannotForge blk]
nodeOutputCannotForges :: Map SlotNo [CannotForge blk]
  , forall blk. NodeOutput blk -> Chain blk
nodeOutputFinalChain   :: Chain blk
  , forall blk. NodeOutput blk -> LedgerState blk
nodeOutputFinalLedger  :: LedgerState blk
  , forall blk. NodeOutput blk -> Map SlotNo blk
nodeOutputForges       :: Map SlotNo blk
  , forall blk. NodeOutput blk -> Map SlotNo [(RealPoint blk, BlockNo)]
nodeOutputHeaderAdds   :: Map SlotNo [(RealPoint blk, BlockNo)]
  , forall blk.
NodeOutput blk -> Map (RealPoint blk) [ExtValidationError blk]
nodeOutputInvalids     :: Map (RealPoint blk) [ExtValidationError blk]
  , forall blk. NodeOutput blk -> NodeDBs MockFS
nodeOutputNodeDBs      :: NodeDBs MockFS
  , forall blk. NodeOutput blk -> Map SlotNo [(RealPoint blk, BlockNo)]
nodeOutputSelects      :: Map SlotNo [(RealPoint blk, BlockNo)]
  , forall blk. NodeOutput blk -> [LedgerUpdate blk]
nodeOutputUpdates      :: [LedgerUpdate blk]
  , forall blk. NodeOutput blk -> [TracePipeliningEvent blk]
nodePipeliningEvents   :: [ChainDB.TracePipeliningEvent blk]
  }

data TestOutput blk = TestOutput
    { forall blk. TestOutput blk -> Map NodeId (NodeOutput blk)
testOutputNodes       :: Map NodeId (NodeOutput blk)
    , forall blk.
TestOutput blk -> Map SlotNo (Map NodeId (WithOrigin BlockNo))
testOutputTipBlockNos :: Map SlotNo (Map NodeId (WithOrigin BlockNo))
    }

-- | Gather the test output from the nodes
mkTestOutput ::
    forall m blk. (IOLike m, HasHeader blk)
    => [( CoreNodeId
        , m (NodeInfo blk MockFS [])
        , Chain blk
        , LedgerState blk
        )]
    -> m (TestOutput blk)
mkTestOutput :: forall (m :: * -> *) blk.
(IOLike m, HasHeader blk) =>
[(CoreNodeId, m (NodeInfo blk MockFS []), Chain blk,
  LedgerState blk)]
-> m (TestOutput blk)
mkTestOutput [(CoreNodeId, m (NodeInfo blk MockFS []), Chain blk,
  LedgerState blk)]
vertexInfos = do
    ([Map NodeId (NodeOutput blk)]
nodeOutputs', [Map SlotNo (Map NodeId (WithOrigin BlockNo))]
tipBlockNos') <- ([(Map NodeId (NodeOutput blk),
   Map SlotNo (Map NodeId (WithOrigin BlockNo)))]
 -> ([Map NodeId (NodeOutput blk)],
     [Map SlotNo (Map NodeId (WithOrigin BlockNo))]))
-> m [(Map NodeId (NodeOutput blk),
       Map SlotNo (Map NodeId (WithOrigin BlockNo)))]
-> m ([Map NodeId (NodeOutput blk)],
      [Map SlotNo (Map NodeId (WithOrigin BlockNo))])
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(Map NodeId (NodeOutput blk),
  Map SlotNo (Map NodeId (WithOrigin BlockNo)))]
-> ([Map NodeId (NodeOutput blk)],
    [Map SlotNo (Map NodeId (WithOrigin BlockNo))])
forall a b. [(a, b)] -> ([a], [b])
unzip (m [(Map NodeId (NodeOutput blk),
     Map SlotNo (Map NodeId (WithOrigin BlockNo)))]
 -> m ([Map NodeId (NodeOutput blk)],
       [Map SlotNo (Map NodeId (WithOrigin BlockNo))]))
-> m [(Map NodeId (NodeOutput blk),
       Map SlotNo (Map NodeId (WithOrigin BlockNo)))]
-> m ([Map NodeId (NodeOutput blk)],
      [Map SlotNo (Map NodeId (WithOrigin BlockNo))])
forall a b. (a -> b) -> a -> b
$ [(CoreNodeId, m (NodeInfo blk MockFS []), Chain blk,
  LedgerState blk)]
-> ((CoreNodeId, m (NodeInfo blk MockFS []), Chain blk,
     LedgerState blk)
    -> m (Map NodeId (NodeOutput blk),
          Map SlotNo (Map NodeId (WithOrigin BlockNo))))
-> m [(Map NodeId (NodeOutput blk),
       Map SlotNo (Map NodeId (WithOrigin BlockNo)))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(CoreNodeId, m (NodeInfo blk MockFS []), Chain blk,
  LedgerState blk)]
vertexInfos (((CoreNodeId, m (NodeInfo blk MockFS []), Chain blk,
   LedgerState blk)
  -> m (Map NodeId (NodeOutput blk),
        Map SlotNo (Map NodeId (WithOrigin BlockNo))))
 -> m [(Map NodeId (NodeOutput blk),
        Map SlotNo (Map NodeId (WithOrigin BlockNo)))])
-> ((CoreNodeId, m (NodeInfo blk MockFS []), Chain blk,
     LedgerState blk)
    -> m (Map NodeId (NodeOutput blk),
          Map SlotNo (Map NodeId (WithOrigin BlockNo))))
-> m [(Map NodeId (NodeOutput blk),
       Map SlotNo (Map NodeId (WithOrigin BlockNo)))]
forall a b. (a -> b) -> a -> b
$
      \(CoreNodeId
cid, m (NodeInfo blk MockFS [])
readNodeInfo, Chain blk
ch, LedgerState blk
ldgr) -> do
        let nid :: NodeId
nid = CoreNodeId -> NodeId
fromCoreNodeId CoreNodeId
cid
        NodeInfo blk MockFS []
nodeInfo <- m (NodeInfo blk MockFS [])
readNodeInfo
        let NodeInfo
              { NodeEvents blk []
nodeInfoEvents :: forall blk db (ev :: * -> *).
NodeInfo blk db ev -> NodeEvents blk ev
nodeInfoEvents :: NodeEvents blk []
nodeInfoEvents
              , NodeDBs MockFS
nodeInfoDBs :: forall blk db (ev :: * -> *). NodeInfo blk db ev -> NodeDBs db
nodeInfoDBs :: NodeDBs MockFS
nodeInfoDBs
              } = NodeInfo blk MockFS []
nodeInfo
        let NodeEvents
              { [(SlotNo, RealPoint blk, BlockNo)]
nodeEventsAdds :: forall blk (ev :: * -> *).
NodeEvents blk ev -> ev (SlotNo, RealPoint blk, BlockNo)
nodeEventsAdds :: [(SlotNo, RealPoint blk, BlockNo)]
nodeEventsAdds
              , [TraceForgeEvent blk]
nodeEventsForges :: forall blk (ev :: * -> *).
NodeEvents blk ev -> ev (TraceForgeEvent blk)
nodeEventsForges :: [TraceForgeEvent blk]
nodeEventsForges
              , [(SlotNo, RealPoint blk, BlockNo)]
nodeEventsHeaderAdds :: forall blk (ev :: * -> *).
NodeEvents blk ev -> ev (SlotNo, RealPoint blk, BlockNo)
nodeEventsHeaderAdds :: [(SlotNo, RealPoint blk, BlockNo)]
nodeEventsHeaderAdds
              , [(RealPoint blk, ExtValidationError blk)]
nodeEventsInvalids :: forall blk (ev :: * -> *).
NodeEvents blk ev -> ev (RealPoint blk, ExtValidationError blk)
nodeEventsInvalids :: [(RealPoint blk, ExtValidationError blk)]
nodeEventsInvalids
              , [(SlotNo, RealPoint blk, BlockNo)]
nodeEventsSelects :: forall blk (ev :: * -> *).
NodeEvents blk ev -> ev (SlotNo, RealPoint blk, BlockNo)
nodeEventsSelects :: [(SlotNo, RealPoint blk, BlockNo)]
nodeEventsSelects
              , [(SlotNo, WithOrigin BlockNo)]
nodeEventsTipBlockNos :: forall blk (ev :: * -> *).
NodeEvents blk ev -> ev (SlotNo, WithOrigin BlockNo)
nodeEventsTipBlockNos :: [(SlotNo, WithOrigin BlockNo)]
nodeEventsTipBlockNos
              , [LedgerUpdate blk]
nodeEventsUpdates :: forall blk (ev :: * -> *).
NodeEvents blk ev -> ev (LedgerUpdate blk)
nodeEventsUpdates :: [LedgerUpdate blk]
nodeEventsUpdates
              , [TracePipeliningEvent blk]
nodeEventsPipelining :: forall blk (ev :: * -> *).
NodeEvents blk ev -> ev (TracePipeliningEvent blk)
nodeEventsPipelining :: [TracePipeliningEvent blk]
nodeEventsPipelining
              } = NodeEvents blk []
nodeInfoEvents
        let nodeOutput :: NodeOutput blk
nodeOutput = NodeOutput
              { nodeOutputAdds :: Map SlotNo (Set (RealPoint blk, BlockNo))
nodeOutputAdds        =
                  (Set (RealPoint blk, BlockNo)
 -> Set (RealPoint blk, BlockNo) -> Set (RealPoint blk, BlockNo))
-> [(SlotNo, Set (RealPoint blk, BlockNo))]
-> Map SlotNo (Set (RealPoint blk, BlockNo))
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith Set (RealPoint blk, BlockNo)
-> Set (RealPoint blk, BlockNo) -> Set (RealPoint blk, BlockNo)
forall a. Ord a => Set a -> Set a -> Set a
Set.union ([(SlotNo, Set (RealPoint blk, BlockNo))]
 -> Map SlotNo (Set (RealPoint blk, BlockNo)))
-> [(SlotNo, Set (RealPoint blk, BlockNo))]
-> Map SlotNo (Set (RealPoint blk, BlockNo))
forall a b. (a -> b) -> a -> b
$
                  [ (SlotNo
s, (RealPoint blk, BlockNo) -> Set (RealPoint blk, BlockNo)
forall a. a -> Set a
Set.singleton (RealPoint blk
p, BlockNo
bno)) | (SlotNo
s, RealPoint blk
p, BlockNo
bno) <- [(SlotNo, RealPoint blk, BlockNo)]
nodeEventsAdds ]
              , nodeOutputCannotForges :: Map SlotNo [CannotForge blk]
nodeOutputCannotForges =
                  ([CannotForge blk] -> [CannotForge blk] -> [CannotForge blk])
-> [(SlotNo, [CannotForge blk])] -> Map SlotNo [CannotForge blk]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith (([CannotForge blk] -> [CannotForge blk] -> [CannotForge blk])
-> [CannotForge blk] -> [CannotForge blk] -> [CannotForge blk]
forall a b c. (a -> b -> c) -> b -> a -> c
flip [CannotForge blk] -> [CannotForge blk] -> [CannotForge blk]
forall a. [a] -> [a] -> [a]
(++)) ([(SlotNo, [CannotForge blk])] -> Map SlotNo [CannotForge blk])
-> [(SlotNo, [CannotForge blk])] -> Map SlotNo [CannotForge blk]
forall a b. (a -> b) -> a -> b
$
                  [ (SlotNo
s, [CannotForge blk
err]) | TraceNodeCannotForge SlotNo
s CannotForge blk
err <- [TraceForgeEvent blk]
nodeEventsForges ]
              , nodeOutputFinalChain :: Chain blk
nodeOutputFinalChain  = Chain blk
ch
              , nodeOutputFinalLedger :: LedgerState blk
nodeOutputFinalLedger = LedgerState blk
ldgr
              , nodeOutputForges :: Map SlotNo blk
nodeOutputForges      =
                  [(SlotNo, blk)] -> Map SlotNo blk
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(SlotNo, blk)] -> Map SlotNo blk)
-> [(SlotNo, blk)] -> Map SlotNo blk
forall a b. (a -> b) -> a -> b
$
                  [ (SlotNo
s, blk
b) | TraceForgedBlock SlotNo
s Point blk
_ blk
b MempoolSize
_ <- [TraceForgeEvent blk]
nodeEventsForges ]
              , nodeOutputHeaderAdds :: Map SlotNo [(RealPoint blk, BlockNo)]
nodeOutputHeaderAdds  =
                  ([(RealPoint blk, BlockNo)]
 -> [(RealPoint blk, BlockNo)] -> [(RealPoint blk, BlockNo)])
-> [(SlotNo, [(RealPoint blk, BlockNo)])]
-> Map SlotNo [(RealPoint blk, BlockNo)]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith (([(RealPoint blk, BlockNo)]
 -> [(RealPoint blk, BlockNo)] -> [(RealPoint blk, BlockNo)])
-> [(RealPoint blk, BlockNo)]
-> [(RealPoint blk, BlockNo)]
-> [(RealPoint blk, BlockNo)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip [(RealPoint blk, BlockNo)]
-> [(RealPoint blk, BlockNo)] -> [(RealPoint blk, BlockNo)]
forall a. [a] -> [a] -> [a]
(++)) ([(SlotNo, [(RealPoint blk, BlockNo)])]
 -> Map SlotNo [(RealPoint blk, BlockNo)])
-> [(SlotNo, [(RealPoint blk, BlockNo)])]
-> Map SlotNo [(RealPoint blk, BlockNo)]
forall a b. (a -> b) -> a -> b
$
                  [ (SlotNo
s, [(RealPoint blk
p, BlockNo
bno)])
                  | (SlotNo
s, RealPoint blk
p, BlockNo
bno) <- [(SlotNo, RealPoint blk, BlockNo)]
nodeEventsHeaderAdds
                  ]
              , nodeOutputSelects :: Map SlotNo [(RealPoint blk, BlockNo)]
nodeOutputSelects     =
                  ([(RealPoint blk, BlockNo)]
 -> [(RealPoint blk, BlockNo)] -> [(RealPoint blk, BlockNo)])
-> [(SlotNo, [(RealPoint blk, BlockNo)])]
-> Map SlotNo [(RealPoint blk, BlockNo)]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith (([(RealPoint blk, BlockNo)]
 -> [(RealPoint blk, BlockNo)] -> [(RealPoint blk, BlockNo)])
-> [(RealPoint blk, BlockNo)]
-> [(RealPoint blk, BlockNo)]
-> [(RealPoint blk, BlockNo)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip [(RealPoint blk, BlockNo)]
-> [(RealPoint blk, BlockNo)] -> [(RealPoint blk, BlockNo)]
forall a. [a] -> [a] -> [a]
(++)) ([(SlotNo, [(RealPoint blk, BlockNo)])]
 -> Map SlotNo [(RealPoint blk, BlockNo)])
-> [(SlotNo, [(RealPoint blk, BlockNo)])]
-> Map SlotNo [(RealPoint blk, BlockNo)]
forall a b. (a -> b) -> a -> b
$
                  [ (SlotNo
s, [(RealPoint blk
p, BlockNo
bno)])
                  | (SlotNo
s, RealPoint blk
p, BlockNo
bno) <- [(SlotNo, RealPoint blk, BlockNo)]
nodeEventsSelects
                  ]
              , nodeOutputInvalids :: Map (RealPoint blk) [ExtValidationError blk]
nodeOutputInvalids    = (ExtValidationError blk
-> [ExtValidationError blk] -> [ExtValidationError blk]
forall a. a -> [a] -> [a]
:[]) (ExtValidationError blk -> [ExtValidationError blk])
-> Map (RealPoint blk) (ExtValidationError blk)
-> Map (RealPoint blk) [ExtValidationError blk]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(RealPoint blk, ExtValidationError blk)]
-> Map (RealPoint blk) (ExtValidationError blk)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(RealPoint blk, ExtValidationError blk)]
nodeEventsInvalids
              , nodeOutputNodeDBs :: NodeDBs MockFS
nodeOutputNodeDBs     = NodeDBs MockFS
nodeInfoDBs
              , nodeOutputUpdates :: [LedgerUpdate blk]
nodeOutputUpdates     = [LedgerUpdate blk]
nodeEventsUpdates
              , nodePipeliningEvents :: [TracePipeliningEvent blk]
nodePipeliningEvents  = [TracePipeliningEvent blk]
nodeEventsPipelining
              }

        (Map NodeId (NodeOutput blk),
 Map SlotNo (Map NodeId (WithOrigin BlockNo)))
-> m (Map NodeId (NodeOutput blk),
      Map SlotNo (Map NodeId (WithOrigin BlockNo)))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
          ( NodeId -> NodeOutput blk -> Map NodeId (NodeOutput blk)
forall k a. k -> a -> Map k a
Map.singleton NodeId
nid NodeOutput blk
nodeOutput
          , NodeId -> WithOrigin BlockNo -> Map NodeId (WithOrigin BlockNo)
forall k a. k -> a -> Map k a
Map.singleton NodeId
nid (WithOrigin BlockNo -> Map NodeId (WithOrigin BlockNo))
-> Map SlotNo (WithOrigin BlockNo)
-> Map SlotNo (Map NodeId (WithOrigin BlockNo))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(SlotNo, WithOrigin BlockNo)] -> Map SlotNo (WithOrigin BlockNo)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(SlotNo, WithOrigin BlockNo)]
nodeEventsTipBlockNos
          )

    TestOutput blk -> m (TestOutput blk)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TestOutput blk -> m (TestOutput blk))
-> TestOutput blk -> m (TestOutput blk)
forall a b. (a -> b) -> a -> b
$ TestOutput
        { testOutputNodes :: Map NodeId (NodeOutput blk)
testOutputNodes       = [Map NodeId (NodeOutput blk)] -> Map NodeId (NodeOutput blk)
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions [Map NodeId (NodeOutput blk)]
nodeOutputs'
        , testOutputTipBlockNos :: Map SlotNo (Map NodeId (WithOrigin BlockNo))
testOutputTipBlockNos = (Map NodeId (WithOrigin BlockNo)
 -> Map NodeId (WithOrigin BlockNo)
 -> Map NodeId (WithOrigin BlockNo))
-> [Map SlotNo (Map NodeId (WithOrigin BlockNo))]
-> Map SlotNo (Map NodeId (WithOrigin BlockNo))
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
Map.unionsWith Map NodeId (WithOrigin BlockNo)
-> Map NodeId (WithOrigin BlockNo)
-> Map NodeId (WithOrigin BlockNo)
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union [Map SlotNo (Map NodeId (WithOrigin BlockNo))]
tipBlockNos'
        }

{-------------------------------------------------------------------------------
  Constraints needed for verbose tracing
-------------------------------------------------------------------------------}

-- | Occurs throughout in positions that might be useful for debugging.
nullDebugTracer :: (Applicative m, Show a) => Tracer m a
nullDebugTracer :: forall (m :: * -> *) a. (Applicative m, Show a) => Tracer m a
nullDebugTracer = Tracer m a
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer Tracer m a -> Tracer m a -> Tracer m a
forall a. a -> a -> a
`asTypeOf` Tracer m String -> Tracer m a
forall a (m :: * -> *). Show a => Tracer m String -> Tracer m a
showTracing Tracer m String
forall (m :: * -> *). Applicative m => Tracer m String
debugTracer

-- | Occurs throughout in positions that might be useful for debugging.
nullDebugTracers ::
     ( Monad m
     , Show peer
     , LedgerSupportsProtocol blk
     , TracingConstraints blk
     )
  => Tracers m peer Void blk
nullDebugTracers :: forall (m :: * -> *) peer blk.
(Monad m, Show peer, LedgerSupportsProtocol blk,
 TracingConstraints blk) =>
Tracers m peer Void blk
nullDebugTracers = Tracers m peer Void blk
forall (m :: * -> *) remotePeer localPeer blk.
Monad m =>
Tracers m remotePeer localPeer blk
nullTracers Tracers m peer Void blk
-> Tracers m peer Void blk -> Tracers m peer Void blk
forall a. a -> a -> a
`asTypeOf` Tracer m String -> Tracers m peer Void blk
forall blk remotePeer (m :: * -> *) localPeer.
(Show blk, Show (GenTx blk), Show (Validated (GenTx blk)),
 Show (GenTxId blk), Show (ApplyTxErr blk), Show (Header blk),
 Show (ForgeStateInfo blk), Show (ForgeStateUpdateError blk),
 Show (CannotForge blk), Show remotePeer,
 LedgerSupportsProtocol blk) =>
Tracer m String -> Tracers m remotePeer localPeer blk
showTracers Tracer m String
forall (m :: * -> *). Applicative m => Tracer m String
debugTracer

-- | Occurs throughout in positions that might be useful for debugging.
nullDebugProtocolTracers ::
     ( Monad m
     , HasHeader blk
     , TracingConstraints blk
     , Show peer
     )
  => NTN.Tracers m peer blk failure
nullDebugProtocolTracers :: forall (m :: * -> *) blk peer failure.
(Monad m, HasHeader blk, TracingConstraints blk, Show peer) =>
Tracers m peer blk failure
nullDebugProtocolTracers =
  Tracers m peer blk failure
forall (m :: * -> *) peer blk e. Monad m => Tracers m peer blk e
NTN.nullTracers Tracers m peer blk failure
-> Tracers m peer blk failure -> Tracers m peer blk failure
forall a. a -> a -> a
`asTypeOf` Tracer m String -> Tracers m peer blk failure
forall blk peer (m :: * -> *) e.
(Show blk, Show peer, Show (Header blk), Show (GenTx blk),
 Show (GenTxId blk), HasHeader blk, HasNestedContent Header blk) =>
Tracer m String -> Tracers m peer blk e
NTN.showTracers Tracer m String
forall (m :: * -> *). Applicative m => Tracer m String
debugTracer

-- These constraints are when using @showTracer(s) debugTracer@ instead of
-- @nullTracer(s)@.
type TracingConstraints blk =
  ( Show blk
  , Show (ApplyTxErr blk)
  , Show (Header blk)
  , Show (GenTx blk)
  , Show (Validated (GenTx blk))
  , Show (GenTxId blk)
  , Show (ForgeStateInfo blk)
  , Show (ForgeStateUpdateError blk)
  , Show (CannotForge blk)
  , HasNestedContent Header blk
  )

{-------------------------------------------------------------------------------
  Ancillaries
-------------------------------------------------------------------------------}

-- | Spawn multiple async actions and wait for the first one to complete.
--
-- Each child thread is spawned with 'withAsync' and so won't outlive this one.
-- In the use case where each child thread only terminates on an exception, the
-- 'waitAny' ensures that this parent thread will run until a child terminates
-- with an exception, and it will also reraise that exception.
--
-- Why 'NE.NonEmpty'? An empty argument list would have blocked indefinitely,
-- which is likely not intended.
withAsyncsWaitAny :: forall m a. IOLike m => NE.NonEmpty (m a) -> m a
withAsyncsWaitAny :: forall (m :: * -> *) a. IOLike m => NonEmpty (m a) -> m a
withAsyncsWaitAny = [Async m a] -> [m a] -> m a
forall {f :: * -> *} {b}.
MonadAsync f =>
[Async f b] -> [f b] -> f b
go [] ([m a] -> m a)
-> (NonEmpty (m a) -> [m a]) -> NonEmpty (m a) -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (m a) -> [m a]
forall a. NonEmpty a -> [a]
NE.toList
  where
    go :: [Async f b] -> [f b] -> f b
go [Async f b]
acc = \case
      []   -> (Async f b, b) -> b
forall a b. (a, b) -> b
snd ((Async f b, b) -> b) -> f (Async f b, b) -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Async f b] -> f (Async f b, b)
forall a. [Async f a] -> f (Async f a, a)
forall (m :: * -> *) a.
MonadAsync m =>
[Async m a] -> m (Async m a, a)
waitAny [Async f b]
acc
      f b
m:[f b]
ms -> f b -> (Async f b -> f b) -> f b
forall a b. f a -> (Async f a -> f b) -> f b
forall (m :: * -> *) a b.
MonadAsync m =>
m a -> (Async m a -> m b) -> m b
withAsync f b
m ((Async f b -> f b) -> f b) -> (Async f b -> f b) -> f b
forall a b. (a -> b) -> a -> b
$ \Async f b
h -> [Async f b] -> [f b] -> f b
go (Async f b
hAsync f b -> [Async f b] -> [Async f b]
forall a. a -> [a] -> [a]
:[Async f b]
acc) [f b]
ms

-- | The partially instantiation of the 'NetworkApplication' type according to
-- its use in this module
--
-- Used internal to this module, essentially as an abbreviation.
data LimitedApp m addr blk =
   LimitedApp (LimitedApp' m addr blk)

-- | Argument of 'LimitedApp' data constructor
--
-- Used internal to this module, essentially as an abbreviation.
type LimitedApp' m addr blk =
    NTN.Apps m addr
        -- The 'ChainSync' and 'BlockFetch' protocols use @'Serialised' x@ for
        -- the servers and @x@ for the clients. Since both have to match to be
        -- sent across a channel, we can't use @'AnyMessage' ..@, instead, we
        -- (de)serialise the messages so that they can be sent across the
        -- channel with the same type on both ends, i.e., 'Lazy.ByteString'.
        Lazy.ByteString
        Lazy.ByteString
        (AnyMessage (TxSubmission2 (GenTxId blk) (GenTx blk)))
        (AnyMessage KeepAlive)
        (AnyMessage (PeerSharing addr))
        NodeToNodeInitiatorResult ()

{-------------------------------------------------------------------------------
  Tracing
-------------------------------------------------------------------------------}

data MiniProtocolState = MiniProtocolDelayed | MiniProtocolRestarting
  deriving (Int -> MiniProtocolState -> ShowS
[MiniProtocolState] -> ShowS
MiniProtocolState -> String
(Int -> MiniProtocolState -> ShowS)
-> (MiniProtocolState -> String)
-> ([MiniProtocolState] -> ShowS)
-> Show MiniProtocolState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MiniProtocolState -> ShowS
showsPrec :: Int -> MiniProtocolState -> ShowS
$cshow :: MiniProtocolState -> String
show :: MiniProtocolState -> String
$cshowList :: [MiniProtocolState] -> ShowS
showList :: [MiniProtocolState] -> ShowS
Show)

-- | Any synchronous exception from a 'directedEdge'
data MiniProtocolFatalException = MiniProtocolFatalException
  { MiniProtocolFatalException -> TypeRep
mpfeType   :: !Typeable.TypeRep
    -- ^ Including the type explicitly makes it easier for a human to debug
  , MiniProtocolFatalException -> SomeException
mpfeExn    :: !SomeException
  , MiniProtocolFatalException -> CoreNodeId
mpfeClient :: !CoreNodeId
  , MiniProtocolFatalException -> CoreNodeId
mpfeServer :: !CoreNodeId
  }
  deriving (Int -> MiniProtocolFatalException -> ShowS
[MiniProtocolFatalException] -> ShowS
MiniProtocolFatalException -> String
(Int -> MiniProtocolFatalException -> ShowS)
-> (MiniProtocolFatalException -> String)
-> ([MiniProtocolFatalException] -> ShowS)
-> Show MiniProtocolFatalException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MiniProtocolFatalException -> ShowS
showsPrec :: Int -> MiniProtocolFatalException -> ShowS
$cshow :: MiniProtocolFatalException -> String
show :: MiniProtocolFatalException -> String
$cshowList :: [MiniProtocolFatalException] -> ShowS
showList :: [MiniProtocolFatalException] -> ShowS
Show)

instance Exception MiniProtocolFatalException

-- | Our scheme for Just-In-Time EBBs makes some assumptions
--
data JitEbbError blk
  = JitEbbError (LedgerError blk)
    -- ^ we were unable to extend the ledger state with the JIT EBB

deriving instance LedgerSupportsProtocol blk => Show (JitEbbError blk)
instance LedgerSupportsProtocol blk => Exception (JitEbbError blk)

-- | The 'TxGen' generator consecutively failed too many times
data TxGenFailure = TxGenFailure Int   -- ^ how many times it failed
  deriving (Int -> TxGenFailure -> ShowS
[TxGenFailure] -> ShowS
TxGenFailure -> String
(Int -> TxGenFailure -> ShowS)
-> (TxGenFailure -> String)
-> ([TxGenFailure] -> ShowS)
-> Show TxGenFailure
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TxGenFailure -> ShowS
showsPrec :: Int -> TxGenFailure -> ShowS
$cshow :: TxGenFailure -> String
show :: TxGenFailure -> String
$cshowList :: [TxGenFailure] -> ShowS
showList :: [TxGenFailure] -> ShowS
Show)

instance Exception TxGenFailure

-- In base@4.20 the Data.List.NonEmpty.unzip is deprecated and suggests that
-- Data.Function.unzip should be used instead,but base versions earlier than
-- 4.20 do not have that.
-- Neatest solution is to cargo cult it here and switch to Data.Function.unzip
-- later.
neUnzip :: Functor f => f (a,b) -> (f a, f b)
neUnzip :: forall (f :: * -> *) a b. Functor f => f (a, b) -> (f a, f b)
neUnzip f (a, b)
xs = ((a, b) -> a
forall a b. (a, b) -> a
fst ((a, b) -> a) -> f (a, b) -> f a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (a, b)
xs, (a, b) -> b
forall a b. (a, b) -> b
snd ((a, b) -> b) -> f (a, b) -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (a, b)
xs)