{-# 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 #-}
module Test.ThreadNet.Network (
CalcMessageDelay (..)
, ForgeEbbEnv (..)
, RekeyM
, TestNodeInitialization (..)
, ThreadNetworkArgs (..)
, TracingConstraints
, noCalcMessageDelay
, plainTestNodeInitialization
, runThreadNetwork
, MiniProtocolFatalException (..)
, MiniProtocolState (..)
, 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.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 qualified Ouroboros.Consensus.Fragment.InFuture as InFuture
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.ResourceRegistry
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
data ForgeEbbEnv blk = ForgeEbbEnv
{ forall blk.
ForgeEbbEnv blk
-> TopLevelConfig blk -> SlotNo -> BlockNo -> ChainHash blk -> blk
forgeEBB ::
TopLevelConfig blk
-> SlotNo
-> BlockNo
-> ChainHash blk
-> 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 _"
type RekeyM m blk =
CoreNodeId
-> ProtocolInfo blk
-> m [BlockForging m blk]
-> SlotNo
-> (SlotNo -> m EpochNo)
-> m (TestNodeInitialization m blk)
data TestNodeInitialization m blk = TestNodeInitialization
{ forall (m :: * -> *) blk.
TestNodeInitialization m blk -> [GenTx blk]
tniCrucialTxs :: [GenTx blk]
, 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
}
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
instance Show (CalcMessageDelay blk) where
show :: CalcMessageDelay blk -> String
show CalcMessageDelay blk
_ = String
"_CalcMessageDelay"
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
, :: TxGenExtra blk
, forall (m :: * -> *) blk.
ThreadNetworkArgs m blk -> NodeToNodeVersion
tnaVersion :: NodeToNodeVersion
, forall (m :: * -> *) blk.
ThreadNetworkArgs m blk -> BlockNodeToNodeVersion blk
tnaBlockVersion :: BlockNodeToNodeVersion blk
}
data VertexStatus m blk
= VDown (Chain blk) (LedgerState blk)
| VFalling
| VUp !(NodeKernel m NodeId Void blk) !(LimitedApp m NodeId blk)
data EdgeStatus
= EDown
| EUp
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
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.
(IOLike 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
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
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
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)
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
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
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
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
$
((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
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
(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
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)
OracularClock m -> m ()
forall (m :: * -> *). OracularClock m -> m ()
OracularClock.waitUntilDone OracularClock m
clock
[(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))))
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.
(IOLike 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
(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.
(IOLike 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
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'
(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
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
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
Just ((SlotNo
s', NodeRestart
nr'), Map SlotNo NodeRestart
rs') -> do
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')
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')
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)
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)
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'
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"
forkCrucialTxs
:: HasCallStack
=> OracularClock m
-> SlotNo
-> ResourceRegistry m
-> (SlotNo -> STM m ())
-> LedgerConfig blk
-> STM m (LedgerState blk)
-> Mempool m blk
-> [GenTx blk]
-> 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.
(IOLike 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
$
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
$
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
(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)
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 ()
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
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)
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')
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)
(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
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, [])
forkTxProducer :: HasCallStack
=> CoreNodeId
-> ResourceRegistry m
-> OracularClock m
-> TopLevelConfig blk
-> Seed
-> STM m (ExtLedgerState blk)
-> 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
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 :: OracularClock m
-> 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 (ChainDB.TracePipeliningEvent blk)
-> NodeDBs (StrictTMVar m MockFS)
-> CoreNodeId
-> ChainDbArgs Identity m blk
mkArgs :: OracularClock m
-> 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
OracularClock m
clock 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) {
cdbsCheckInFuture = InFuture.reference (configLedger cfg)
InFuture.defaultClockSkew
(OracularClock.finiteSystemTime clock)
, 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"
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 ()
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
_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]
-> 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
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 = OracularClock m
-> 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
OracularClock m
clock 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.
(IOLike 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
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 ->
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
let ebbBno :: BlockNo
ebbBno = case BlockNo
currentBno of
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)
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
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
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
(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
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 ->
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 ()
}
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
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
((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
InFuture.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 :: Word16
txSubmissionMaxUnacked = Word16
1000
}
, $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
, 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
}
}
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
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
(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
(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)
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
(Seed
seed Seed -> Word64 -> Seed
forall a. Integral a => Seed -> a -> Seed
`combineWith` CoreNodeId -> Word64
unCoreNodeId CoreNodeId
coreNodeId)
(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
data CodecError
= CodecIdFailure CodecFailure
| CodecBytesFailure
String
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)
data RestartCause
= RestartScheduled
| RestartChainSyncTerminated
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.
(IOLike 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]
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
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
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
}
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 :: 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
(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
-> (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 :: 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!"
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
chainSyncMiddle :: Lazy.ByteString -> m ()
chainSyncMiddle :: ByteString -> m ()
chainSyncMiddle ByteString
bs = do
let tok :: PeerHasAgency 'AsServer ('StNext 'StMustReply)
tok = ServerHasAgency ('StNext 'StMustReply)
-> PeerHasAgency 'AsServer ('StNext 'StMustReply)
forall {ps} (st :: ps).
ServerHasAgency st -> PeerHasAgency 'AsServer st
Codec.ServerAgency (ServerHasAgency ('StNext 'StMustReply)
-> PeerHasAgency 'AsServer ('StNext 'StMustReply))
-> ServerHasAgency ('StNext 'StMustReply)
-> PeerHasAgency 'AsServer ('StNext 'StMustReply)
forall a b. (a -> b) -> a -> b
$ TokNextKind 'StMustReply -> ServerHasAgency ('StNext 'StMustReply)
forall {k} {k1} {k2} {header :: k} {point :: k1} {tip :: k2}
(k3 :: StNextKind).
TokNextKind k3 -> ServerHasAgency ('StNext k3)
CS.TokNext TokNextKind 'StMustReply
CS.TokMustReply
DecodeStep
ByteString
DeserialiseFailure
m
(SomeMessage ('StNext 'StMustReply))
decodeStep <- Codec
(ChainSync (Header blk) (Point blk) (Tip blk))
DeserialiseFailure
m
ByteString
-> forall (pr :: PeerRole)
(st :: ChainSync (Header blk) (Point blk) (Tip blk)).
PeerHasAgency pr st
-> m (DecodeStep ByteString DeserialiseFailure m (SomeMessage st))
forall ps failure (m :: * -> *) bytes.
Codec ps failure m bytes
-> forall (pr :: PeerRole) (st :: ps).
PeerHasAgency pr st
-> m (DecodeStep bytes failure m (SomeMessage st))
Codec.decode Codec
(ChainSync (Header blk) (Point blk) (Tip blk))
DeserialiseFailure
m
ByteString
codec PeerHasAgency 'AsServer ('StNext 'StMustReply)
forall {k} {k1} {k2} {header :: k} {point :: k1} {tip :: k2}.
PeerHasAgency 'AsServer ('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
createConnectedChannelsWithDelay ::
IOLike m
=> ResourceRegistry m
-> (CoreNodeId, CoreNodeId, String)
-> (a -> m ())
-> 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
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)
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.
(IOLike 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
}
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
}
data NodeEvents blk ev = NodeEvents
{ forall blk (ev :: * -> *).
NodeEvents blk ev -> ev (SlotNo, RealPoint blk, BlockNo)
nodeEventsAdds :: ev (SlotNo, RealPoint blk, BlockNo)
, forall blk (ev :: * -> *).
NodeEvents blk ev -> ev (TraceForgeEvent blk)
nodeEventsForges :: ev (TraceForgeEvent blk)
, :: ev (SlotNo, RealPoint blk, BlockNo)
, forall blk (ev :: * -> *).
NodeEvents blk ev -> ev (RealPoint blk, ExtValidationError blk)
nodeEventsInvalids :: ev (RealPoint blk, ExtValidationError blk)
, forall blk (ev :: * -> *).
NodeEvents blk ev -> ev (SlotNo, RealPoint blk, BlockNo)
nodeEventsSelects :: ev (SlotNo, RealPoint blk, BlockNo)
, forall blk (ev :: * -> *).
NodeEvents blk ev -> ev (SlotNo, WithOrigin BlockNo)
nodeEventsTipBlockNos :: ev (SlotNo, WithOrigin BlockNo)
, forall blk (ev :: * -> *).
NodeEvents blk ev -> ev (LedgerUpdate blk)
nodeEventsUpdates :: ev (LedgerUpdate blk)
, forall blk (ev :: * -> *).
NodeEvents blk ev -> ev (TracePipeliningEvent blk)
nodeEventsPipelining :: ev (ChainDB.TracePipeliningEvent blk)
}
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
)
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
, :: 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))
}
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'
}
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
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
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
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
)
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
data LimitedApp m addr blk =
LimitedApp (LimitedApp' m addr blk)
type LimitedApp' m addr blk =
NTN.Apps m addr
Lazy.ByteString
Lazy.ByteString
(AnyMessage (TxSubmission2 (GenTxId blk) (GenTx blk)))
(AnyMessage KeepAlive)
(AnyMessage (PeerSharing addr))
NodeToNodeInitiatorResult ()
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)
data MiniProtocolFatalException = MiniProtocolFatalException
{ MiniProtocolFatalException -> TypeRep
mpfeType