{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE NamedFieldPuns        #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE RecordWildCards       #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TypeApplications      #-}

-- | Intended for qualified import
module Ouroboros.Consensus.Network.NodeToNode (
    -- * Handlers
    Handlers (..)
  , mkHandlers
    -- * Codecs
  , Codecs (..)
  , defaultCodecs
  , identityCodecs
    -- * Tracers
  , Tracers
  , Tracers' (..)
  , nullTracers
  , showTracers
    -- * Applications
  , ClientApp
  , ServerApp
  , Apps (..)
  , mkApps
    -- ** Projections
  , initiator
  , responder
    -- * Re-exports
  , ChainSyncTimeout (..)
  ) where

import           Codec.CBOR.Decoding (Decoder)
import           Codec.CBOR.Encoding (Encoding)
import           Control.Monad (forever)
import           Control.Monad.Class.MonadTimer (MonadTimer)
import           Control.Tracer
import           Data.ByteString.Lazy (ByteString)
import           Data.Map.Strict (Map)
import           Data.Void (Void)

import           Ouroboros.Network.AnchoredFragment (AnchoredFragment (..))
import           Ouroboros.Network.Block (Serialised (..), decodePoint,
                     decodeTip, encodePoint, encodeTip)
import           Ouroboros.Network.BlockFetch
import           Ouroboros.Network.BlockFetch.Client (BlockFetchClient,
                     blockFetchClient)
import           Ouroboros.Network.Channel
import           Ouroboros.Network.Codec
import           Ouroboros.Network.DeltaQ
import           Ouroboros.Network.Driver
import           Ouroboros.Network.KeepAlive
import           Ouroboros.Network.Mux
import           Ouroboros.Network.NodeToNode
import           Ouroboros.Network.Protocol.BlockFetch.Codec
import           Ouroboros.Network.Protocol.BlockFetch.Server (BlockFetchServer,
                     blockFetchServerPeer)
import           Ouroboros.Network.Protocol.BlockFetch.Type (BlockFetch (..))
import           Ouroboros.Network.Protocol.ChainSync.ClientPipelined
import           Ouroboros.Network.Protocol.ChainSync.Codec
import           Ouroboros.Network.Protocol.ChainSync.PipelineDecision
import           Ouroboros.Network.Protocol.ChainSync.Server
import           Ouroboros.Network.Protocol.ChainSync.Type
import           Ouroboros.Network.Protocol.KeepAlive.Client
import           Ouroboros.Network.Protocol.KeepAlive.Codec
import           Ouroboros.Network.Protocol.KeepAlive.Server
import           Ouroboros.Network.Protocol.KeepAlive.Type
import           Ouroboros.Network.Protocol.TxSubmission.Client
import           Ouroboros.Network.Protocol.TxSubmission.Codec
import           Ouroboros.Network.Protocol.TxSubmission.Server
import           Ouroboros.Network.Protocol.TxSubmission.Type
import           Ouroboros.Network.TxSubmission.Inbound
import           Ouroboros.Network.TxSubmission.Outbound

import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.Ledger.SupportsMempool
import           Ouroboros.Consensus.Ledger.SupportsProtocol
import           Ouroboros.Consensus.MiniProtocol.BlockFetch.Server
import           Ouroboros.Consensus.MiniProtocol.ChainSync.Client
import           Ouroboros.Consensus.MiniProtocol.ChainSync.Server
import           Ouroboros.Consensus.Node.NetworkProtocolVersion
import           Ouroboros.Consensus.Node.Run
import           Ouroboros.Consensus.Node.Serialisation
import qualified Ouroboros.Consensus.Node.Tracers as Node
import           Ouroboros.Consensus.NodeKernel
import           Ouroboros.Consensus.Util (ShowProxy)
import           Ouroboros.Consensus.Util.IOLike
import           Ouroboros.Consensus.Util.Orphans ()
import           Ouroboros.Consensus.Util.ResourceRegistry

import           Ouroboros.Consensus.Storage.Serialisation (SerialisedHeader)

{-------------------------------------------------------------------------------
  Handlers
-------------------------------------------------------------------------------}

-- | Protocol handlers for node-to-node (remote) communication
data Handlers m peer blk = Handlers {
      Handlers m peer blk
-> NodeToNodeVersion
-> ControlMessageSTM m
-> StrictTVar m (AnchoredFragment (Header blk))
-> ChainSyncClientPipelined
     (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult
hChainSyncClient
        :: NodeToNodeVersion
        -> ControlMessageSTM m
        -> StrictTVar m (AnchoredFragment (Header blk))
        -> ChainSyncClientPipelined (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult
        -- TODO: we should consider either bundling these context parameters
        -- into a record, or extending the protocol handler representation
        -- to support bracket-style initialisation so that we could have the
        -- closure include these and not need to be explicit about them here.

    , Handlers m peer blk
-> NodeToNodeVersion
-> ResourceRegistry m
-> ChainSyncServer
     (SerialisedHeader blk) (Point blk) (Tip blk) m ()
hChainSyncServer
        :: NodeToNodeVersion
        -> ResourceRegistry m
        -> ChainSyncServer (SerialisedHeader blk) (Point blk) (Tip blk) m ()

    -- TODO block fetch client does not have GADT view of the handlers.
    , Handlers m peer blk
-> NodeToNodeVersion
-> ControlMessageSTM m
-> BlockFetchClient (Header blk) blk m ()
hBlockFetchClient
        :: NodeToNodeVersion
        -> ControlMessageSTM m
        -> BlockFetchClient (Header blk) blk m ()

    , Handlers m peer blk
-> NodeToNodeVersion
-> ResourceRegistry m
-> BlockFetchServer (Serialised blk) (Point blk) m ()
hBlockFetchServer
        :: NodeToNodeVersion
        -> ResourceRegistry m
        -> BlockFetchServer (Serialised blk) (Point blk) m ()

    , Handlers m peer blk
-> NodeToNodeVersion
-> ControlMessageSTM m
-> peer
-> TxSubmissionClient (GenTxId blk) (GenTx blk) m ()
hTxSubmissionClient
        :: NodeToNodeVersion
        -> ControlMessageSTM m
        -> peer
        -> TxSubmissionClient (GenTxId blk) (GenTx blk) m ()

    , Handlers m peer blk
-> NodeToNodeVersion
-> peer
-> TxSubmissionServerPipelined (GenTxId blk) (GenTx blk) m ()
hTxSubmissionServer
        :: NodeToNodeVersion
        -> peer
        -> TxSubmissionServerPipelined (GenTxId blk) (GenTx blk) m ()

    , Handlers m peer blk
-> NodeToNodeVersion
-> ControlMessageSTM m
-> peer
-> StrictTVar m (Map peer PeerGSV)
-> KeepAliveInterval
-> KeepAliveClient m ()
hKeepAliveClient
        :: NodeToNodeVersion
        -> ControlMessageSTM m
        -> peer
        -> StrictTVar m (Map peer PeerGSV)
        -> KeepAliveInterval
        -> KeepAliveClient m ()

    , Handlers m peer blk
-> NodeToNodeVersion -> peer -> KeepAliveServer m ()
hKeepAliveServer
        :: NodeToNodeVersion
        -> peer
        -> KeepAliveServer m ()
    }

mkHandlers
  :: forall m blk remotePeer localPeer.
     ( IOLike m
     , MonadTimer m
     , LedgerSupportsMempool blk
     , HasTxId (GenTx blk)
     , LedgerSupportsProtocol blk
     , Ord remotePeer
     )
  => NodeArgs   m remotePeer localPeer blk
  -> NodeKernel m remotePeer localPeer blk
  -> Handlers   m remotePeer           blk
mkHandlers :: NodeArgs m remotePeer localPeer blk
-> NodeKernel m remotePeer localPeer blk
-> Handlers m remotePeer blk
mkHandlers
      NodeArgs {StdGen
$sel:keepAliveRng:NodeArgs :: forall (m :: * -> *) remotePeer localPeer blk.
NodeArgs m remotePeer localPeer blk -> StdGen
keepAliveRng :: StdGen
keepAliveRng, MiniProtocolParameters
$sel:miniProtocolParameters:NodeArgs :: forall (m :: * -> *) remotePeer localPeer blk.
NodeArgs m remotePeer localPeer blk -> MiniProtocolParameters
miniProtocolParameters :: MiniProtocolParameters
miniProtocolParameters}
      NodeKernel {ChainDB m blk
$sel:getChainDB:NodeKernel :: forall (m :: * -> *) remotePeer localPeer blk.
NodeKernel m remotePeer localPeer blk -> ChainDB m blk
getChainDB :: ChainDB m blk
getChainDB, Mempool m blk TicketNo
$sel:getMempool:NodeKernel :: forall (m :: * -> *) remotePeer localPeer blk.
NodeKernel m remotePeer localPeer blk -> Mempool m blk TicketNo
getMempool :: Mempool m blk TicketNo
getMempool, TopLevelConfig blk
$sel:getTopLevelConfig:NodeKernel :: forall (m :: * -> *) remotePeer localPeer blk.
NodeKernel m remotePeer localPeer blk -> TopLevelConfig blk
getTopLevelConfig :: TopLevelConfig blk
getTopLevelConfig, $sel:getTracers:NodeKernel :: forall (m :: * -> *) remotePeer localPeer blk.
NodeKernel m remotePeer localPeer blk
-> Tracers m remotePeer localPeer blk
getTracers = Tracers m remotePeer localPeer blk
tracers} =
    Handlers :: forall (m :: * -> *) peer blk.
(NodeToNodeVersion
 -> ControlMessageSTM m
 -> StrictTVar m (AnchoredFragment (Header blk))
 -> ChainSyncClientPipelined
      (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult)
-> (NodeToNodeVersion
    -> ResourceRegistry m
    -> ChainSyncServer
         (SerialisedHeader blk) (Point blk) (Tip blk) m ())
-> (NodeToNodeVersion
    -> ControlMessageSTM m -> BlockFetchClient (Header blk) blk m ())
-> (NodeToNodeVersion
    -> ResourceRegistry m
    -> BlockFetchServer (Serialised blk) (Point blk) m ())
-> (NodeToNodeVersion
    -> ControlMessageSTM m
    -> peer
    -> TxSubmissionClient (GenTxId blk) (GenTx blk) m ())
-> (NodeToNodeVersion
    -> peer
    -> TxSubmissionServerPipelined (GenTxId blk) (GenTx blk) m ())
-> (NodeToNodeVersion
    -> ControlMessageSTM m
    -> peer
    -> StrictTVar m (Map peer PeerGSV)
    -> KeepAliveInterval
    -> KeepAliveClient m ())
-> (NodeToNodeVersion -> peer -> KeepAliveServer m ())
-> Handlers m peer blk
Handlers {
        hChainSyncClient :: NodeToNodeVersion
-> ControlMessageSTM m
-> StrictTVar m (AnchoredFragment (Header blk))
-> ChainSyncClientPipelined
     (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult
hChainSyncClient =
          MkPipelineDecision
-> Tracer m (TraceChainSyncClientEvent blk)
-> TopLevelConfig blk
-> ChainDbView m blk
-> NodeToNodeVersion
-> ControlMessageSTM m
-> StrictTVar m (AnchoredFragment (Header blk))
-> ChainSyncClientPipelined
     (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult
forall (m :: * -> *) blk.
(IOLike m, LedgerSupportsProtocol blk) =>
MkPipelineDecision
-> Tracer m (TraceChainSyncClientEvent blk)
-> TopLevelConfig blk
-> ChainDbView m blk
-> NodeToNodeVersion
-> ControlMessageSTM m
-> StrictTVar m (AnchoredFragment (Header blk))
-> Consensus ChainSyncClientPipelined blk m
chainSyncClient
            (Word32 -> Word32 -> MkPipelineDecision
pipelineDecisionLowHighMark
              (MiniProtocolParameters -> Word32
chainSyncPipeliningLowMark  MiniProtocolParameters
miniProtocolParameters)
              (MiniProtocolParameters -> Word32
chainSyncPipeliningHighMark MiniProtocolParameters
miniProtocolParameters))
            (Tracers m remotePeer localPeer blk
-> Tracer m (TraceChainSyncClientEvent blk)
forall remotePeer localPeer blk (f :: * -> *).
Tracers' remotePeer localPeer blk f
-> f (TraceChainSyncClientEvent blk)
Node.chainSyncClientTracer Tracers m remotePeer localPeer blk
tracers)
            TopLevelConfig blk
getTopLevelConfig
            (ChainDB m blk -> ChainDbView m blk
forall (m :: * -> *) blk. ChainDB m blk -> ChainDbView m blk
defaultChainDbView ChainDB m blk
getChainDB)
      , hChainSyncServer :: NodeToNodeVersion
-> ResourceRegistry m
-> ChainSyncServer
     (SerialisedHeader blk) (Point blk) (Tip blk) m ()
hChainSyncServer =
          Tracer m (TraceChainSyncServerEvent blk)
-> ChainDB m blk
-> NodeToNodeVersion
-> ResourceRegistry m
-> ChainSyncServer
     (SerialisedHeader blk) (Point blk) (Tip blk) m ()
forall (m :: * -> *) blk.
(IOLike m, HasHeader (Header blk)) =>
Tracer m (TraceChainSyncServerEvent blk)
-> ChainDB m blk
-> NodeToNodeVersion
-> ResourceRegistry m
-> ChainSyncServer
     (SerialisedHeader blk) (Point blk) (Tip blk) m ()
chainSyncHeadersServer
            (Tracers m remotePeer localPeer blk
-> Tracer m (TraceChainSyncServerEvent blk)
forall remotePeer localPeer blk (f :: * -> *).
Tracers' remotePeer localPeer blk f
-> f (TraceChainSyncServerEvent blk)
Node.chainSyncServerHeaderTracer Tracers m remotePeer localPeer blk
tracers)
            ChainDB m blk
getChainDB
      , hBlockFetchClient :: NodeToNodeVersion
-> ControlMessageSTM m -> BlockFetchClient (Header blk) blk m ()
hBlockFetchClient =
          NodeToNodeVersion
-> ControlMessageSTM m -> BlockFetchClient (Header blk) blk m ()
forall header block (m :: * -> *).
(MonadSTM m, MonadThrow m, HasHeader header, HasHeader block,
 HeaderHash header ~ HeaderHash block) =>
NodeToNodeVersion
-> ControlMessageSTM m
-> FetchClientContext header block m
-> PeerPipelined
     (BlockFetch block (Point block)) 'AsClient 'BFIdle m ()
blockFetchClient
      , hBlockFetchServer :: NodeToNodeVersion
-> ResourceRegistry m
-> BlockFetchServer (Serialised blk) (Point blk) m ()
hBlockFetchServer = \NodeToNodeVersion
version ->
          Tracer m (TraceBlockFetchServerEvent blk)
-> ChainDB m blk
-> NodeToNodeVersion
-> ResourceRegistry m
-> BlockFetchServer (Serialised blk) (Point blk) m ()
forall (m :: * -> *) blk.
(IOLike m, StandardHash blk, Typeable blk) =>
Tracer m (TraceBlockFetchServerEvent blk)
-> ChainDB m blk
-> NodeToNodeVersion
-> ResourceRegistry m
-> BlockFetchServer (Serialised blk) (Point blk) m ()
blockFetchServer
            (Tracers m remotePeer localPeer blk
-> Tracer m (TraceBlockFetchServerEvent blk)
forall remotePeer localPeer blk (f :: * -> *).
Tracers' remotePeer localPeer blk f
-> f (TraceBlockFetchServerEvent blk)
Node.blockFetchServerTracer Tracers m remotePeer localPeer blk
tracers)
            ChainDB m blk
getChainDB
            NodeToNodeVersion
version
      , hTxSubmissionClient :: NodeToNodeVersion
-> ControlMessageSTM m
-> remotePeer
-> TxSubmissionClient (GenTxId blk) (GenTx blk) m ()
hTxSubmissionClient = \NodeToNodeVersion
version ControlMessageSTM m
controlMessageSTM remotePeer
peer ->
          Tracer m (TraceTxSubmissionOutbound (GenTxId blk) (GenTx blk))
-> Word16
-> TxSubmissionMempoolReader (GenTxId blk) (GenTx blk) TicketNo m
-> NodeToNodeVersion
-> ControlMessageSTM m
-> TxSubmissionClient (GenTxId blk) (GenTx blk) m ()
forall txid tx idx (m :: * -> *).
(Ord txid, Ord idx, MonadSTM m, MonadThrow m) =>
Tracer m (TraceTxSubmissionOutbound txid tx)
-> Word16
-> TxSubmissionMempoolReader txid tx idx m
-> NodeToNodeVersion
-> ControlMessageSTM m
-> TxSubmissionClient txid tx m ()
txSubmissionOutbound
            ((TraceTxSubmissionOutbound (GenTxId blk) (GenTx blk)
 -> TraceLabelPeer
      remotePeer (TraceTxSubmissionOutbound (GenTxId blk) (GenTx blk)))
-> Tracer
     m
     (TraceLabelPeer
        remotePeer (TraceTxSubmissionOutbound (GenTxId blk) (GenTx blk)))
-> Tracer m (TraceTxSubmissionOutbound (GenTxId blk) (GenTx blk))
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap (remotePeer
-> TraceTxSubmissionOutbound (GenTxId blk) (GenTx blk)
-> TraceLabelPeer
     remotePeer (TraceTxSubmissionOutbound (GenTxId blk) (GenTx blk))
forall peerid a. peerid -> a -> TraceLabelPeer peerid a
TraceLabelPeer remotePeer
peer) (Tracers m remotePeer localPeer blk
-> Tracer
     m
     (TraceLabelPeer
        remotePeer (TraceTxSubmissionOutbound (GenTxId blk) (GenTx blk)))
forall remotePeer localPeer blk (f :: * -> *).
Tracers' remotePeer localPeer blk f
-> f (TraceLabelPeer
        remotePeer (TraceTxSubmissionOutbound (GenTxId blk) (GenTx blk)))
Node.txOutboundTracer Tracers m remotePeer localPeer blk
tracers))
            (MiniProtocolParameters -> Word16
txSubmissionMaxUnacked MiniProtocolParameters
miniProtocolParameters)
            (Mempool m blk TicketNo
-> TxSubmissionMempoolReader (GenTxId blk) (GenTx blk) TicketNo m
forall (m :: * -> *) blk.
(IOLike m, HasTxId (GenTx blk)) =>
Mempool m blk TicketNo
-> TxSubmissionMempoolReader (GenTxId blk) (GenTx blk) TicketNo m
getMempoolReader Mempool m blk TicketNo
getMempool)
            NodeToNodeVersion
version
            ControlMessageSTM m
controlMessageSTM
      , hTxSubmissionServer :: NodeToNodeVersion
-> remotePeer
-> TxSubmissionServerPipelined (GenTxId blk) (GenTx blk) m ()
hTxSubmissionServer = \NodeToNodeVersion
version remotePeer
peer ->
          Tracer m (TraceTxSubmissionInbound (GenTxId blk) (GenTx blk))
-> Word16
-> TxSubmissionMempoolReader (GenTxId blk) (GenTx blk) TicketNo m
-> TxSubmissionMempoolWriter (GenTxId blk) (GenTx blk) TicketNo m
-> NodeToNodeVersion
-> TxSubmissionServerPipelined (GenTxId blk) (GenTx blk) m ()
forall txid tx idx (m :: * -> *).
(Ord txid, NoThunks txid, NoThunks tx, MonadSTM m, MonadThrow m) =>
Tracer m (TraceTxSubmissionInbound txid tx)
-> Word16
-> TxSubmissionMempoolReader txid tx idx m
-> TxSubmissionMempoolWriter txid tx idx m
-> NodeToNodeVersion
-> TxSubmissionServerPipelined txid tx m ()
txSubmissionInbound
            ((TraceTxSubmissionInbound (GenTxId blk) (GenTx blk)
 -> TraceLabelPeer
      remotePeer (TraceTxSubmissionInbound (GenTxId blk) (GenTx blk)))
-> Tracer
     m
     (TraceLabelPeer
        remotePeer (TraceTxSubmissionInbound (GenTxId blk) (GenTx blk)))
-> Tracer m (TraceTxSubmissionInbound (GenTxId blk) (GenTx blk))
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap (remotePeer
-> TraceTxSubmissionInbound (GenTxId blk) (GenTx blk)
-> TraceLabelPeer
     remotePeer (TraceTxSubmissionInbound (GenTxId blk) (GenTx blk))
forall peerid a. peerid -> a -> TraceLabelPeer peerid a
TraceLabelPeer remotePeer
peer) (Tracers m remotePeer localPeer blk
-> Tracer
     m
     (TraceLabelPeer
        remotePeer (TraceTxSubmissionInbound (GenTxId blk) (GenTx blk)))
forall remotePeer localPeer blk (f :: * -> *).
Tracers' remotePeer localPeer blk f
-> f (TraceLabelPeer
        remotePeer (TraceTxSubmissionInbound (GenTxId blk) (GenTx blk)))
Node.txInboundTracer Tracers m remotePeer localPeer blk
tracers))
            (MiniProtocolParameters -> Word16
txSubmissionMaxUnacked MiniProtocolParameters
miniProtocolParameters)
            (Mempool m blk TicketNo
-> TxSubmissionMempoolReader (GenTxId blk) (GenTx blk) TicketNo m
forall (m :: * -> *) blk.
(IOLike m, HasTxId (GenTx blk)) =>
Mempool m blk TicketNo
-> TxSubmissionMempoolReader (GenTxId blk) (GenTx blk) TicketNo m
getMempoolReader Mempool m blk TicketNo
getMempool)
            (Mempool m blk TicketNo
-> TxSubmissionMempoolWriter (GenTxId blk) (GenTx blk) TicketNo m
forall (m :: * -> *) blk.
(IOLike m, HasTxId (GenTx blk)) =>
Mempool m blk TicketNo
-> TxSubmissionMempoolWriter (GenTxId blk) (GenTx blk) TicketNo m
getMempoolWriter Mempool m blk TicketNo
getMempool)
            NodeToNodeVersion
version
      , hKeepAliveClient :: NodeToNodeVersion
-> ControlMessageSTM m
-> remotePeer
-> StrictTVar m (Map remotePeer PeerGSV)
-> KeepAliveInterval
-> KeepAliveClient m ()
hKeepAliveClient = \NodeToNodeVersion
_version -> Tracer m (TraceKeepAliveClient remotePeer)
-> StdGen
-> ControlMessageSTM m
-> remotePeer
-> StrictTVar m (Map remotePeer PeerGSV)
-> KeepAliveInterval
-> KeepAliveClient m ()
forall (m :: * -> *) peer.
(MonadSTM m, MonadMonotonicTime m, MonadTimer m, Ord peer) =>
Tracer m (TraceKeepAliveClient peer)
-> StdGen
-> ControlMessageSTM m
-> peer
-> StrictTVar m (Map peer PeerGSV)
-> KeepAliveInterval
-> KeepAliveClient m ()
keepAliveClient (Tracers m remotePeer localPeer blk
-> Tracer m (TraceKeepAliveClient remotePeer)
forall remotePeer localPeer blk (f :: * -> *).
Tracers' remotePeer localPeer blk f
-> f (TraceKeepAliveClient remotePeer)
Node.keepAliveClientTracer Tracers m remotePeer localPeer blk
tracers) StdGen
keepAliveRng
      , hKeepAliveServer :: NodeToNodeVersion -> remotePeer -> KeepAliveServer m ()
hKeepAliveServer = \NodeToNodeVersion
_version remotePeer
_peer -> KeepAliveServer m ()
forall (m :: * -> *). Applicative m => KeepAliveServer m ()
keepAliveServer
      }

{-------------------------------------------------------------------------------
  Codecs
-------------------------------------------------------------------------------}

-- | Node-to-node protocol codecs needed to run 'Handlers'.
data Codecs blk e m bCS bSCS bBF bSBF bTX bKA = Codecs {
      Codecs blk e m bCS bSCS bBF bSBF bTX bKA
-> Codec (ChainSync (Header blk) (Point blk) (Tip blk)) e m bCS
cChainSyncCodec            :: Codec (ChainSync (Header blk) (Point blk) (Tip blk))           e m bCS
    , Codecs blk e m bCS bSCS bBF bSBF bTX bKA
-> Codec
     (ChainSync (SerialisedHeader blk) (Point blk) (Tip blk)) e m bSCS
cChainSyncCodecSerialised  :: Codec (ChainSync (SerialisedHeader blk) (Point blk) (Tip blk)) e m bSCS
    , Codecs blk e m bCS bSCS bBF bSBF bTX bKA
-> Codec (BlockFetch blk (Point blk)) e m bBF
cBlockFetchCodec           :: Codec (BlockFetch blk (Point blk))                             e m bBF
    , Codecs blk e m bCS bSCS bBF bSBF bTX bKA
-> Codec (BlockFetch (Serialised blk) (Point blk)) e m bSBF
cBlockFetchCodecSerialised :: Codec (BlockFetch (Serialised blk) (Point blk))                e m bSBF
    , Codecs blk e m bCS bSCS bBF bSBF bTX bKA
-> Codec (TxSubmission (GenTxId blk) (GenTx blk)) e m bTX
cTxSubmissionCodec         :: Codec (TxSubmission (GenTxId blk) (GenTx blk))                 e m bTX
    , Codecs blk e m bCS bSCS bBF bSBF bTX bKA -> Codec KeepAlive e m bKA
cKeepAliveCodec            :: Codec KeepAlive                                                e m bKA
    }

-- | Protocol codecs for the node-to-node protocols
defaultCodecs :: forall m blk. (IOLike m, SerialiseNodeToNodeConstraints blk)
              => CodecConfig       blk
              -> BlockNodeToNodeVersion blk
              -> Codecs blk DeserialiseFailure m
                   ByteString ByteString ByteString ByteString ByteString ByteString
defaultCodecs :: CodecConfig blk
-> BlockNodeToNodeVersion blk
-> Codecs
     blk
     DeserialiseFailure
     m
     ByteString
     ByteString
     ByteString
     ByteString
     ByteString
     ByteString
defaultCodecs CodecConfig blk
ccfg BlockNodeToNodeVersion blk
version = Codecs :: forall blk e (m :: * -> *) bCS bSCS bBF bSBF bTX bKA.
Codec (ChainSync (Header blk) (Point blk) (Tip blk)) e m bCS
-> Codec
     (ChainSync (SerialisedHeader blk) (Point blk) (Tip blk)) e m bSCS
-> Codec (BlockFetch blk (Point blk)) e m bBF
-> Codec (BlockFetch (Serialised blk) (Point blk)) e m bSBF
-> Codec (TxSubmission (GenTxId blk) (GenTx blk)) e m bTX
-> Codec KeepAlive e m bKA
-> Codecs blk e m bCS bSCS bBF bSBF bTX bKA
Codecs {
      cChainSyncCodec :: Codec
  (ChainSync (Header blk) (Point blk) (Tip blk))
  DeserialiseFailure
  m
  ByteString
cChainSyncCodec =
        (Header blk -> Encoding)
-> (forall s. Decoder s (Header blk))
-> (Point blk -> Encoding)
-> (forall s. Decoder s (Point blk))
-> (Tip blk -> Encoding)
-> (forall s. Decoder s (Tip blk))
-> Codec
     (ChainSync (Header blk) (Point blk) (Tip blk))
     DeserialiseFailure
     m
     ByteString
forall header point tip (m :: * -> *).
MonadST m =>
(header -> Encoding)
-> (forall s. Decoder s header)
-> (point -> Encoding)
-> (forall s. Decoder s point)
-> (tip -> Encoding)
-> (forall s. Decoder s tip)
-> Codec
     (ChainSync header point tip) DeserialiseFailure m ByteString
codecChainSync
          Header blk -> Encoding
forall a. SerialiseNodeToNode blk a => a -> Encoding
enc
          forall s. Decoder s (Header blk)
forall a s. SerialiseNodeToNode blk a => Decoder s a
dec
          ((HeaderHash blk -> Encoding) -> Point blk -> Encoding
forall block.
(HeaderHash block -> Encoding) -> Point block -> Encoding
encodePoint (Proxy blk -> HeaderHash blk -> Encoding
forall blk (proxy :: * -> *).
ConvertRawHash blk =>
proxy blk -> HeaderHash blk -> Encoding
encodeRawHash Proxy blk
p))
          ((forall s. Decoder s (HeaderHash blk))
-> forall s. Decoder s (Point blk)
forall block.
(forall s. Decoder s (HeaderHash block))
-> forall s. Decoder s (Point block)
decodePoint (Proxy blk -> forall s. Decoder s (HeaderHash blk)
forall blk (proxy :: * -> *).
ConvertRawHash blk =>
proxy blk -> forall s. Decoder s (HeaderHash blk)
decodeRawHash Proxy blk
p))
          ((HeaderHash blk -> Encoding) -> Tip blk -> Encoding
forall blk. (HeaderHash blk -> Encoding) -> Tip blk -> Encoding
encodeTip   (Proxy blk -> HeaderHash blk -> Encoding
forall blk (proxy :: * -> *).
ConvertRawHash blk =>
proxy blk -> HeaderHash blk -> Encoding
encodeRawHash Proxy blk
p))
          ((forall s. Decoder s (HeaderHash blk))
-> forall s. Decoder s (Tip blk)
forall blk.
(forall s. Decoder s (HeaderHash blk))
-> forall s. Decoder s (Tip blk)
decodeTip   (Proxy blk -> forall s. Decoder s (HeaderHash blk)
forall blk (proxy :: * -> *).
ConvertRawHash blk =>
proxy blk -> forall s. Decoder s (HeaderHash blk)
decodeRawHash Proxy blk
p))

    , cChainSyncCodecSerialised :: Codec
  (ChainSync (SerialisedHeader blk) (Point blk) (Tip blk))
  DeserialiseFailure
  m
  ByteString
cChainSyncCodecSerialised =
        (SerialisedHeader blk -> Encoding)
-> (forall s. Decoder s (SerialisedHeader blk))
-> (Point blk -> Encoding)
-> (forall s. Decoder s (Point blk))
-> (Tip blk -> Encoding)
-> (forall s. Decoder s (Tip blk))
-> Codec
     (ChainSync (SerialisedHeader blk) (Point blk) (Tip blk))
     DeserialiseFailure
     m
     ByteString
forall header point tip (m :: * -> *).
MonadST m =>
(header -> Encoding)
-> (forall s. Decoder s header)
-> (point -> Encoding)
-> (forall s. Decoder s point)
-> (tip -> Encoding)
-> (forall s. Decoder s tip)
-> Codec
     (ChainSync header point tip) DeserialiseFailure m ByteString
codecChainSync
          SerialisedHeader blk -> Encoding
forall a. SerialiseNodeToNode blk a => a -> Encoding
enc
          forall s. Decoder s (SerialisedHeader blk)
forall a s. SerialiseNodeToNode blk a => Decoder s a
dec
          ((HeaderHash blk -> Encoding) -> Point blk -> Encoding
forall block.
(HeaderHash block -> Encoding) -> Point block -> Encoding
encodePoint (Proxy blk -> HeaderHash blk -> Encoding
forall blk (proxy :: * -> *).
ConvertRawHash blk =>
proxy blk -> HeaderHash blk -> Encoding
encodeRawHash Proxy blk
p))
          ((forall s. Decoder s (HeaderHash blk))
-> forall s. Decoder s (Point blk)
forall block.
(forall s. Decoder s (HeaderHash block))
-> forall s. Decoder s (Point block)
decodePoint (Proxy blk -> forall s. Decoder s (HeaderHash blk)
forall blk (proxy :: * -> *).
ConvertRawHash blk =>
proxy blk -> forall s. Decoder s (HeaderHash blk)
decodeRawHash Proxy blk
p))
          ((HeaderHash blk -> Encoding) -> Tip blk -> Encoding
forall blk. (HeaderHash blk -> Encoding) -> Tip blk -> Encoding
encodeTip   (Proxy blk -> HeaderHash blk -> Encoding
forall blk (proxy :: * -> *).
ConvertRawHash blk =>
proxy blk -> HeaderHash blk -> Encoding
encodeRawHash Proxy blk
p))
          ((forall s. Decoder s (HeaderHash blk))
-> forall s. Decoder s (Tip blk)
forall blk.
(forall s. Decoder s (HeaderHash blk))
-> forall s. Decoder s (Tip blk)
decodeTip   (Proxy blk -> forall s. Decoder s (HeaderHash blk)
forall blk (proxy :: * -> *).
ConvertRawHash blk =>
proxy blk -> forall s. Decoder s (HeaderHash blk)
decodeRawHash Proxy blk
p))

    , cBlockFetchCodec :: Codec (BlockFetch blk (Point blk)) DeserialiseFailure m ByteString
cBlockFetchCodec =
        (blk -> Encoding)
-> (forall s. Decoder s blk)
-> (Point blk -> Encoding)
-> (forall s. Decoder s (Point blk))
-> Codec
     (BlockFetch blk (Point blk)) DeserialiseFailure m ByteString
forall block point (m :: * -> *).
MonadST m =>
(block -> Encoding)
-> (forall s. Decoder s block)
-> (point -> Encoding)
-> (forall s. Decoder s point)
-> Codec (BlockFetch block point) DeserialiseFailure m ByteString
codecBlockFetch
          blk -> Encoding
forall a. SerialiseNodeToNode blk a => a -> Encoding
enc
          forall s. Decoder s blk
forall a s. SerialiseNodeToNode blk a => Decoder s a
dec
          ((HeaderHash blk -> Encoding) -> Point blk -> Encoding
forall block.
(HeaderHash block -> Encoding) -> Point block -> Encoding
encodePoint (Proxy blk -> HeaderHash blk -> Encoding
forall blk (proxy :: * -> *).
ConvertRawHash blk =>
proxy blk -> HeaderHash blk -> Encoding
encodeRawHash Proxy blk
p))
          ((forall s. Decoder s (HeaderHash blk))
-> forall s. Decoder s (Point blk)
forall block.
(forall s. Decoder s (HeaderHash block))
-> forall s. Decoder s (Point block)
decodePoint (Proxy blk -> forall s. Decoder s (HeaderHash blk)
forall blk (proxy :: * -> *).
ConvertRawHash blk =>
proxy blk -> forall s. Decoder s (HeaderHash blk)
decodeRawHash Proxy blk
p))

    , cBlockFetchCodecSerialised :: Codec
  (BlockFetch (Serialised blk) (Point blk))
  DeserialiseFailure
  m
  ByteString
cBlockFetchCodecSerialised =
        (Serialised blk -> Encoding)
-> (forall s. Decoder s (Serialised blk))
-> (Point blk -> Encoding)
-> (forall s. Decoder s (Point blk))
-> Codec
     (BlockFetch (Serialised blk) (Point blk))
     DeserialiseFailure
     m
     ByteString
forall block point (m :: * -> *).
MonadST m =>
(block -> Encoding)
-> (forall s. Decoder s block)
-> (point -> Encoding)
-> (forall s. Decoder s point)
-> Codec (BlockFetch block point) DeserialiseFailure m ByteString
codecBlockFetch
          Serialised blk -> Encoding
forall a. SerialiseNodeToNode blk a => a -> Encoding
enc
          forall s. Decoder s (Serialised blk)
forall a s. SerialiseNodeToNode blk a => Decoder s a
dec
          ((HeaderHash blk -> Encoding) -> Point blk -> Encoding
forall block.
(HeaderHash block -> Encoding) -> Point block -> Encoding
encodePoint (Proxy blk -> HeaderHash blk -> Encoding
forall blk (proxy :: * -> *).
ConvertRawHash blk =>
proxy blk -> HeaderHash blk -> Encoding
encodeRawHash Proxy blk
p))
          ((forall s. Decoder s (HeaderHash blk))
-> forall s. Decoder s (Point blk)
forall block.
(forall s. Decoder s (HeaderHash block))
-> forall s. Decoder s (Point block)
decodePoint (Proxy blk -> forall s. Decoder s (HeaderHash blk)
forall blk (proxy :: * -> *).
ConvertRawHash blk =>
proxy blk -> forall s. Decoder s (HeaderHash blk)
decodeRawHash Proxy blk
p))

    , cTxSubmissionCodec :: Codec
  (TxSubmission (GenTxId blk) (GenTx blk))
  DeserialiseFailure
  m
  ByteString
cTxSubmissionCodec =
        (GenTxId blk -> Encoding)
-> (forall s. Decoder s (GenTxId blk))
-> (GenTx blk -> Encoding)
-> (forall s. Decoder s (GenTx blk))
-> Codec
     (TxSubmission (GenTxId blk) (GenTx blk))
     DeserialiseFailure
     m
     ByteString
forall txid tx (m :: * -> *).
MonadST m =>
(txid -> Encoding)
-> (forall s. Decoder s txid)
-> (tx -> Encoding)
-> (forall s. Decoder s tx)
-> Codec (TxSubmission txid tx) DeserialiseFailure m ByteString
codecTxSubmission
          GenTxId blk -> Encoding
forall a. SerialiseNodeToNode blk a => a -> Encoding
enc
          forall s. Decoder s (GenTxId blk)
forall a s. SerialiseNodeToNode blk a => Decoder s a
dec
          GenTx blk -> Encoding
forall a. SerialiseNodeToNode blk a => a -> Encoding
enc
          forall s. Decoder s (GenTx blk)
forall a s. SerialiseNodeToNode blk a => Decoder s a
dec

    , cKeepAliveCodec :: Codec KeepAlive DeserialiseFailure m ByteString
cKeepAliveCodec =
        Codec KeepAlive DeserialiseFailure m ByteString
forall (m :: * -> *).
MonadST m =>
Codec KeepAlive DeserialiseFailure m ByteString
codecKeepAlive
    }
  where
    p :: Proxy blk
    p :: Proxy blk
p = Proxy blk
forall k (t :: k). Proxy t
Proxy

    enc :: SerialiseNodeToNode blk a => a -> Encoding
    enc :: a -> Encoding
enc = CodecConfig blk -> BlockNodeToNodeVersion blk -> a -> Encoding
forall blk a.
SerialiseNodeToNode blk a =>
CodecConfig blk -> BlockNodeToNodeVersion blk -> a -> Encoding
encodeNodeToNode CodecConfig blk
ccfg BlockNodeToNodeVersion blk
version

    dec :: SerialiseNodeToNode blk a => forall s. Decoder s a
    dec :: forall s. Decoder s a
dec = CodecConfig blk
-> BlockNodeToNodeVersion blk -> forall s. Decoder s a
forall blk a.
SerialiseNodeToNode blk a =>
CodecConfig blk
-> BlockNodeToNodeVersion blk -> forall s. Decoder s a
decodeNodeToNode CodecConfig blk
ccfg BlockNodeToNodeVersion blk
version

-- | Identity codecs used in tests.
identityCodecs :: Monad m
               => Codecs blk 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 (TxSubmission (GenTxId blk) (GenTx blk)))
                    (AnyMessage KeepAlive)
identityCodecs :: Codecs
  blk
  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 (TxSubmission (GenTxId blk) (GenTx blk)))
  (AnyMessage KeepAlive)
identityCodecs = Codecs :: forall blk e (m :: * -> *) bCS bSCS bBF bSBF bTX bKA.
Codec (ChainSync (Header blk) (Point blk) (Tip blk)) e m bCS
-> Codec
     (ChainSync (SerialisedHeader blk) (Point blk) (Tip blk)) e m bSCS
-> Codec (BlockFetch blk (Point blk)) e m bBF
-> Codec (BlockFetch (Serialised blk) (Point blk)) e m bSBF
-> Codec (TxSubmission (GenTxId blk) (GenTx blk)) e m bTX
-> Codec KeepAlive e m bKA
-> Codecs blk e m bCS bSCS bBF bSBF bTX bKA
Codecs {
      cChainSyncCodec :: Codec
  (ChainSync (Header blk) (Point blk) (Tip blk))
  CodecFailure
  m
  (AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk)))
cChainSyncCodec            = Codec
  (ChainSync (Header blk) (Point blk) (Tip blk))
  CodecFailure
  m
  (AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk)))
forall k1 k2 k3 (header :: k1) (point :: k2) (tip :: k3)
       (m :: * -> *).
Monad m =>
Codec
  (ChainSync header point tip)
  CodecFailure
  m
  (AnyMessage (ChainSync header point tip))
codecChainSyncId
    , cChainSyncCodecSerialised :: Codec
  (ChainSync (SerialisedHeader blk) (Point blk) (Tip blk))
  CodecFailure
  m
  (AnyMessage
     (ChainSync (SerialisedHeader blk) (Point blk) (Tip blk)))
cChainSyncCodecSerialised  = Codec
  (ChainSync (SerialisedHeader blk) (Point blk) (Tip blk))
  CodecFailure
  m
  (AnyMessage
     (ChainSync (SerialisedHeader blk) (Point blk) (Tip blk)))
forall k1 k2 k3 (header :: k1) (point :: k2) (tip :: k3)
       (m :: * -> *).
Monad m =>
Codec
  (ChainSync header point tip)
  CodecFailure
  m
  (AnyMessage (ChainSync header point tip))
codecChainSyncId
    , cBlockFetchCodec :: Codec
  (BlockFetch blk (Point blk))
  CodecFailure
  m
  (AnyMessage (BlockFetch blk (Point blk)))
cBlockFetchCodec           = Codec
  (BlockFetch blk (Point blk))
  CodecFailure
  m
  (AnyMessage (BlockFetch blk (Point blk)))
forall k1 k2 (block :: k1) (point :: k2) (m :: * -> *).
Monad m =>
Codec
  (BlockFetch block point)
  CodecFailure
  m
  (AnyMessage (BlockFetch block point))
codecBlockFetchId
    , cBlockFetchCodecSerialised :: Codec
  (BlockFetch (Serialised blk) (Point blk))
  CodecFailure
  m
  (AnyMessage (BlockFetch (Serialised blk) (Point blk)))
cBlockFetchCodecSerialised = Codec
  (BlockFetch (Serialised blk) (Point blk))
  CodecFailure
  m
  (AnyMessage (BlockFetch (Serialised blk) (Point blk)))
forall k1 k2 (block :: k1) (point :: k2) (m :: * -> *).
Monad m =>
Codec
  (BlockFetch block point)
  CodecFailure
  m
  (AnyMessage (BlockFetch block point))
codecBlockFetchId
    , cTxSubmissionCodec :: Codec
  (TxSubmission (GenTxId blk) (GenTx blk))
  CodecFailure
  m
  (AnyMessage (TxSubmission (GenTxId blk) (GenTx blk)))
cTxSubmissionCodec         = Codec
  (TxSubmission (GenTxId blk) (GenTx blk))
  CodecFailure
  m
  (AnyMessage (TxSubmission (GenTxId blk) (GenTx blk)))
forall k1 k2 (txid :: k1) (tx :: k2) (m :: * -> *).
Monad m =>
Codec
  (TxSubmission txid tx)
  CodecFailure
  m
  (AnyMessage (TxSubmission txid tx))
codecTxSubmissionId
    , cKeepAliveCodec :: Codec KeepAlive CodecFailure m (AnyMessage KeepAlive)
cKeepAliveCodec            = Codec KeepAlive CodecFailure m (AnyMessage KeepAlive)
forall (m :: * -> *).
Monad m =>
Codec KeepAlive CodecFailure m (AnyMessage KeepAlive)
codecKeepAliveId
    }

{-------------------------------------------------------------------------------
  Tracers
-------------------------------------------------------------------------------}

-- | A record of 'Tracer's for the different protocols.
type Tracers m peer blk e =
     Tracers'  peer blk e (Tracer m)

data Tracers' peer blk e f = Tracers {
      Tracers' peer blk e f
-> f (TraceLabelPeer
        peer
        (TraceSendRecv (ChainSync (Header blk) (Point blk) (Tip blk))))
tChainSyncTracer            :: f (TraceLabelPeer peer (TraceSendRecv (ChainSync (Header blk) (Point blk) (Tip blk))))
    , Tracers' peer blk e f
-> f (TraceLabelPeer
        peer
        (TraceSendRecv
           (ChainSync (SerialisedHeader blk) (Point blk) (Tip blk))))
tChainSyncSerialisedTracer  :: f (TraceLabelPeer peer (TraceSendRecv (ChainSync (SerialisedHeader blk) (Point blk) (Tip blk))))
    , Tracers' peer blk e f
-> f (TraceLabelPeer
        peer (TraceSendRecv (BlockFetch blk (Point blk))))
tBlockFetchTracer           :: f (TraceLabelPeer peer (TraceSendRecv (BlockFetch blk (Point blk))))
    , Tracers' peer blk e f
-> f (TraceLabelPeer
        peer (TraceSendRecv (BlockFetch (Serialised blk) (Point blk))))
tBlockFetchSerialisedTracer :: f (TraceLabelPeer peer (TraceSendRecv (BlockFetch (Serialised blk) (Point blk))))
    , Tracers' peer blk e f
-> f (TraceLabelPeer
        peer (TraceSendRecv (TxSubmission (GenTxId blk) (GenTx blk))))
tTxSubmissionTracer         :: f (TraceLabelPeer peer (TraceSendRecv (TxSubmission (GenTxId blk) (GenTx blk))))
    }

instance (forall a. Semigroup (f a)) => Semigroup (Tracers' peer blk e f) where
  Tracers' peer blk e f
l <> :: Tracers' peer blk e f
-> Tracers' peer blk e f -> Tracers' peer blk e f
<> Tracers' peer blk e f
r = Tracers :: forall peer blk e (f :: * -> *).
f (TraceLabelPeer
     peer
     (TraceSendRecv (ChainSync (Header blk) (Point blk) (Tip blk))))
-> f (TraceLabelPeer
        peer
        (TraceSendRecv
           (ChainSync (SerialisedHeader blk) (Point blk) (Tip blk))))
-> f (TraceLabelPeer
        peer (TraceSendRecv (BlockFetch blk (Point blk))))
-> f (TraceLabelPeer
        peer (TraceSendRecv (BlockFetch (Serialised blk) (Point blk))))
-> f (TraceLabelPeer
        peer (TraceSendRecv (TxSubmission (GenTxId blk) (GenTx blk))))
-> Tracers' peer blk e f
Tracers {
        tChainSyncTracer :: f (TraceLabelPeer
     peer
     (TraceSendRecv (ChainSync (Header blk) (Point blk) (Tip blk))))
tChainSyncTracer            = (Tracers' peer blk e f
 -> f (TraceLabelPeer
         peer
         (TraceSendRecv (ChainSync (Header blk) (Point blk) (Tip blk)))))
-> f (TraceLabelPeer
        peer
        (TraceSendRecv (ChainSync (Header blk) (Point blk) (Tip blk))))
forall a. Semigroup a => (Tracers' peer blk e f -> a) -> a
f Tracers' peer blk e f
-> f (TraceLabelPeer
        peer
        (TraceSendRecv (ChainSync (Header blk) (Point blk) (Tip blk))))
forall peer blk e (f :: * -> *).
Tracers' peer blk e f
-> f (TraceLabelPeer
        peer
        (TraceSendRecv (ChainSync (Header blk) (Point blk) (Tip blk))))
tChainSyncTracer
      , tChainSyncSerialisedTracer :: f (TraceLabelPeer
     peer
     (TraceSendRecv
        (ChainSync (SerialisedHeader blk) (Point blk) (Tip blk))))
tChainSyncSerialisedTracer  = (Tracers' peer blk e f
 -> f (TraceLabelPeer
         peer
         (TraceSendRecv
            (ChainSync (SerialisedHeader blk) (Point blk) (Tip blk)))))
-> f (TraceLabelPeer
        peer
        (TraceSendRecv
           (ChainSync (SerialisedHeader blk) (Point blk) (Tip blk))))
forall a. Semigroup a => (Tracers' peer blk e f -> a) -> a
f Tracers' peer blk e f
-> f (TraceLabelPeer
        peer
        (TraceSendRecv
           (ChainSync (SerialisedHeader blk) (Point blk) (Tip blk))))
forall peer blk e (f :: * -> *).
Tracers' peer blk e f
-> f (TraceLabelPeer
        peer
        (TraceSendRecv
           (ChainSync (SerialisedHeader blk) (Point blk) (Tip blk))))
tChainSyncSerialisedTracer
      , tBlockFetchTracer :: f (TraceLabelPeer
     peer (TraceSendRecv (BlockFetch blk (Point blk))))
tBlockFetchTracer           = (Tracers' peer blk e f
 -> f (TraceLabelPeer
         peer (TraceSendRecv (BlockFetch blk (Point blk)))))
-> f (TraceLabelPeer
        peer (TraceSendRecv (BlockFetch blk (Point blk))))
forall a. Semigroup a => (Tracers' peer blk e f -> a) -> a
f Tracers' peer blk e f
-> f (TraceLabelPeer
        peer (TraceSendRecv (BlockFetch blk (Point blk))))
forall peer blk e (f :: * -> *).
Tracers' peer blk e f
-> f (TraceLabelPeer
        peer (TraceSendRecv (BlockFetch blk (Point blk))))
tBlockFetchTracer
      , tBlockFetchSerialisedTracer :: f (TraceLabelPeer
     peer (TraceSendRecv (BlockFetch (Serialised blk) (Point blk))))
tBlockFetchSerialisedTracer = (Tracers' peer blk e f
 -> f (TraceLabelPeer
         peer (TraceSendRecv (BlockFetch (Serialised blk) (Point blk)))))
-> f (TraceLabelPeer
        peer (TraceSendRecv (BlockFetch (Serialised blk) (Point blk))))
forall a. Semigroup a => (Tracers' peer blk e f -> a) -> a
f Tracers' peer blk e f
-> f (TraceLabelPeer
        peer (TraceSendRecv (BlockFetch (Serialised blk) (Point blk))))
forall peer blk e (f :: * -> *).
Tracers' peer blk e f
-> f (TraceLabelPeer
        peer (TraceSendRecv (BlockFetch (Serialised blk) (Point blk))))
tBlockFetchSerialisedTracer
      , tTxSubmissionTracer :: f (TraceLabelPeer
     peer (TraceSendRecv (TxSubmission (GenTxId blk) (GenTx blk))))
tTxSubmissionTracer         = (Tracers' peer blk e f
 -> f (TraceLabelPeer
         peer (TraceSendRecv (TxSubmission (GenTxId blk) (GenTx blk)))))
-> f (TraceLabelPeer
        peer (TraceSendRecv (TxSubmission (GenTxId blk) (GenTx blk))))
forall a. Semigroup a => (Tracers' peer blk e f -> a) -> a
f Tracers' peer blk e f
-> f (TraceLabelPeer
        peer (TraceSendRecv (TxSubmission (GenTxId blk) (GenTx blk))))
forall peer blk e (f :: * -> *).
Tracers' peer blk e f
-> f (TraceLabelPeer
        peer (TraceSendRecv (TxSubmission (GenTxId blk) (GenTx blk))))
tTxSubmissionTracer
      }
    where
      f :: forall a. Semigroup a
        => (Tracers' peer blk e f -> a)
        -> a
      f :: (Tracers' peer blk e f -> a) -> a
f Tracers' peer blk e f -> a
prj = Tracers' peer blk e f -> a
prj Tracers' peer blk e f
l a -> a -> a
forall a. Semigroup a => a -> a -> a
<> Tracers' peer blk e f -> a
prj Tracers' peer blk e f
r

-- | Use a 'nullTracer' for each protocol.
nullTracers :: Monad m => Tracers m peer blk e
nullTracers :: Tracers m peer blk e
nullTracers = Tracers :: forall peer blk e (f :: * -> *).
f (TraceLabelPeer
     peer
     (TraceSendRecv (ChainSync (Header blk) (Point blk) (Tip blk))))
-> f (TraceLabelPeer
        peer
        (TraceSendRecv
           (ChainSync (SerialisedHeader blk) (Point blk) (Tip blk))))
-> f (TraceLabelPeer
        peer (TraceSendRecv (BlockFetch blk (Point blk))))
-> f (TraceLabelPeer
        peer (TraceSendRecv (BlockFetch (Serialised blk) (Point blk))))
-> f (TraceLabelPeer
        peer (TraceSendRecv (TxSubmission (GenTxId blk) (GenTx blk))))
-> Tracers' peer blk e f
Tracers {
      tChainSyncTracer :: Tracer
  m
  (TraceLabelPeer
     peer
     (TraceSendRecv (ChainSync (Header blk) (Point blk) (Tip blk))))
tChainSyncTracer            = Tracer
  m
  (TraceLabelPeer
     peer
     (TraceSendRecv (ChainSync (Header blk) (Point blk) (Tip blk))))
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
    , tChainSyncSerialisedTracer :: Tracer
  m
  (TraceLabelPeer
     peer
     (TraceSendRecv
        (ChainSync (SerialisedHeader blk) (Point blk) (Tip blk))))
tChainSyncSerialisedTracer  = Tracer
  m
  (TraceLabelPeer
     peer
     (TraceSendRecv
        (ChainSync (SerialisedHeader blk) (Point blk) (Tip blk))))
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
    , tBlockFetchTracer :: Tracer
  m
  (TraceLabelPeer peer (TraceSendRecv (BlockFetch blk (Point blk))))
tBlockFetchTracer           = Tracer
  m
  (TraceLabelPeer peer (TraceSendRecv (BlockFetch blk (Point blk))))
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
    , tBlockFetchSerialisedTracer :: Tracer
  m
  (TraceLabelPeer
     peer (TraceSendRecv (BlockFetch (Serialised blk) (Point blk))))
tBlockFetchSerialisedTracer = Tracer
  m
  (TraceLabelPeer
     peer (TraceSendRecv (BlockFetch (Serialised blk) (Point blk))))
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
    , tTxSubmissionTracer :: Tracer
  m
  (TraceLabelPeer
     peer (TraceSendRecv (TxSubmission (GenTxId blk) (GenTx blk))))
tTxSubmissionTracer         = Tracer
  m
  (TraceLabelPeer
     peer (TraceSendRecv (TxSubmission (GenTxId blk) (GenTx blk))))
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
    }

showTracers :: ( 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
showTracers :: Tracer m String -> Tracers m peer blk e
showTracers Tracer m String
tr = Tracers :: forall peer blk e (f :: * -> *).
f (TraceLabelPeer
     peer
     (TraceSendRecv (ChainSync (Header blk) (Point blk) (Tip blk))))
-> f (TraceLabelPeer
        peer
        (TraceSendRecv
           (ChainSync (SerialisedHeader blk) (Point blk) (Tip blk))))
-> f (TraceLabelPeer
        peer (TraceSendRecv (BlockFetch blk (Point blk))))
-> f (TraceLabelPeer
        peer (TraceSendRecv (BlockFetch (Serialised blk) (Point blk))))
-> f (TraceLabelPeer
        peer (TraceSendRecv (TxSubmission (GenTxId blk) (GenTx blk))))
-> Tracers' peer blk e f
Tracers {
      tChainSyncTracer :: Tracer
  m
  (TraceLabelPeer
     peer
     (TraceSendRecv (ChainSync (Header blk) (Point blk) (Tip blk))))
tChainSyncTracer            = Tracer m String
-> Tracer
     m
     (TraceLabelPeer
        peer
        (TraceSendRecv (ChainSync (Header blk) (Point blk) (Tip blk))))
forall a (m :: * -> *). Show a => Tracer m String -> Tracer m a
showTracing Tracer m String
tr
    , tChainSyncSerialisedTracer :: Tracer
  m
  (TraceLabelPeer
     peer
     (TraceSendRecv
        (ChainSync (SerialisedHeader blk) (Point blk) (Tip blk))))
tChainSyncSerialisedTracer  = Tracer m String
-> Tracer
     m
     (TraceLabelPeer
        peer
        (TraceSendRecv
           (ChainSync (SerialisedHeader blk) (Point blk) (Tip blk))))
forall a (m :: * -> *). Show a => Tracer m String -> Tracer m a
showTracing Tracer m String
tr
    , tBlockFetchTracer :: Tracer
  m
  (TraceLabelPeer peer (TraceSendRecv (BlockFetch blk (Point blk))))
tBlockFetchTracer           = Tracer m String
-> Tracer
     m
     (TraceLabelPeer peer (TraceSendRecv (BlockFetch blk (Point blk))))
forall a (m :: * -> *). Show a => Tracer m String -> Tracer m a
showTracing Tracer m String
tr
    , tBlockFetchSerialisedTracer :: Tracer
  m
  (TraceLabelPeer
     peer (TraceSendRecv (BlockFetch (Serialised blk) (Point blk))))
tBlockFetchSerialisedTracer = Tracer m String
-> Tracer
     m
     (TraceLabelPeer
        peer (TraceSendRecv (BlockFetch (Serialised blk) (Point blk))))
forall a (m :: * -> *). Show a => Tracer m String -> Tracer m a
showTracing Tracer m String
tr
    , tTxSubmissionTracer :: Tracer
  m
  (TraceLabelPeer
     peer (TraceSendRecv (TxSubmission (GenTxId blk) (GenTx blk))))
tTxSubmissionTracer         = Tracer m String
-> Tracer
     m
     (TraceLabelPeer
        peer (TraceSendRecv (TxSubmission (GenTxId blk) (GenTx blk))))
forall a (m :: * -> *). Show a => Tracer m String -> Tracer m a
showTracing Tracer m String
tr
    }

{-------------------------------------------------------------------------------
  Applications
-------------------------------------------------------------------------------}

-- | A node-to-node application
type ClientApp m peer bytes a =
     NodeToNodeVersion
  -> ControlMessageSTM m
  -> peer
  -> Channel m bytes
  -> m (a, Maybe bytes)

type ServerApp m peer bytes a =
     NodeToNodeVersion
  -> peer
  -> Channel m bytes
  -> m (a, Maybe bytes)

-- | Applications for the node-to-node protocols
--
-- See 'Network.Mux.Types.MuxApplication'
data Apps m peer bCS bBF bTX bKA a = Apps {
      -- | Start a chain sync client that communicates with the given upstream
      -- node.
      Apps m peer bCS bBF bTX bKA a -> ClientApp m peer bCS a
aChainSyncClient    :: ClientApp m peer bCS a

      -- | Start a chain sync server.
    , Apps m peer bCS bBF bTX bKA a -> ServerApp m peer bCS a
aChainSyncServer    :: ServerApp m peer bCS a

      -- | Start a block fetch client that communicates with the given
      -- upstream node.
    , Apps m peer bCS bBF bTX bKA a -> ClientApp m peer bBF a
aBlockFetchClient   :: ClientApp m peer bBF a

      -- | Start a block fetch server.
    , Apps m peer bCS bBF bTX bKA a -> ServerApp m peer bBF a
aBlockFetchServer   :: ServerApp m peer bBF a

      -- | Start a transaction submission client that communicates with the
      -- given upstream node.
    , Apps m peer bCS bBF bTX bKA a -> ClientApp m peer bTX a
aTxSubmissionClient :: ClientApp m peer bTX a

      -- | Start a transaction submission server.
    , Apps m peer bCS bBF bTX bKA a -> ServerApp m peer bTX a
aTxSubmissionServer :: ServerApp m peer bTX a

      -- | Start a keep-alive client.
    , Apps m peer bCS bBF bTX bKA a -> ClientApp m peer bKA a
aKeepAliveClient    :: ClientApp m peer bKA a

      -- | Start a keep-alive server.
    , Apps m peer bCS bBF bTX bKA a -> ServerApp m peer bKA a
aKeepAliveServer    :: ServerApp m peer bKA a
    }

-- | Construct the 'NetworkApplication' for the node-to-node protocols
mkApps
  :: forall m remotePeer localPeer blk e bCS bBF bTX bKA.
     ( IOLike m
     , MonadTimer m
     , Ord remotePeer
     , Exception e
     , LedgerSupportsProtocol blk
     , ShowProxy blk
     , ShowProxy (Header blk)
     , ShowProxy (TxId (GenTx blk))
     , ShowProxy (GenTx blk)
     )
  => NodeKernel m remotePeer localPeer blk -- ^ Needed for bracketing only
  -> Tracers m remotePeer blk e
  -> Codecs blk e m bCS bCS bBF bBF bTX bKA
  -> m ChainSyncTimeout
  -> Handlers m remotePeer blk
  -> Apps m remotePeer bCS bBF bTX bKA ()
mkApps :: NodeKernel m remotePeer localPeer blk
-> Tracers m remotePeer blk e
-> Codecs blk e m bCS bCS bBF bBF bTX bKA
-> m ChainSyncTimeout
-> Handlers m remotePeer blk
-> Apps m remotePeer bCS bBF bTX bKA ()
mkApps NodeKernel m remotePeer localPeer blk
kernel Tracers {Tracer
  m
  (TraceLabelPeer
     remotePeer
     (TraceSendRecv (ChainSync (Header blk) (Point blk) (Tip blk))))
Tracer
  m
  (TraceLabelPeer
     remotePeer
     (TraceSendRecv
        (ChainSync (SerialisedHeader blk) (Point blk) (Tip blk))))
Tracer
  m
  (TraceLabelPeer
     remotePeer (TraceSendRecv (BlockFetch blk (Point blk))))
Tracer
  m
  (TraceLabelPeer
     remotePeer
     (TraceSendRecv (BlockFetch (Serialised blk) (Point blk))))
Tracer
  m
  (TraceLabelPeer
     remotePeer
     (TraceSendRecv (TxSubmission (GenTxId blk) (GenTx blk))))
tTxSubmissionTracer :: Tracer
  m
  (TraceLabelPeer
     remotePeer
     (TraceSendRecv (TxSubmission (GenTxId blk) (GenTx blk))))
tBlockFetchSerialisedTracer :: Tracer
  m
  (TraceLabelPeer
     remotePeer
     (TraceSendRecv (BlockFetch (Serialised blk) (Point blk))))
tBlockFetchTracer :: Tracer
  m
  (TraceLabelPeer
     remotePeer (TraceSendRecv (BlockFetch blk (Point blk))))
tChainSyncSerialisedTracer :: Tracer
  m
  (TraceLabelPeer
     remotePeer
     (TraceSendRecv
        (ChainSync (SerialisedHeader blk) (Point blk) (Tip blk))))
tChainSyncTracer :: Tracer
  m
  (TraceLabelPeer
     remotePeer
     (TraceSendRecv (ChainSync (Header blk) (Point blk) (Tip blk))))
tTxSubmissionTracer :: forall peer blk e (f :: * -> *).
Tracers' peer blk e f
-> f (TraceLabelPeer
        peer (TraceSendRecv (TxSubmission (GenTxId blk) (GenTx blk))))
tBlockFetchSerialisedTracer :: forall peer blk e (f :: * -> *).
Tracers' peer blk e f
-> f (TraceLabelPeer
        peer (TraceSendRecv (BlockFetch (Serialised blk) (Point blk))))
tBlockFetchTracer :: forall peer blk e (f :: * -> *).
Tracers' peer blk e f
-> f (TraceLabelPeer
        peer (TraceSendRecv (BlockFetch blk (Point blk))))
tChainSyncSerialisedTracer :: forall peer blk e (f :: * -> *).
Tracers' peer blk e f
-> f (TraceLabelPeer
        peer
        (TraceSendRecv
           (ChainSync (SerialisedHeader blk) (Point blk) (Tip blk))))
tChainSyncTracer :: forall peer blk e (f :: * -> *).
Tracers' peer blk e f
-> f (TraceLabelPeer
        peer
        (TraceSendRecv (ChainSync (Header blk) (Point blk) (Tip blk))))
..} Codecs {Codec (ChainSync (Header blk) (Point blk) (Tip blk)) e m bCS
Codec
  (ChainSync (SerialisedHeader blk) (Point blk) (Tip blk)) e m bCS
Codec (BlockFetch blk (Point blk)) e m bBF
Codec (BlockFetch (Serialised blk) (Point blk)) e m bBF
Codec (TxSubmission (GenTxId blk) (GenTx blk)) e m bTX
Codec KeepAlive e m bKA
cKeepAliveCodec :: Codec KeepAlive e m bKA
cTxSubmissionCodec :: Codec (TxSubmission (GenTxId blk) (GenTx blk)) e m bTX
cBlockFetchCodecSerialised :: Codec (BlockFetch (Serialised blk) (Point blk)) e m bBF
cBlockFetchCodec :: Codec (BlockFetch blk (Point blk)) e m bBF
cChainSyncCodecSerialised :: Codec
  (ChainSync (SerialisedHeader blk) (Point blk) (Tip blk)) e m bCS
cChainSyncCodec :: Codec (ChainSync (Header blk) (Point blk) (Tip blk)) e m bCS
cKeepAliveCodec :: forall blk e (m :: * -> *) bCS bSCS bBF bSBF bTX bKA.
Codecs blk e m bCS bSCS bBF bSBF bTX bKA -> Codec KeepAlive e m bKA
cTxSubmissionCodec :: forall blk e (m :: * -> *) bCS bSCS bBF bSBF bTX bKA.
Codecs blk e m bCS bSCS bBF bSBF bTX bKA
-> Codec (TxSubmission (GenTxId blk) (GenTx blk)) e m bTX
cBlockFetchCodecSerialised :: forall blk e (m :: * -> *) bCS bSCS bBF bSBF bTX bKA.
Codecs blk e m bCS bSCS bBF bSBF bTX bKA
-> Codec (BlockFetch (Serialised blk) (Point blk)) e m bSBF
cBlockFetchCodec :: forall blk e (m :: * -> *) bCS bSCS bBF bSBF bTX bKA.
Codecs blk e m bCS bSCS bBF bSBF bTX bKA
-> Codec (BlockFetch blk (Point blk)) e m bBF
cChainSyncCodecSerialised :: forall blk e (m :: * -> *) bCS bSCS bBF bSBF bTX bKA.
Codecs blk e m bCS bSCS bBF bSBF bTX bKA
-> Codec
     (ChainSync (SerialisedHeader blk) (Point blk) (Tip blk)) e m bSCS
cChainSyncCodec :: forall blk e (m :: * -> *) bCS bSCS bBF bSBF bTX bKA.
Codecs blk e m bCS bSCS bBF bSBF bTX bKA
-> Codec (ChainSync (Header blk) (Point blk) (Tip blk)) e m bCS
..} m ChainSyncTimeout
genChainSyncTimeout Handlers {NodeToNodeVersion
-> remotePeer
-> TxSubmissionServerPipelined (GenTxId blk) (GenTx blk) m ()
NodeToNodeVersion -> remotePeer -> KeepAliveServer m ()
NodeToNodeVersion
-> ControlMessageSTM m
-> remotePeer
-> TxSubmissionClient (GenTxId blk) (GenTx blk) m ()
NodeToNodeVersion
-> ControlMessageSTM m
-> remotePeer
-> StrictTVar m (Map remotePeer PeerGSV)
-> KeepAliveInterval
-> KeepAliveClient m ()
NodeToNodeVersion
-> ControlMessageSTM m
-> StrictTVar m (AnchoredFragment (Header blk))
-> ChainSyncClientPipelined
     (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult
NodeToNodeVersion
-> ControlMessageSTM m -> BlockFetchClient (Header blk) blk m ()
NodeToNodeVersion
-> ResourceRegistry m
-> ChainSyncServer
     (SerialisedHeader blk) (Point blk) (Tip blk) m ()
NodeToNodeVersion
-> ResourceRegistry m
-> BlockFetchServer (Serialised blk) (Point blk) m ()
hKeepAliveServer :: NodeToNodeVersion -> remotePeer -> KeepAliveServer m ()
hKeepAliveClient :: NodeToNodeVersion
-> ControlMessageSTM m
-> remotePeer
-> StrictTVar m (Map remotePeer PeerGSV)
-> KeepAliveInterval
-> KeepAliveClient m ()
hTxSubmissionServer :: NodeToNodeVersion
-> remotePeer
-> TxSubmissionServerPipelined (GenTxId blk) (GenTx blk) m ()
hTxSubmissionClient :: NodeToNodeVersion
-> ControlMessageSTM m
-> remotePeer
-> TxSubmissionClient (GenTxId blk) (GenTx blk) m ()
hBlockFetchServer :: NodeToNodeVersion
-> ResourceRegistry m
-> BlockFetchServer (Serialised blk) (Point blk) m ()
hBlockFetchClient :: NodeToNodeVersion
-> ControlMessageSTM m -> BlockFetchClient (Header blk) blk m ()
hChainSyncServer :: NodeToNodeVersion
-> ResourceRegistry m
-> ChainSyncServer
     (SerialisedHeader blk) (Point blk) (Tip blk) m ()
hChainSyncClient :: NodeToNodeVersion
-> ControlMessageSTM m
-> StrictTVar m (AnchoredFragment (Header blk))
-> ChainSyncClientPipelined
     (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult
hKeepAliveServer :: forall (m :: * -> *) peer blk.
Handlers m peer blk
-> NodeToNodeVersion -> peer -> KeepAliveServer m ()
hKeepAliveClient :: forall (m :: * -> *) peer blk.
Handlers m peer blk
-> NodeToNodeVersion
-> ControlMessageSTM m
-> peer
-> StrictTVar m (Map peer PeerGSV)
-> KeepAliveInterval
-> KeepAliveClient m ()
hTxSubmissionServer :: forall (m :: * -> *) peer blk.
Handlers m peer blk
-> NodeToNodeVersion
-> peer
-> TxSubmissionServerPipelined (GenTxId blk) (GenTx blk) m ()
hTxSubmissionClient :: forall (m :: * -> *) peer blk.
Handlers m peer blk
-> NodeToNodeVersion
-> ControlMessageSTM m
-> peer
-> TxSubmissionClient (GenTxId blk) (GenTx blk) m ()
hBlockFetchServer :: forall (m :: * -> *) peer blk.
Handlers m peer blk
-> NodeToNodeVersion
-> ResourceRegistry m
-> BlockFetchServer (Serialised blk) (Point blk) m ()
hBlockFetchClient :: forall (m :: * -> *) peer blk.
Handlers m peer blk
-> NodeToNodeVersion
-> ControlMessageSTM m
-> BlockFetchClient (Header blk) blk m ()
hChainSyncServer :: forall (m :: * -> *) peer blk.
Handlers m peer blk
-> NodeToNodeVersion
-> ResourceRegistry m
-> ChainSyncServer
     (SerialisedHeader blk) (Point blk) (Tip blk) m ()
hChainSyncClient :: forall (m :: * -> *) peer blk.
Handlers m peer blk
-> NodeToNodeVersion
-> ControlMessageSTM m
-> StrictTVar m (AnchoredFragment (Header blk))
-> ChainSyncClientPipelined
     (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult
..} =
    Apps :: forall (m :: * -> *) peer bCS bBF bTX bKA a.
ClientApp m peer bCS a
-> ServerApp m peer bCS a
-> ClientApp m peer bBF a
-> ServerApp m peer bBF a
-> ClientApp m peer bTX a
-> ServerApp m peer bTX a
-> ClientApp m peer bKA a
-> ServerApp m peer bKA a
-> Apps m peer bCS bBF bTX bKA a
Apps {NodeToNodeVersion
-> remotePeer -> Channel m bCS -> m ((), Maybe bCS)
NodeToNodeVersion
-> remotePeer -> Channel m bBF -> m ((), Maybe bBF)
NodeToNodeVersion
-> remotePeer -> Channel m bTX -> m ((), Maybe bTX)
NodeToNodeVersion
-> remotePeer -> Channel m bKA -> m ((), Maybe bKA)
NodeToNodeVersion
-> ControlMessageSTM m
-> remotePeer
-> Channel m bCS
-> m ((), Maybe bCS)
NodeToNodeVersion
-> ControlMessageSTM m
-> remotePeer
-> Channel m bBF
-> m ((), Maybe bBF)
NodeToNodeVersion
-> ControlMessageSTM m
-> remotePeer
-> Channel m bTX
-> m ((), Maybe bTX)
NodeToNodeVersion
-> ControlMessageSTM m
-> remotePeer
-> Channel m bKA
-> m ((), Maybe bKA)
aKeepAliveServer :: NodeToNodeVersion
-> remotePeer -> Channel m bKA -> m ((), Maybe bKA)
aKeepAliveClient :: NodeToNodeVersion
-> ControlMessageSTM m
-> remotePeer
-> Channel m bKA
-> m ((), Maybe bKA)
aTxSubmissionServer :: NodeToNodeVersion
-> remotePeer -> Channel m bTX -> m ((), Maybe bTX)
aTxSubmissionClient :: NodeToNodeVersion
-> ControlMessageSTM m
-> remotePeer
-> Channel m bTX
-> m ((), Maybe bTX)
aBlockFetchServer :: NodeToNodeVersion
-> remotePeer -> Channel m bBF -> m ((), Maybe bBF)
aBlockFetchClient :: NodeToNodeVersion
-> ControlMessageSTM m
-> remotePeer
-> Channel m bBF
-> m ((), Maybe bBF)
aChainSyncServer :: NodeToNodeVersion
-> remotePeer -> Channel m bCS -> m ((), Maybe bCS)
aChainSyncClient :: NodeToNodeVersion
-> ControlMessageSTM m
-> remotePeer
-> Channel m bCS
-> m ((), Maybe bCS)
aKeepAliveServer :: NodeToNodeVersion
-> remotePeer -> Channel m bKA -> m ((), Maybe bKA)
aKeepAliveClient :: NodeToNodeVersion
-> ControlMessageSTM m
-> remotePeer
-> Channel m bKA
-> m ((), Maybe bKA)
aTxSubmissionServer :: NodeToNodeVersion
-> remotePeer -> Channel m bTX -> m ((), Maybe bTX)
aTxSubmissionClient :: NodeToNodeVersion
-> ControlMessageSTM m
-> remotePeer
-> Channel m bTX
-> m ((), Maybe bTX)
aBlockFetchServer :: NodeToNodeVersion
-> remotePeer -> Channel m bBF -> m ((), Maybe bBF)
aBlockFetchClient :: NodeToNodeVersion
-> ControlMessageSTM m
-> remotePeer
-> Channel m bBF
-> m ((), Maybe bBF)
aChainSyncServer :: NodeToNodeVersion
-> remotePeer -> Channel m bCS -> m ((), Maybe bCS)
aChainSyncClient :: NodeToNodeVersion
-> ControlMessageSTM m
-> remotePeer
-> Channel m bCS
-> m ((), Maybe bCS)
..}
  where
    aChainSyncClient
      :: NodeToNodeVersion
      -> ControlMessageSTM m
      -> remotePeer
      -> Channel m bCS
      -> m ((), Maybe bCS)
    aChainSyncClient :: NodeToNodeVersion
-> ControlMessageSTM m
-> remotePeer
-> Channel m bCS
-> m ((), Maybe bCS)
aChainSyncClient NodeToNodeVersion
version ControlMessageSTM m
controlMessageSTM remotePeer
them Channel m bCS
channel = do
      String -> m ()
forall (m :: * -> *). MonadThread m => String -> m ()
labelThisThread String
"ChainSyncClient"
      -- Note that it is crucial that we sync with the fetch client "outside"
      -- of registering the state for the sync client. This is needed to
      -- maintain a state invariant required by the block fetch logic: that for
      -- each candidate chain there is a corresponding block fetch client that
      -- can be used to fetch blocks for that chain.
      FetchClientRegistry remotePeer (Header blk) blk m
-> remotePeer -> m ((), Maybe bCS) -> m ((), Maybe bCS)
forall (m :: * -> *) a peer header block.
(MonadThrow m, MonadSTM m, MonadFork m, Ord peer) =>
FetchClientRegistry peer header block m -> peer -> m a -> m a
bracketSyncWithFetchClient
        (NodeKernel m remotePeer localPeer blk
-> FetchClientRegistry remotePeer (Header blk) blk m
forall (m :: * -> *) remotePeer localPeer blk.
NodeKernel m remotePeer localPeer blk
-> FetchClientRegistry remotePeer (Header blk) blk m
getFetchClientRegistry NodeKernel m remotePeer localPeer blk
kernel) remotePeer
them (m ((), Maybe bCS) -> m ((), Maybe bCS))
-> m ((), Maybe bCS) -> m ((), Maybe bCS)
forall a b. (a -> b) -> a -> b
$
        Tracer m (TraceChainSyncClientEvent blk)
-> ChainDbView m blk
-> StrictTVar
     m (Map remotePeer (StrictTVar m (AnchoredFragment (Header blk))))
-> remotePeer
-> (StrictTVar m (AnchoredFragment (Header blk))
    -> m ((), Maybe bCS))
-> m ((), Maybe bCS)
forall (m :: * -> *) peer blk a.
(IOLike m, Ord peer, BlockSupportsProtocol blk,
 LedgerSupportsProtocol blk) =>
Tracer m (TraceChainSyncClientEvent blk)
-> ChainDbView m blk
-> StrictTVar
     m (Map peer (StrictTVar m (AnchoredFragment (Header blk))))
-> peer
-> (StrictTVar m (AnchoredFragment (Header blk)) -> m a)
-> m a
bracketChainSyncClient
            (Tracers' remotePeer localPeer blk (Tracer m)
-> Tracer m (TraceChainSyncClientEvent blk)
forall remotePeer localPeer blk (f :: * -> *).
Tracers' remotePeer localPeer blk f
-> f (TraceChainSyncClientEvent blk)
Node.chainSyncClientTracer (NodeKernel m remotePeer localPeer blk
-> Tracers' remotePeer localPeer blk (Tracer m)
forall (m :: * -> *) remotePeer localPeer blk.
NodeKernel m remotePeer localPeer blk
-> Tracers m remotePeer localPeer blk
getTracers NodeKernel m remotePeer localPeer blk
kernel))
            (ChainDB m blk -> ChainDbView m blk
forall (m :: * -> *) blk. ChainDB m blk -> ChainDbView m blk
defaultChainDbView (NodeKernel m remotePeer localPeer blk -> ChainDB m blk
forall (m :: * -> *) remotePeer localPeer blk.
NodeKernel m remotePeer localPeer blk -> ChainDB m blk
getChainDB NodeKernel m remotePeer localPeer blk
kernel))
            (NodeKernel m remotePeer localPeer blk
-> StrictTVar
     m (Map remotePeer (StrictTVar m (AnchoredFragment (Header blk))))
forall (m :: * -> *) remotePeer localPeer blk.
NodeKernel m remotePeer localPeer blk
-> StrictTVar
     m (Map remotePeer (StrictTVar m (AnchoredFragment (Header blk))))
getNodeCandidates NodeKernel m remotePeer localPeer blk
kernel)
            remotePeer
them ((StrictTVar m (AnchoredFragment (Header blk))
  -> m ((), Maybe bCS))
 -> m ((), Maybe bCS))
-> (StrictTVar m (AnchoredFragment (Header blk))
    -> m ((), Maybe bCS))
-> m ((), Maybe bCS)
forall a b. (a -> b) -> a -> b
$ \StrictTVar m (AnchoredFragment (Header blk))
varCandidate -> do
              ChainSyncTimeout
chainSyncTimeout <- m ChainSyncTimeout
genChainSyncTimeout
              (ChainSyncClientResult
_, Maybe bCS
trailing) <-
                Tracer
  m (TraceSendRecv (ChainSync (Header blk) (Point blk) (Tip blk)))
-> Codec (ChainSync (Header blk) (Point blk) (Tip blk)) e m bCS
-> ProtocolSizeLimits
     (ChainSync (Header blk) (Point blk) (Tip blk)) bCS
-> ProtocolTimeLimits
     (ChainSync (Header blk) (Point blk) (Tip blk))
-> Channel m bCS
-> PeerPipelined
     (ChainSync (Header blk) (Point blk) (Tip blk))
     'AsClient
     'StIdle
     m
     ChainSyncClientResult
-> m (ChainSyncClientResult, Maybe bCS)
forall ps (st :: ps) (pr :: PeerRole) failure bytes (m :: * -> *)
       a.
(MonadAsync m, MonadFork m, MonadMask m, MonadThrow (STM m),
 MonadMonotonicTime m, MonadTimer m,
 forall (st' :: ps). Show (ClientHasAgency st'),
 forall (st' :: ps). Show (ServerHasAgency st'), ShowProxy ps,
 Show failure) =>
Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> ProtocolSizeLimits ps bytes
-> ProtocolTimeLimits ps
-> Channel m bytes
-> PeerPipelined ps pr st m a
-> m (a, Maybe bytes)
runPipelinedPeerWithLimits
                  ((TraceSendRecv (ChainSync (Header blk) (Point blk) (Tip blk))
 -> TraceLabelPeer
      remotePeer
      (TraceSendRecv (ChainSync (Header blk) (Point blk) (Tip blk))))
-> Tracer
     m
     (TraceLabelPeer
        remotePeer
        (TraceSendRecv (ChainSync (Header blk) (Point blk) (Tip blk))))
-> Tracer
     m (TraceSendRecv (ChainSync (Header blk) (Point blk) (Tip blk)))
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap (remotePeer
-> TraceSendRecv (ChainSync (Header blk) (Point blk) (Tip blk))
-> TraceLabelPeer
     remotePeer
     (TraceSendRecv (ChainSync (Header blk) (Point blk) (Tip blk)))
forall peerid a. peerid -> a -> TraceLabelPeer peerid a
TraceLabelPeer remotePeer
them) Tracer
  m
  (TraceLabelPeer
     remotePeer
     (TraceSendRecv (ChainSync (Header blk) (Point blk) (Tip blk))))
tChainSyncTracer)
                  Codec (ChainSync (Header blk) (Point blk) (Tip blk)) e m bCS
cChainSyncCodec
                  ((bCS -> Word)
-> ProtocolSizeLimits
     (ChainSync (Header blk) (Point blk) (Tip blk)) bCS
forall k1 k2 k3 bytes (header :: k1) (point :: k2) (tip :: k3).
(bytes -> Word)
-> ProtocolSizeLimits (ChainSync header point tip) bytes
byteLimitsChainSync (Word -> bCS -> Word
forall a b. a -> b -> a
const Word
0)) -- TODO: Real Bytelimits, see #1727
                  (ChainSyncTimeout
-> ProtocolTimeLimits
     (ChainSync (Header blk) (Point blk) (Tip blk))
forall k1 k2 k3 (header :: k1) (point :: k2) (tip :: k3).
ChainSyncTimeout -> ProtocolTimeLimits (ChainSync header point tip)
timeLimitsChainSync ChainSyncTimeout
chainSyncTimeout)
                  Channel m bCS
channel
                  (PeerPipelined
   (ChainSync (Header blk) (Point blk) (Tip blk))
   'AsClient
   'StIdle
   m
   ChainSyncClientResult
 -> m (ChainSyncClientResult, Maybe bCS))
-> PeerPipelined
     (ChainSync (Header blk) (Point blk) (Tip blk))
     'AsClient
     'StIdle
     m
     ChainSyncClientResult
-> m (ChainSyncClientResult, Maybe bCS)
forall a b. (a -> b) -> a -> b
$ ChainSyncClientPipelined
  (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult
-> PeerPipelined
     (ChainSync (Header blk) (Point blk) (Tip blk))
     'AsClient
     'StIdle
     m
     ChainSyncClientResult
forall header point tip (m :: * -> *) a.
Monad m =>
ChainSyncClientPipelined header point tip m a
-> PeerPipelined (ChainSync header point tip) 'AsClient 'StIdle m a
chainSyncClientPeerPipelined
                  (ChainSyncClientPipelined
   (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult
 -> PeerPipelined
      (ChainSync (Header blk) (Point blk) (Tip blk))
      'AsClient
      'StIdle
      m
      ChainSyncClientResult)
-> ChainSyncClientPipelined
     (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult
-> PeerPipelined
     (ChainSync (Header blk) (Point blk) (Tip blk))
     'AsClient
     'StIdle
     m
     ChainSyncClientResult
forall a b. (a -> b) -> a -> b
$ NodeToNodeVersion
-> ControlMessageSTM m
-> StrictTVar m (AnchoredFragment (Header blk))
-> ChainSyncClientPipelined
     (Header blk) (Point blk) (Tip blk) m ChainSyncClientResult
hChainSyncClient NodeToNodeVersion
version ControlMessageSTM m
controlMessageSTM StrictTVar m (AnchoredFragment (Header blk))
varCandidate
              ((), Maybe bCS) -> m ((), Maybe bCS)
forall (m :: * -> *) a. Monad m => a -> m a
return ((), Maybe bCS
trailing)

    aChainSyncServer
      :: NodeToNodeVersion
      -> remotePeer
      -> Channel m bCS
      -> m ((), Maybe bCS)
    aChainSyncServer :: NodeToNodeVersion
-> remotePeer -> Channel m bCS -> m ((), Maybe bCS)
aChainSyncServer NodeToNodeVersion
version remotePeer
them Channel m bCS
channel = do
      String -> m ()
forall (m :: * -> *). MonadThread m => String -> m ()
labelThisThread String
"ChainSyncServer"
      (ResourceRegistry m -> m ((), Maybe bCS)) -> m ((), Maybe bCS)
forall (m :: * -> *) a.
(IOLike m, HasCallStack) =>
(ResourceRegistry m -> m a) -> m a
withRegistry ((ResourceRegistry m -> m ((), Maybe bCS)) -> m ((), Maybe bCS))
-> (ResourceRegistry m -> m ((), Maybe bCS)) -> m ((), Maybe bCS)
forall a b. (a -> b) -> a -> b
$ \ResourceRegistry m
registry -> do
        ChainSyncTimeout
chainSyncTimeout <- m ChainSyncTimeout
genChainSyncTimeout
        Tracer
  m
  (TraceSendRecv
     (ChainSync (SerialisedHeader blk) (Point blk) (Tip blk)))
-> Codec
     (ChainSync (SerialisedHeader blk) (Point blk) (Tip blk)) e m bCS
-> ProtocolSizeLimits
     (ChainSync (SerialisedHeader blk) (Point blk) (Tip blk)) bCS
-> ProtocolTimeLimits
     (ChainSync (SerialisedHeader blk) (Point blk) (Tip blk))
-> Channel m bCS
-> Peer
     (ChainSync (SerialisedHeader blk) (Point blk) (Tip blk))
     'AsServer
     'StIdle
     m
     ()
-> m ((), Maybe bCS)
forall ps (st :: ps) (pr :: PeerRole) failure bytes (m :: * -> *)
       a.
(MonadAsync m, MonadFork m, MonadMask m, MonadThrow (STM m),
 MonadMonotonicTime m, MonadTimer m,
 forall (st' :: ps). Show (ClientHasAgency st'),
 forall (st' :: ps). Show (ServerHasAgency st'), ShowProxy ps,
 Show failure) =>
Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> ProtocolSizeLimits ps bytes
-> ProtocolTimeLimits ps
-> Channel m bytes
-> Peer ps pr st m a
-> m (a, Maybe bytes)
runPeerWithLimits
          ((TraceSendRecv
   (ChainSync (SerialisedHeader blk) (Point blk) (Tip blk))
 -> TraceLabelPeer
      remotePeer
      (TraceSendRecv
         (ChainSync (SerialisedHeader blk) (Point blk) (Tip blk))))
-> Tracer
     m
     (TraceLabelPeer
        remotePeer
        (TraceSendRecv
           (ChainSync (SerialisedHeader blk) (Point blk) (Tip blk))))
-> Tracer
     m
     (TraceSendRecv
        (ChainSync (SerialisedHeader blk) (Point blk) (Tip blk)))
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap (remotePeer
-> TraceSendRecv
     (ChainSync (SerialisedHeader blk) (Point blk) (Tip blk))
-> TraceLabelPeer
     remotePeer
     (TraceSendRecv
        (ChainSync (SerialisedHeader blk) (Point blk) (Tip blk)))
forall peerid a. peerid -> a -> TraceLabelPeer peerid a
TraceLabelPeer remotePeer
them) Tracer
  m
  (TraceLabelPeer
     remotePeer
     (TraceSendRecv
        (ChainSync (SerialisedHeader blk) (Point blk) (Tip blk))))
tChainSyncSerialisedTracer)
          Codec
  (ChainSync (SerialisedHeader blk) (Point blk) (Tip blk)) e m bCS
cChainSyncCodecSerialised
          ((bCS -> Word)
-> ProtocolSizeLimits
     (ChainSync (SerialisedHeader blk) (Point blk) (Tip blk)) bCS
forall k1 k2 k3 bytes (header :: k1) (point :: k2) (tip :: k3).
(bytes -> Word)
-> ProtocolSizeLimits (ChainSync header point tip) bytes
byteLimitsChainSync (Word -> bCS -> Word
forall a b. a -> b -> a
const Word
0)) -- TODO: Real Bytelimits, see #1727
          (ChainSyncTimeout
-> ProtocolTimeLimits
     (ChainSync (SerialisedHeader blk) (Point blk) (Tip blk))
forall k1 k2 k3 (header :: k1) (point :: k2) (tip :: k3).
ChainSyncTimeout -> ProtocolTimeLimits (ChainSync header point tip)
timeLimitsChainSync ChainSyncTimeout
chainSyncTimeout)
          Channel m bCS
channel
          (Peer
   (ChainSync (SerialisedHeader blk) (Point blk) (Tip blk))
   'AsServer
   'StIdle
   m
   ()
 -> m ((), Maybe bCS))
-> Peer
     (ChainSync (SerialisedHeader blk) (Point blk) (Tip blk))
     'AsServer
     'StIdle
     m
     ()
-> m ((), Maybe bCS)
forall a b. (a -> b) -> a -> b
$ ChainSyncServer (SerialisedHeader blk) (Point blk) (Tip blk) m ()
-> Peer
     (ChainSync (SerialisedHeader blk) (Point blk) (Tip blk))
     'AsServer
     'StIdle
     m
     ()
forall header point tip (m :: * -> *) a.
Monad m =>
ChainSyncServer header point tip m a
-> Peer (ChainSync header point tip) 'AsServer 'StIdle m a
chainSyncServerPeer
          (ChainSyncServer (SerialisedHeader blk) (Point blk) (Tip blk) m ()
 -> Peer
      (ChainSync (SerialisedHeader blk) (Point blk) (Tip blk))
      'AsServer
      'StIdle
      m
      ())
-> ChainSyncServer
     (SerialisedHeader blk) (Point blk) (Tip blk) m ()
-> Peer
     (ChainSync (SerialisedHeader blk) (Point blk) (Tip blk))
     'AsServer
     'StIdle
     m
     ()
forall a b. (a -> b) -> a -> b
$ NodeToNodeVersion
-> ResourceRegistry m
-> ChainSyncServer
     (SerialisedHeader blk) (Point blk) (Tip blk) m ()
hChainSyncServer NodeToNodeVersion
version ResourceRegistry m
registry

    aBlockFetchClient
      :: NodeToNodeVersion
      -> ControlMessageSTM m
      -> remotePeer
      -> Channel m bBF
      -> m ((), Maybe bBF)
    aBlockFetchClient :: NodeToNodeVersion
-> ControlMessageSTM m
-> remotePeer
-> Channel m bBF
-> m ((), Maybe bBF)
aBlockFetchClient NodeToNodeVersion
version ControlMessageSTM m
controlMessageSTM remotePeer
them Channel m bBF
channel = do
      String -> m ()
forall (m :: * -> *). MonadThread m => String -> m ()
labelThisThread String
"BlockFetchClient"
      FetchClientRegistry remotePeer (Header blk) blk m
-> remotePeer
-> (FetchClientContext (Header blk) blk m -> m ((), Maybe bBF))
-> m ((), Maybe bBF)
forall (m :: * -> *) a peer header block.
(MonadThrow m, MonadSTM m, MonadFork m, Ord peer) =>
FetchClientRegistry peer header block m
-> peer -> (FetchClientContext header block m -> m a) -> m a
bracketFetchClient (NodeKernel m remotePeer localPeer blk
-> FetchClientRegistry remotePeer (Header blk) blk m
forall (m :: * -> *) remotePeer localPeer blk.
NodeKernel m remotePeer localPeer blk
-> FetchClientRegistry remotePeer (Header blk) blk m
getFetchClientRegistry NodeKernel m remotePeer localPeer blk
kernel) remotePeer
them ((FetchClientContext (Header blk) blk m -> m ((), Maybe bBF))
 -> m ((), Maybe bBF))
-> (FetchClientContext (Header blk) blk m -> m ((), Maybe bBF))
-> m ((), Maybe bBF)
forall a b. (a -> b) -> a -> b
$ \FetchClientContext (Header blk) blk m
clientCtx ->
        Tracer m (TraceSendRecv (BlockFetch blk (Point blk)))
-> Codec (BlockFetch blk (Point blk)) e m bBF
-> ProtocolSizeLimits (BlockFetch blk (Point blk)) bBF
-> ProtocolTimeLimits (BlockFetch blk (Point blk))
-> Channel m bBF
-> PeerPipelined
     (BlockFetch blk (Point blk)) 'AsClient 'BFIdle m ()
-> m ((), Maybe bBF)
forall ps (st :: ps) (pr :: PeerRole) failure bytes (m :: * -> *)
       a.
(MonadAsync m, MonadFork m, MonadMask m, MonadThrow (STM m),
 MonadMonotonicTime m, MonadTimer m,
 forall (st' :: ps). Show (ClientHasAgency st'),
 forall (st' :: ps). Show (ServerHasAgency st'), ShowProxy ps,
 Show failure) =>
Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> ProtocolSizeLimits ps bytes
-> ProtocolTimeLimits ps
-> Channel m bytes
-> PeerPipelined ps pr st m a
-> m (a, Maybe bytes)
runPipelinedPeerWithLimits
          ((TraceSendRecv (BlockFetch blk (Point blk))
 -> TraceLabelPeer
      remotePeer (TraceSendRecv (BlockFetch blk (Point blk))))
-> Tracer
     m
     (TraceLabelPeer
        remotePeer (TraceSendRecv (BlockFetch blk (Point blk))))
-> Tracer m (TraceSendRecv (BlockFetch blk (Point blk)))
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap (remotePeer
-> TraceSendRecv (BlockFetch blk (Point blk))
-> TraceLabelPeer
     remotePeer (TraceSendRecv (BlockFetch blk (Point blk)))
forall peerid a. peerid -> a -> TraceLabelPeer peerid a
TraceLabelPeer remotePeer
them) Tracer
  m
  (TraceLabelPeer
     remotePeer (TraceSendRecv (BlockFetch blk (Point blk))))
tBlockFetchTracer)
          Codec (BlockFetch blk (Point blk)) e m bBF
cBlockFetchCodec
          ((bBF -> Word)
-> ProtocolSizeLimits (BlockFetch blk (Point blk)) bBF
forall k1 k2 bytes (block :: k1) (point :: k2).
(bytes -> Word)
-> ProtocolSizeLimits (BlockFetch block point) bytes
byteLimitsBlockFetch (Word -> bBF -> Word
forall a b. a -> b -> a
const Word
0)) -- TODO: Real Bytelimits, see #1727
          ProtocolTimeLimits (BlockFetch blk (Point blk))
forall k1 k2 (block :: k1) (point :: k2).
ProtocolTimeLimits (BlockFetch block point)
timeLimitsBlockFetch
          Channel m bBF
channel
          (PeerPipelined (BlockFetch blk (Point blk)) 'AsClient 'BFIdle m ()
 -> m ((), Maybe bBF))
-> PeerPipelined
     (BlockFetch blk (Point blk)) 'AsClient 'BFIdle m ()
-> m ((), Maybe bBF)
forall a b. (a -> b) -> a -> b
$ NodeToNodeVersion
-> ControlMessageSTM m -> BlockFetchClient (Header blk) blk m ()
hBlockFetchClient NodeToNodeVersion
version ControlMessageSTM m
controlMessageSTM FetchClientContext (Header blk) blk m
clientCtx

    aBlockFetchServer
      :: NodeToNodeVersion
      -> remotePeer
      -> Channel m bBF
      -> m ((), Maybe bBF)
    aBlockFetchServer :: NodeToNodeVersion
-> remotePeer -> Channel m bBF -> m ((), Maybe bBF)
aBlockFetchServer NodeToNodeVersion
version remotePeer
them Channel m bBF
channel = do
      String -> m ()
forall (m :: * -> *). MonadThread m => String -> m ()
labelThisThread String
"BlockFetchServer"
      (ResourceRegistry m -> m ((), Maybe bBF)) -> m ((), Maybe bBF)
forall (m :: * -> *) a.
(IOLike m, HasCallStack) =>
(ResourceRegistry m -> m a) -> m a
withRegistry ((ResourceRegistry m -> m ((), Maybe bBF)) -> m ((), Maybe bBF))
-> (ResourceRegistry m -> m ((), Maybe bBF)) -> m ((), Maybe bBF)
forall a b. (a -> b) -> a -> b
$ \ResourceRegistry m
registry ->
        Tracer m (TraceSendRecv (BlockFetch (Serialised blk) (Point blk)))
-> Codec (BlockFetch (Serialised blk) (Point blk)) e m bBF
-> ProtocolSizeLimits (BlockFetch (Serialised blk) (Point blk)) bBF
-> ProtocolTimeLimits (BlockFetch (Serialised blk) (Point blk))
-> Channel m bBF
-> Peer
     (BlockFetch (Serialised blk) (Point blk)) 'AsServer 'BFIdle m ()
-> m ((), Maybe bBF)
forall ps (st :: ps) (pr :: PeerRole) failure bytes (m :: * -> *)
       a.
(MonadAsync m, MonadFork m, MonadMask m, MonadThrow (STM m),
 MonadMonotonicTime m, MonadTimer m,
 forall (st' :: ps). Show (ClientHasAgency st'),
 forall (st' :: ps). Show (ServerHasAgency st'), ShowProxy ps,
 Show failure) =>
Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> ProtocolSizeLimits ps bytes
-> ProtocolTimeLimits ps
-> Channel m bytes
-> Peer ps pr st m a
-> m (a, Maybe bytes)
runPeerWithLimits
          ((TraceSendRecv (BlockFetch (Serialised blk) (Point blk))
 -> TraceLabelPeer
      remotePeer
      (TraceSendRecv (BlockFetch (Serialised blk) (Point blk))))
-> Tracer
     m
     (TraceLabelPeer
        remotePeer
        (TraceSendRecv (BlockFetch (Serialised blk) (Point blk))))
-> Tracer
     m (TraceSendRecv (BlockFetch (Serialised blk) (Point blk)))
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap (remotePeer
-> TraceSendRecv (BlockFetch (Serialised blk) (Point blk))
-> TraceLabelPeer
     remotePeer
     (TraceSendRecv (BlockFetch (Serialised blk) (Point blk)))
forall peerid a. peerid -> a -> TraceLabelPeer peerid a
TraceLabelPeer remotePeer
them) Tracer
  m
  (TraceLabelPeer
     remotePeer
     (TraceSendRecv (BlockFetch (Serialised blk) (Point blk))))
tBlockFetchSerialisedTracer)
          Codec (BlockFetch (Serialised blk) (Point blk)) e m bBF
cBlockFetchCodecSerialised
          ((bBF -> Word)
-> ProtocolSizeLimits (BlockFetch (Serialised blk) (Point blk)) bBF
forall k1 k2 bytes (block :: k1) (point :: k2).
(bytes -> Word)
-> ProtocolSizeLimits (BlockFetch block point) bytes
byteLimitsBlockFetch (Word -> bBF -> Word
forall a b. a -> b -> a
const Word
0)) -- TODO: Real Bytelimits, see #1727
          ProtocolTimeLimits (BlockFetch (Serialised blk) (Point blk))
forall k1 k2 (block :: k1) (point :: k2).
ProtocolTimeLimits (BlockFetch block point)
timeLimitsBlockFetch
          Channel m bBF
channel
          (Peer
   (BlockFetch (Serialised blk) (Point blk)) 'AsServer 'BFIdle m ()
 -> m ((), Maybe bBF))
-> Peer
     (BlockFetch (Serialised blk) (Point blk)) 'AsServer 'BFIdle m ()
-> m ((), Maybe bBF)
forall a b. (a -> b) -> a -> b
$ BlockFetchServer (Serialised blk) (Point blk) m ()
-> Peer
     (BlockFetch (Serialised blk) (Point blk)) 'AsServer 'BFIdle m ()
forall block point (m :: * -> *) a.
Functor m =>
BlockFetchServer block point m a
-> Peer (BlockFetch block point) 'AsServer 'BFIdle m a
blockFetchServerPeer
          (BlockFetchServer (Serialised blk) (Point blk) m ()
 -> Peer
      (BlockFetch (Serialised blk) (Point blk)) 'AsServer 'BFIdle m ())
-> BlockFetchServer (Serialised blk) (Point blk) m ()
-> Peer
     (BlockFetch (Serialised blk) (Point blk)) 'AsServer 'BFIdle m ()
forall a b. (a -> b) -> a -> b
$ NodeToNodeVersion
-> ResourceRegistry m
-> BlockFetchServer (Serialised blk) (Point blk) m ()
hBlockFetchServer NodeToNodeVersion
version ResourceRegistry m
registry

    aTxSubmissionClient
      :: NodeToNodeVersion
      -> ControlMessageSTM m
      -> remotePeer
      -> Channel m bTX
      -> m ((), Maybe bTX)
    aTxSubmissionClient :: NodeToNodeVersion
-> ControlMessageSTM m
-> remotePeer
-> Channel m bTX
-> m ((), Maybe bTX)
aTxSubmissionClient NodeToNodeVersion
version ControlMessageSTM m
controlMessageSTM remotePeer
them Channel m bTX
channel = do
      String -> m ()
forall (m :: * -> *). MonadThread m => String -> m ()
labelThisThread String
"TxSubmissionClient"
      Tracer m (TraceSendRecv (TxSubmission (GenTxId blk) (GenTx blk)))
-> Codec (TxSubmission (GenTxId blk) (GenTx blk)) e m bTX
-> ProtocolSizeLimits (TxSubmission (GenTxId blk) (GenTx blk)) bTX
-> ProtocolTimeLimits (TxSubmission (GenTxId blk) (GenTx blk))
-> Channel m bTX
-> Peer
     (TxSubmission (GenTxId blk) (GenTx blk)) 'AsClient 'StIdle m ()
-> m ((), Maybe bTX)
forall ps (st :: ps) (pr :: PeerRole) failure bytes (m :: * -> *)
       a.
(MonadAsync m, MonadFork m, MonadMask m, MonadThrow (STM m),
 MonadMonotonicTime m, MonadTimer m,
 forall (st' :: ps). Show (ClientHasAgency st'),
 forall (st' :: ps). Show (ServerHasAgency st'), ShowProxy ps,
 Show failure) =>
Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> ProtocolSizeLimits ps bytes
-> ProtocolTimeLimits ps
-> Channel m bytes
-> Peer ps pr st m a
-> m (a, Maybe bytes)
runPeerWithLimits
        ((TraceSendRecv (TxSubmission (GenTxId blk) (GenTx blk))
 -> TraceLabelPeer
      remotePeer
      (TraceSendRecv (TxSubmission (GenTxId blk) (GenTx blk))))
-> Tracer
     m
     (TraceLabelPeer
        remotePeer
        (TraceSendRecv (TxSubmission (GenTxId blk) (GenTx blk))))
-> Tracer
     m (TraceSendRecv (TxSubmission (GenTxId blk) (GenTx blk)))
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap (remotePeer
-> TraceSendRecv (TxSubmission (GenTxId blk) (GenTx blk))
-> TraceLabelPeer
     remotePeer (TraceSendRecv (TxSubmission (GenTxId blk) (GenTx blk)))
forall peerid a. peerid -> a -> TraceLabelPeer peerid a
TraceLabelPeer remotePeer
them) Tracer
  m
  (TraceLabelPeer
     remotePeer
     (TraceSendRecv (TxSubmission (GenTxId blk) (GenTx blk))))
tTxSubmissionTracer)
        Codec (TxSubmission (GenTxId blk) (GenTx blk)) e m bTX
cTxSubmissionCodec
        ((bTX -> Word)
-> ProtocolSizeLimits (TxSubmission (GenTxId blk) (GenTx blk)) bTX
forall k1 k2 bytes (txid :: k1) (tx :: k2).
(bytes -> Word) -> ProtocolSizeLimits (TxSubmission txid tx) bytes
byteLimitsTxSubmission (Word -> bTX -> Word
forall a b. a -> b -> a
const Word
0)) -- TODO: Real Bytelimits, see #1727
        ProtocolTimeLimits (TxSubmission (GenTxId blk) (GenTx blk))
forall k1 k2 (txid :: k1) (tx :: k2).
ProtocolTimeLimits (TxSubmission txid tx)
timeLimitsTxSubmission
        Channel m bTX
channel
        (TxSubmissionClient (GenTxId blk) (GenTx blk) m ()
-> Peer
     (TxSubmission (GenTxId blk) (GenTx blk)) 'AsClient 'StIdle m ()
forall txid tx (m :: * -> *) a.
Monad m =>
TxSubmissionClient txid tx m a
-> Peer (TxSubmission txid tx) 'AsClient 'StIdle m a
txSubmissionClientPeer (NodeToNodeVersion
-> ControlMessageSTM m
-> remotePeer
-> TxSubmissionClient (GenTxId blk) (GenTx blk) m ()
hTxSubmissionClient NodeToNodeVersion
version ControlMessageSTM m
controlMessageSTM remotePeer
them))

    aTxSubmissionServer
      :: NodeToNodeVersion
      -> remotePeer
      -> Channel m bTX
      -> m ((), Maybe bTX)
    aTxSubmissionServer :: NodeToNodeVersion
-> remotePeer -> Channel m bTX -> m ((), Maybe bTX)
aTxSubmissionServer NodeToNodeVersion
version remotePeer
them Channel m bTX
channel = do
      String -> m ()
forall (m :: * -> *). MonadThread m => String -> m ()
labelThisThread String
"TxSubmissionServer"
      Tracer m (TraceSendRecv (TxSubmission (GenTxId blk) (GenTx blk)))
-> Codec (TxSubmission (GenTxId blk) (GenTx blk)) e m bTX
-> ProtocolSizeLimits (TxSubmission (GenTxId blk) (GenTx blk)) bTX
-> ProtocolTimeLimits (TxSubmission (GenTxId blk) (GenTx blk))
-> Channel m bTX
-> PeerPipelined
     (TxSubmission (GenTxId blk) (GenTx blk)) 'AsServer 'StIdle m ()
-> m ((), Maybe bTX)
forall ps (st :: ps) (pr :: PeerRole) failure bytes (m :: * -> *)
       a.
(MonadAsync m, MonadFork m, MonadMask m, MonadThrow (STM m),
 MonadMonotonicTime m, MonadTimer m,
 forall (st' :: ps). Show (ClientHasAgency st'),
 forall (st' :: ps). Show (ServerHasAgency st'), ShowProxy ps,
 Show failure) =>
Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> ProtocolSizeLimits ps bytes
-> ProtocolTimeLimits ps
-> Channel m bytes
-> PeerPipelined ps pr st m a
-> m (a, Maybe bytes)
runPipelinedPeerWithLimits
        ((TraceSendRecv (TxSubmission (GenTxId blk) (GenTx blk))
 -> TraceLabelPeer
      remotePeer
      (TraceSendRecv (TxSubmission (GenTxId blk) (GenTx blk))))
-> Tracer
     m
     (TraceLabelPeer
        remotePeer
        (TraceSendRecv (TxSubmission (GenTxId blk) (GenTx blk))))
-> Tracer
     m (TraceSendRecv (TxSubmission (GenTxId blk) (GenTx blk)))
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap (remotePeer
-> TraceSendRecv (TxSubmission (GenTxId blk) (GenTx blk))
-> TraceLabelPeer
     remotePeer (TraceSendRecv (TxSubmission (GenTxId blk) (GenTx blk)))
forall peerid a. peerid -> a -> TraceLabelPeer peerid a
TraceLabelPeer remotePeer
them) Tracer
  m
  (TraceLabelPeer
     remotePeer
     (TraceSendRecv (TxSubmission (GenTxId blk) (GenTx blk))))
tTxSubmissionTracer)
        Codec (TxSubmission (GenTxId blk) (GenTx blk)) e m bTX
cTxSubmissionCodec
        ((bTX -> Word)
-> ProtocolSizeLimits (TxSubmission (GenTxId blk) (GenTx blk)) bTX
forall k1 k2 bytes (txid :: k1) (tx :: k2).
(bytes -> Word) -> ProtocolSizeLimits (TxSubmission txid tx) bytes
byteLimitsTxSubmission (Word -> bTX -> Word
forall a b. a -> b -> a
const Word
0)) -- TODO: Real Bytelimits, see #1727
        ProtocolTimeLimits (TxSubmission (GenTxId blk) (GenTx blk))
forall k1 k2 (txid :: k1) (tx :: k2).
ProtocolTimeLimits (TxSubmission txid tx)
timeLimitsTxSubmission
        Channel m bTX
channel
        (TxSubmissionServerPipelined (GenTxId blk) (GenTx blk) m ()
-> PeerPipelined
     (TxSubmission (GenTxId blk) (GenTx blk)) 'AsServer 'StIdle m ()
forall txid tx (m :: * -> *) a.
Functor m =>
TxSubmissionServerPipelined txid tx m a
-> PeerPipelined (TxSubmission txid tx) 'AsServer 'StIdle m a
txSubmissionServerPeerPipelined (NodeToNodeVersion
-> remotePeer
-> TxSubmissionServerPipelined (GenTxId blk) (GenTx blk) m ()
hTxSubmissionServer NodeToNodeVersion
version remotePeer
them))

    aKeepAliveClient
      :: NodeToNodeVersion
      -> ControlMessageSTM m
      -> remotePeer
      -> Channel m bKA
      -> m ((), Maybe bKA)
    aKeepAliveClient :: NodeToNodeVersion
-> ControlMessageSTM m
-> remotePeer
-> Channel m bKA
-> m ((), Maybe bKA)
aKeepAliveClient NodeToNodeVersion
version ControlMessageSTM m
_controlMessageSTM remotePeer
them Channel m bKA
channel = do
      String -> m ()
forall (m :: * -> *). MonadThread m => String -> m ()
labelThisThread String
"KeepAliveClient"
      let kacApp :: StrictTVar m (Map remotePeer PeerGSV) -> m ((), Maybe bKA)
kacApp = case NodeToNodeVersion
version of
                     -- Version 1 doesn't support keep alive protocol but Blockfetch
                     -- still requires a PeerGSV per peer.
                     NodeToNodeVersion
NodeToNodeV_1 -> \StrictTVar m (Map remotePeer PeerGSV)
_ -> m () -> m Any
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (DiffTime -> m ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
1000) m Any -> m ((), Maybe bKA) -> m ((), Maybe bKA)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ((), Maybe bKA) -> m ((), Maybe bKA)
forall (m :: * -> *) a. Monad m => a -> m a
return ((), Maybe bKA
forall a. Maybe a
Nothing)
                     NodeToNodeVersion
NodeToNodeV_2 -> \StrictTVar m (Map remotePeer PeerGSV)
_ -> m () -> m Any
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (DiffTime -> m ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
1000) m Any -> m ((), Maybe bKA) -> m ((), Maybe bKA)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ((), Maybe bKA) -> m ((), Maybe bKA)
forall (m :: * -> *) a. Monad m => a -> m a
return ((), Maybe bKA
forall a. Maybe a
Nothing)
                     NodeToNodeVersion
_             -> \StrictTVar m (Map remotePeer PeerGSV)
dqCtx -> do
                       Tracer m (TraceSendRecv KeepAlive)
-> Codec KeepAlive e m bKA
-> ProtocolSizeLimits KeepAlive bKA
-> ProtocolTimeLimits KeepAlive
-> Channel m bKA
-> Peer KeepAlive 'AsClient 'StClient m ()
-> m ((), Maybe bKA)
forall ps (st :: ps) (pr :: PeerRole) failure bytes (m :: * -> *)
       a.
(MonadAsync m, MonadFork m, MonadMask m, MonadThrow (STM m),
 MonadMonotonicTime m, MonadTimer m,
 forall (st' :: ps). Show (ClientHasAgency st'),
 forall (st' :: ps). Show (ServerHasAgency st'), ShowProxy ps,
 Show failure) =>
Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> ProtocolSizeLimits ps bytes
-> ProtocolTimeLimits ps
-> Channel m bytes
-> Peer ps pr st m a
-> m (a, Maybe bytes)
runPeerWithLimits
                         Tracer m (TraceSendRecv KeepAlive)
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
                         Codec KeepAlive e m bKA
cKeepAliveCodec
                         ((bKA -> Word) -> ProtocolSizeLimits KeepAlive bKA
forall bytes. (bytes -> Word) -> ProtocolSizeLimits KeepAlive bytes
byteLimitsKeepAlive (Word -> bKA -> Word
forall a b. a -> b -> a
const Word
0)) -- TODO: Real Bytelimits, see #1727
                         ProtocolTimeLimits KeepAlive
timeLimitsKeepAlive
                         Channel m bKA
channel
                         (Peer KeepAlive 'AsClient 'StClient m () -> m ((), Maybe bKA))
-> Peer KeepAlive 'AsClient 'StClient m () -> m ((), Maybe bKA)
forall a b. (a -> b) -> a -> b
$ KeepAliveClient m () -> Peer KeepAlive 'AsClient 'StClient m ()
forall (m :: * -> *) a.
MonadThrow m =>
KeepAliveClient m a -> Peer KeepAlive 'AsClient 'StClient m a
keepAliveClientPeer
                         (KeepAliveClient m () -> Peer KeepAlive 'AsClient 'StClient m ())
-> KeepAliveClient m () -> Peer KeepAlive 'AsClient 'StClient m ()
forall a b. (a -> b) -> a -> b
$ NodeToNodeVersion
-> ControlMessageSTM m
-> remotePeer
-> StrictTVar m (Map remotePeer PeerGSV)
-> KeepAliveInterval
-> KeepAliveClient m ()
hKeepAliveClient NodeToNodeVersion
version (Proxy m -> ControlMessageSTM m
forall (m :: * -> *) (proxy :: (* -> *) -> *).
Applicative (STM m) =>
proxy m -> ControlMessageSTM m
continueForever (Proxy m
forall k (t :: k). Proxy t
Proxy :: Proxy m)) remotePeer
them StrictTVar m (Map remotePeer PeerGSV)
dqCtx
                             (DiffTime -> KeepAliveInterval
KeepAliveInterval DiffTime
10)

      FetchClientRegistry remotePeer (Header blk) blk m
-> remotePeer
-> (StrictTVar m (Map remotePeer PeerGSV) -> m ((), Maybe bKA))
-> m ((), Maybe bKA)
forall (m :: * -> *) a peer header block.
(MonadThrow m, MonadSTM m, MonadFork m, Ord peer) =>
FetchClientRegistry peer header block m
-> peer -> (StrictTVar m (Map peer PeerGSV) -> m a) -> m a
bracketKeepAliveClient (NodeKernel m remotePeer localPeer blk
-> FetchClientRegistry remotePeer (Header blk) blk m
forall (m :: * -> *) remotePeer localPeer blk.
NodeKernel m remotePeer localPeer blk
-> FetchClientRegistry remotePeer (Header blk) blk m
getFetchClientRegistry NodeKernel m remotePeer localPeer blk
kernel) remotePeer
them StrictTVar m (Map remotePeer PeerGSV) -> m ((), Maybe bKA)
kacApp

    aKeepAliveServer
      :: NodeToNodeVersion
      -> remotePeer
      -> Channel m bKA
      -> m ((), Maybe bKA)
    aKeepAliveServer :: NodeToNodeVersion
-> remotePeer -> Channel m bKA -> m ((), Maybe bKA)
aKeepAliveServer NodeToNodeVersion
_version remotePeer
_them Channel m bKA
channel = do
      String -> m ()
forall (m :: * -> *). MonadThread m => String -> m ()
labelThisThread String
"KeepAliveServer"
      Tracer m (TraceSendRecv KeepAlive)
-> Codec KeepAlive e m bKA
-> ProtocolSizeLimits KeepAlive bKA
-> ProtocolTimeLimits KeepAlive
-> Channel m bKA
-> Peer KeepAlive 'AsServer 'StClient m ()
-> m ((), Maybe bKA)
forall ps (st :: ps) (pr :: PeerRole) failure bytes (m :: * -> *)
       a.
(MonadAsync m, MonadFork m, MonadMask m, MonadThrow (STM m),
 MonadMonotonicTime m, MonadTimer m,
 forall (st' :: ps). Show (ClientHasAgency st'),
 forall (st' :: ps). Show (ServerHasAgency st'), ShowProxy ps,
 Show failure) =>
Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> ProtocolSizeLimits ps bytes
-> ProtocolTimeLimits ps
-> Channel m bytes
-> Peer ps pr st m a
-> m (a, Maybe bytes)
runPeerWithLimits
        Tracer m (TraceSendRecv KeepAlive)
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
        Codec KeepAlive e m bKA
cKeepAliveCodec
        ((bKA -> Word) -> ProtocolSizeLimits KeepAlive bKA
forall bytes. (bytes -> Word) -> ProtocolSizeLimits KeepAlive bytes
byteLimitsKeepAlive (Word -> bKA -> Word
forall a b. a -> b -> a
const Word
0)) -- TODO: Real Bytelimits, see #1727
        ProtocolTimeLimits KeepAlive
timeLimitsKeepAlive
        Channel m bKA
channel
        (Peer KeepAlive 'AsServer 'StClient m () -> m ((), Maybe bKA))
-> Peer KeepAlive 'AsServer 'StClient m () -> m ((), Maybe bKA)
forall a b. (a -> b) -> a -> b
$ KeepAliveServer m () -> Peer KeepAlive 'AsServer 'StClient m ()
forall (m :: * -> *) a.
Functor m =>
KeepAliveServer m a -> Peer KeepAlive 'AsServer 'StClient m a
keepAliveServerPeer
        (KeepAliveServer m () -> Peer KeepAlive 'AsServer 'StClient m ())
-> KeepAliveServer m () -> Peer KeepAlive 'AsServer 'StClient m ()
forall a b. (a -> b) -> a -> b
$ KeepAliveServer m ()
forall (m :: * -> *). Applicative m => KeepAliveServer m ()
keepAliveServer

{-------------------------------------------------------------------------------
  Projections from 'Apps'
-------------------------------------------------------------------------------}

-- | A projection from 'NetworkApplication' to a client-side
-- 'OuroborosApplication' for the node-to-node protocols.
--
-- Implementation note: network currently doesn't enable protocols conditional
-- on the protocol version, but it eventually may; this is why @_version@ is
-- currently unused.
initiator
  :: MiniProtocolParameters
  -> NodeToNodeVersion
  -> Apps m (ConnectionId peer) b b b b a
  -> OuroborosApplication 'InitiatorMode peer b m a Void
initiator :: MiniProtocolParameters
-> NodeToNodeVersion
-> Apps m (ConnectionId peer) b b b b a
-> OuroborosApplication 'InitiatorMode peer b m a Void
initiator MiniProtocolParameters
miniProtocolParameters NodeToNodeVersion
version Apps {ClientApp m (ConnectionId peer) b a
ServerApp m (ConnectionId peer) b a
aKeepAliveServer :: ServerApp m (ConnectionId peer) b a
aKeepAliveClient :: ClientApp m (ConnectionId peer) b a
aTxSubmissionServer :: ServerApp m (ConnectionId peer) b a
aTxSubmissionClient :: ClientApp m (ConnectionId peer) b a
aBlockFetchServer :: ServerApp m (ConnectionId peer) b a
aBlockFetchClient :: ClientApp m (ConnectionId peer) b a
aChainSyncServer :: ServerApp m (ConnectionId peer) b a
aChainSyncClient :: ClientApp m (ConnectionId peer) b a
aKeepAliveServer :: forall (m :: * -> *) peer bCS bBF bTX bKA a.
Apps m peer bCS bBF bTX bKA a -> ServerApp m peer bKA a
aKeepAliveClient :: forall (m :: * -> *) peer bCS bBF bTX bKA a.
Apps m peer bCS bBF bTX bKA a -> ClientApp m peer bKA a
aTxSubmissionServer :: forall (m :: * -> *) peer bCS bBF bTX bKA a.
Apps m peer bCS bBF bTX bKA a -> ServerApp m peer bTX a
aTxSubmissionClient :: forall (m :: * -> *) peer bCS bBF bTX bKA a.
Apps m peer bCS bBF bTX bKA a -> ClientApp m peer bTX a
aBlockFetchServer :: forall (m :: * -> *) peer bCS bBF bTX bKA a.
Apps m peer bCS bBF bTX bKA a -> ServerApp m peer bBF a
aBlockFetchClient :: forall (m :: * -> *) peer bCS bBF bTX bKA a.
Apps m peer bCS bBF bTX bKA a -> ClientApp m peer bBF a
aChainSyncServer :: forall (m :: * -> *) peer bCS bBF bTX bKA a.
Apps m peer bCS bBF bTX bKA a -> ServerApp m peer bCS a
aChainSyncClient :: forall (m :: * -> *) peer bCS bBF bTX bKA a.
Apps m peer bCS bBF bTX bKA a -> ClientApp m peer bCS a
..} =
    MiniProtocolParameters
-> (ConnectionId peer
    -> STM m ControlMessage
    -> NodeToNodeProtocols 'InitiatorMode b m a Void)
-> NodeToNodeVersion
-> OuroborosApplication 'InitiatorMode peer b m a Void
forall addr (m :: * -> *) (appType :: MuxMode) bytes a b.
MiniProtocolParameters
-> (ConnectionId addr
    -> STM m ControlMessage -> NodeToNodeProtocols appType bytes m a b)
-> NodeToNodeVersion
-> OuroborosApplication appType addr bytes m a b
nodeToNodeProtocols
      MiniProtocolParameters
miniProtocolParameters
      -- TODO: currently consensus is using 'ConnectionId' for its 'peer' type.
      -- This is currently ok, as we might accept multiple connections from the
      -- same ip address, however this will change when we will switch to
      -- p2p-governor & connection-manager.  Then consenus can use peer's ip
      -- address & port number, rather than 'ConnectionId' (which is
      -- a quadruple uniquely determinaing a connection).
      (\ConnectionId peer
them STM m ControlMessage
controlMessageSTM -> NodeToNodeProtocols :: forall (appType :: MuxMode) bytes (m :: * -> *) a b.
RunMiniProtocol appType bytes m a b
-> RunMiniProtocol appType bytes m a b
-> RunMiniProtocol appType bytes m a b
-> RunMiniProtocol appType bytes m a b
-> NodeToNodeProtocols appType bytes m a b
NodeToNodeProtocols {
          chainSyncProtocol :: RunMiniProtocol 'InitiatorMode b m a Void
chainSyncProtocol =
            (MuxPeer b m a -> RunMiniProtocol 'InitiatorMode b m a Void
forall bytes (m :: * -> *) a.
MuxPeer bytes m a -> RunMiniProtocol 'InitiatorMode bytes m a Void
InitiatorProtocolOnly ((Channel m b -> m (a, Maybe b)) -> MuxPeer b m a
forall (m :: * -> *) bytes a.
(Channel m bytes -> m (a, Maybe bytes)) -> MuxPeer bytes m a
MuxPeerRaw (ClientApp m (ConnectionId peer) b a
aChainSyncClient NodeToNodeVersion
version STM m ControlMessage
controlMessageSTM ConnectionId peer
them))),
          blockFetchProtocol :: RunMiniProtocol 'InitiatorMode b m a Void
blockFetchProtocol =
            (MuxPeer b m a -> RunMiniProtocol 'InitiatorMode b m a Void
forall bytes (m :: * -> *) a.
MuxPeer bytes m a -> RunMiniProtocol 'InitiatorMode bytes m a Void
InitiatorProtocolOnly ((Channel m b -> m (a, Maybe b)) -> MuxPeer b m a
forall (m :: * -> *) bytes a.
(Channel m bytes -> m (a, Maybe bytes)) -> MuxPeer bytes m a
MuxPeerRaw (ClientApp m (ConnectionId peer) b a
aBlockFetchClient NodeToNodeVersion
version STM m ControlMessage
controlMessageSTM ConnectionId peer
them))),
          txSubmissionProtocol :: RunMiniProtocol 'InitiatorMode b m a Void
txSubmissionProtocol =
            (MuxPeer b m a -> RunMiniProtocol 'InitiatorMode b m a Void
forall bytes (m :: * -> *) a.
MuxPeer bytes m a -> RunMiniProtocol 'InitiatorMode bytes m a Void
InitiatorProtocolOnly ((Channel m b -> m (a, Maybe b)) -> MuxPeer b m a
forall (m :: * -> *) bytes a.
(Channel m bytes -> m (a, Maybe bytes)) -> MuxPeer bytes m a
MuxPeerRaw (ClientApp m (ConnectionId peer) b a
aTxSubmissionClient NodeToNodeVersion
version STM m ControlMessage
controlMessageSTM ConnectionId peer
them))),
          keepAliveProtocol :: RunMiniProtocol 'InitiatorMode b m a Void
keepAliveProtocol =
            (MuxPeer b m a -> RunMiniProtocol 'InitiatorMode b m a Void
forall bytes (m :: * -> *) a.
MuxPeer bytes m a -> RunMiniProtocol 'InitiatorMode bytes m a Void
InitiatorProtocolOnly ((Channel m b -> m (a, Maybe b)) -> MuxPeer b m a
forall (m :: * -> *) bytes a.
(Channel m bytes -> m (a, Maybe bytes)) -> MuxPeer bytes m a
MuxPeerRaw (ClientApp m (ConnectionId peer) b a
aKeepAliveClient NodeToNodeVersion
version STM m ControlMessage
controlMessageSTM ConnectionId peer
them)))
        })
      NodeToNodeVersion
version

-- | A projection from 'NetworkApplication' to a server-side
-- 'OuroborosApplication' for the node-to-node protocols.
--
-- See 'initiatorNetworkApplication' for rationale for the @_version@ arg.
responder
  :: MiniProtocolParameters
  -> NodeToNodeVersion
  -> Apps m (ConnectionId peer) b b b b a
  -> OuroborosApplication 'ResponderMode peer b m Void a
responder :: MiniProtocolParameters
-> NodeToNodeVersion
-> Apps m (ConnectionId peer) b b b b a
-> OuroborosApplication 'ResponderMode peer b m Void a
responder MiniProtocolParameters
miniProtocolParameters NodeToNodeVersion
version Apps {ClientApp m (ConnectionId peer) b a
ServerApp m (ConnectionId peer) b a
aKeepAliveServer :: ServerApp m (ConnectionId peer) b a
aKeepAliveClient :: ClientApp m (ConnectionId peer) b a
aTxSubmissionServer :: ServerApp m (ConnectionId peer) b a
aTxSubmissionClient :: ClientApp m (ConnectionId peer) b a
aBlockFetchServer :: ServerApp m (ConnectionId peer) b a
aBlockFetchClient :: ClientApp m (ConnectionId peer) b a
aChainSyncServer :: ServerApp m (ConnectionId peer) b a
aChainSyncClient :: ClientApp m (ConnectionId peer) b a
aKeepAliveServer :: forall (m :: * -> *) peer bCS bBF bTX bKA a.
Apps m peer bCS bBF bTX bKA a -> ServerApp m peer bKA a
aKeepAliveClient :: forall (m :: * -> *) peer bCS bBF bTX bKA a.
Apps m peer bCS bBF bTX bKA a -> ClientApp m peer bKA a
aTxSubmissionServer :: forall (m :: * -> *) peer bCS bBF bTX bKA a.
Apps m peer bCS bBF bTX bKA a -> ServerApp m peer bTX a
aTxSubmissionClient :: forall (m :: * -> *) peer bCS bBF bTX bKA a.
Apps m peer bCS bBF bTX bKA a -> ClientApp m peer bTX a
aBlockFetchServer :: forall (m :: * -> *) peer bCS bBF bTX bKA a.
Apps m peer bCS bBF bTX bKA a -> ServerApp m peer bBF a
aBlockFetchClient :: forall (m :: * -> *) peer bCS bBF bTX bKA a.
Apps m peer bCS bBF bTX bKA a -> ClientApp m peer bBF a
aChainSyncServer :: forall (m :: * -> *) peer bCS bBF bTX bKA a.
Apps m peer bCS bBF bTX bKA a -> ServerApp m peer bCS a
aChainSyncClient :: forall (m :: * -> *) peer bCS bBF bTX bKA a.
Apps m peer bCS bBF bTX bKA a -> ClientApp m peer bCS a
..} =
    MiniProtocolParameters
-> (ConnectionId peer
    -> STM m ControlMessage
    -> NodeToNodeProtocols 'ResponderMode b m Void a)
-> NodeToNodeVersion
-> OuroborosApplication 'ResponderMode peer b m Void a
forall addr (m :: * -> *) (appType :: MuxMode) bytes a b.
MiniProtocolParameters
-> (ConnectionId addr
    -> STM m ControlMessage -> NodeToNodeProtocols appType bytes m a b)
-> NodeToNodeVersion
-> OuroborosApplication appType addr bytes m a b
nodeToNodeProtocols
      MiniProtocolParameters
miniProtocolParameters
      (\ConnectionId peer
them STM m ControlMessage
_controlMessageSTM -> NodeToNodeProtocols :: forall (appType :: MuxMode) bytes (m :: * -> *) a b.
RunMiniProtocol appType bytes m a b
-> RunMiniProtocol appType bytes m a b
-> RunMiniProtocol appType bytes m a b
-> RunMiniProtocol appType bytes m a b
-> NodeToNodeProtocols appType bytes m a b
NodeToNodeProtocols {
          chainSyncProtocol :: RunMiniProtocol 'ResponderMode b m Void a
chainSyncProtocol =
            (MuxPeer b m a -> RunMiniProtocol 'ResponderMode b m Void a
forall bytes (m :: * -> *) b.
MuxPeer bytes m b -> RunMiniProtocol 'ResponderMode bytes m Void b
ResponderProtocolOnly ((Channel m b -> m (a, Maybe b)) -> MuxPeer b m a
forall (m :: * -> *) bytes a.
(Channel m bytes -> m (a, Maybe bytes)) -> MuxPeer bytes m a
MuxPeerRaw (ServerApp m (ConnectionId peer) b a
aChainSyncServer NodeToNodeVersion
version ConnectionId peer
them))),
          blockFetchProtocol :: RunMiniProtocol 'ResponderMode b m Void a
blockFetchProtocol =
            (MuxPeer b m a -> RunMiniProtocol 'ResponderMode b m Void a
forall bytes (m :: * -> *) b.
MuxPeer bytes m b -> RunMiniProtocol 'ResponderMode bytes m Void b
ResponderProtocolOnly ((Channel m b -> m (a, Maybe b)) -> MuxPeer b m a
forall (m :: * -> *) bytes a.
(Channel m bytes -> m (a, Maybe bytes)) -> MuxPeer bytes m a
MuxPeerRaw (ServerApp m (ConnectionId peer) b a
aBlockFetchServer NodeToNodeVersion
version ConnectionId peer
them))),
          txSubmissionProtocol :: RunMiniProtocol 'ResponderMode b m Void a
txSubmissionProtocol =
            (MuxPeer b m a -> RunMiniProtocol 'ResponderMode b m Void a
forall bytes (m :: * -> *) b.
MuxPeer bytes m b -> RunMiniProtocol 'ResponderMode bytes m Void b
ResponderProtocolOnly ((Channel m b -> m (a, Maybe b)) -> MuxPeer b m a
forall (m :: * -> *) bytes a.
(Channel m bytes -> m (a, Maybe bytes)) -> MuxPeer bytes m a
MuxPeerRaw (ServerApp m (ConnectionId peer) b a
aTxSubmissionServer NodeToNodeVersion
version ConnectionId peer
them))),
          keepAliveProtocol :: RunMiniProtocol 'ResponderMode b m Void a
keepAliveProtocol =
            (MuxPeer b m a -> RunMiniProtocol 'ResponderMode b m Void a
forall bytes (m :: * -> *) b.
MuxPeer bytes m b -> RunMiniProtocol 'ResponderMode bytes m Void b
ResponderProtocolOnly ((Channel m b -> m (a, Maybe b)) -> MuxPeer b m a
forall (m :: * -> *) bytes a.
(Channel m bytes -> m (a, Maybe bytes)) -> MuxPeer bytes m a
MuxPeerRaw (ServerApp m (ConnectionId peer) b a
aKeepAliveServer NodeToNodeVersion
version ConnectionId peer
them)))
        })
      NodeToNodeVersion
version