{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | Intended for qualified import
module Ouroboros.Consensus.Network.NodeToClient (
    -- * Handlers
    Handlers (..)
  , mkHandlers
    -- * Codecs
  , ClientCodecs
  , Codecs
  , Codecs' (..)
  , DefaultCodecs
  , clientCodecs
  , defaultCodecs
  , identityCodecs
    -- * ClientCodecs
    -- * Tracers
  , Tracers
  , Tracers' (..)
  , nullTracers
  , showTracers
    -- * Applications
  , App
  , Apps (..)
  , mkApps
    -- ** Projections
  , responder
  ) where

import           Codec.CBOR.Decoding (Decoder)
import           Codec.CBOR.Encoding (Encoding)
import           Codec.CBOR.Read (DeserialiseFailure)
import           Codec.Serialise (Serialise)
import           Control.ResourceRegistry
import           Control.Tracer
import           Data.ByteString.Lazy (ByteString)
import           Data.Void (Void)
import           Network.TypedProtocol.Codec
import qualified Network.TypedProtocol.Stateful.Codec as Stateful
import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.Ledger.Extended
import           Ouroboros.Consensus.Ledger.Query
import           Ouroboros.Consensus.Ledger.SupportsMempool
import           Ouroboros.Consensus.Ledger.SupportsProtocol
import           Ouroboros.Consensus.MiniProtocol.ChainSync.Server
import           Ouroboros.Consensus.MiniProtocol.LocalStateQuery.Server
import           Ouroboros.Consensus.MiniProtocol.LocalTxMonitor.Server
import           Ouroboros.Consensus.MiniProtocol.LocalTxSubmission.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 qualified Ouroboros.Consensus.Storage.ChainDB.API as ChainDB
import           Ouroboros.Consensus.Util (ShowProxy)
import           Ouroboros.Consensus.Util.IOLike
import           Ouroboros.Consensus.Util.Orphans ()
import qualified Ouroboros.Network.AnchoredFragment as AF
import           Ouroboros.Network.Block (Serialised, decodePoint, decodeTip,
                     encodePoint, encodeTip)
import           Ouroboros.Network.BlockFetch
import           Ouroboros.Network.Channel
import           Ouroboros.Network.Context
import           Ouroboros.Network.Driver
import qualified Ouroboros.Network.Driver.Stateful as Stateful
import           Ouroboros.Network.Mux
import           Ouroboros.Network.NodeToClient hiding
                     (NodeToClientVersion (..))
import qualified Ouroboros.Network.NodeToClient as N (NodeToClientVersion (..))
import           Ouroboros.Network.Protocol.ChainSync.Codec
import           Ouroboros.Network.Protocol.ChainSync.Server
import           Ouroboros.Network.Protocol.ChainSync.Type
import           Ouroboros.Network.Protocol.LocalStateQuery.Codec
import           Ouroboros.Network.Protocol.LocalStateQuery.Server
import           Ouroboros.Network.Protocol.LocalStateQuery.Type as LocalStateQuery
import           Ouroboros.Network.Protocol.LocalTxMonitor.Codec
import           Ouroboros.Network.Protocol.LocalTxMonitor.Server
import           Ouroboros.Network.Protocol.LocalTxMonitor.Type
import           Ouroboros.Network.Protocol.LocalTxSubmission.Codec
import           Ouroboros.Network.Protocol.LocalTxSubmission.Server
import           Ouroboros.Network.Protocol.LocalTxSubmission.Type

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

-- | Protocol handlers for node-to-client (local) communication
data Handlers m peer blk = Handlers {
      forall {k} (m :: * -> *) (peer :: k) blk.
Handlers m peer blk
-> Follower m blk (WithPoint blk (Serialised blk))
-> ChainSyncServer (Serialised blk) (Point blk) (Tip blk) m ()
hChainSyncServer
        :: ChainDB.Follower m blk (ChainDB.WithPoint blk (Serialised blk))
        -> ChainSyncServer (Serialised blk) (Point blk) (Tip blk) m ()

    , forall {k} (m :: * -> *) (peer :: k) blk.
Handlers m peer blk
-> LocalTxSubmissionServer (GenTx blk) (ApplyTxErr blk) m ()
hTxSubmissionServer
        :: LocalTxSubmissionServer (GenTx blk) (ApplyTxErr blk) m ()

    , forall {k} (m :: * -> *) (peer :: k) blk.
Handlers m peer blk
-> LocalStateQueryServer blk (Point blk) (Query blk) m ()
hStateQueryServer
        :: LocalStateQueryServer blk (Point blk) (Query blk) m ()

    , forall {k} (m :: * -> *) (peer :: k) blk.
Handlers m peer blk
-> LocalTxMonitorServer (GenTxId blk) (GenTx blk) SlotNo m ()
hTxMonitorServer
        :: LocalTxMonitorServer (GenTxId blk) (GenTx blk) SlotNo m ()
    }

mkHandlers ::
     forall m blk addrNTN addrNTC.
     ( IOLike m
     , LedgerSupportsMempool blk
     , LedgerSupportsProtocol blk
     , BlockSupportsLedgerQuery blk
     , ConfigSupportsNode blk
     )
  => NodeKernelArgs m addrNTN addrNTC blk
  -> NodeKernel     m addrNTN addrNTC blk
  -> Handlers       m         addrNTC blk
mkHandlers :: forall (m :: * -> *) blk addrNTN addrNTC.
(IOLike m, LedgerSupportsMempool blk, LedgerSupportsProtocol blk,
 BlockSupportsLedgerQuery blk, ConfigSupportsNode blk) =>
NodeKernelArgs m addrNTN addrNTC blk
-> NodeKernel m addrNTN addrNTC blk -> Handlers m addrNTC blk
mkHandlers NodeKernelArgs {TopLevelConfig blk
cfg :: TopLevelConfig blk
$sel:cfg:NodeKernelArgs :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk -> TopLevelConfig blk
cfg, Tracers m (ConnectionId addrNTN) addrNTC blk
tracers :: Tracers m (ConnectionId addrNTN) addrNTC blk
$sel:tracers:NodeKernelArgs :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernelArgs m addrNTN addrNTC blk
-> Tracers m (ConnectionId addrNTN) addrNTC blk
tracers} NodeKernel {ChainDB m blk
getChainDB :: ChainDB m blk
$sel:getChainDB:NodeKernel :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernel m addrNTN addrNTC blk -> ChainDB m blk
getChainDB, Mempool m blk
getMempool :: Mempool m blk
$sel:getMempool:NodeKernel :: forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernel m addrNTN addrNTC blk -> Mempool m blk
getMempool} =
    Handlers {
        hChainSyncServer :: Follower m blk (WithPoint blk (Serialised blk))
-> ChainSyncServer (Serialised blk) (Point blk) (Tip blk) m ()
hChainSyncServer =
          Tracer m (TraceChainSyncServerEvent blk)
-> ChainDB m blk
-> Follower m blk (WithPoint blk (Serialised blk))
-> ChainSyncServer (Serialised blk) (Point blk) (Tip blk) m ()
forall (m :: * -> *) blk.
(IOLike m, HasHeader (Header blk)) =>
Tracer m (TraceChainSyncServerEvent blk)
-> ChainDB m blk
-> Follower m blk (WithPoint blk (Serialised blk))
-> ChainSyncServer (Serialised blk) (Point blk) (Tip blk) m ()
chainSyncBlocksServer
            (Tracers m (ConnectionId addrNTN) addrNTC blk
-> Tracer m (TraceChainSyncServerEvent blk)
forall remotePeer localPeer blk (f :: * -> *).
Tracers' remotePeer localPeer blk f
-> f (TraceChainSyncServerEvent blk)
Node.chainSyncServerBlockTracer Tracers m (ConnectionId addrNTN) addrNTC blk
tracers)
            ChainDB m blk
getChainDB
      , hTxSubmissionServer :: LocalTxSubmissionServer (GenTx blk) (ApplyTxErr blk) m ()
hTxSubmissionServer =
          Tracer m (TraceLocalTxSubmissionServerEvent blk)
-> Mempool m blk
-> LocalTxSubmissionServer (GenTx blk) (ApplyTxErr blk) m ()
forall (m :: * -> *) blk.
MonadSTM m =>
Tracer m (TraceLocalTxSubmissionServerEvent blk)
-> Mempool m blk
-> LocalTxSubmissionServer (GenTx blk) (ApplyTxErr blk) m ()
localTxSubmissionServer
            (Tracers m (ConnectionId addrNTN) addrNTC blk
-> Tracer m (TraceLocalTxSubmissionServerEvent blk)
forall remotePeer localPeer blk (f :: * -> *).
Tracers' remotePeer localPeer blk f
-> f (TraceLocalTxSubmissionServerEvent blk)
Node.localTxSubmissionServerTracer Tracers m (ConnectionId addrNTN) addrNTC blk
tracers)
            Mempool m blk
getMempool
      , hStateQueryServer :: LocalStateQueryServer blk (Point blk) (Query blk) m ()
hStateQueryServer =
          ExtLedgerCfg blk
-> STM m (Point blk)
-> (Point blk -> STM m (Maybe (ExtLedgerState blk)))
-> STM m (Point blk)
-> LocalStateQueryServer blk (Point blk) (Query blk) m ()
forall (m :: * -> *) blk.
(IOLike m, BlockSupportsLedgerQuery blk, ConfigSupportsNode blk,
 HasAnnTip blk) =>
ExtLedgerCfg blk
-> STM m (Point blk)
-> (Point blk -> STM m (Maybe (ExtLedgerState blk)))
-> STM m (Point blk)
-> LocalStateQueryServer blk (Point blk) (Query blk) m ()
localStateQueryServer
            (TopLevelConfig blk -> ExtLedgerCfg blk
forall blk. TopLevelConfig blk -> ExtLedgerCfg blk
ExtLedgerCfg TopLevelConfig blk
cfg)
            (ChainDB m blk -> STM m (Point blk)
forall (m :: * -> *) blk. ChainDB m blk -> STM m (Point blk)
ChainDB.getTipPoint ChainDB m blk
getChainDB)
            (ChainDB m blk -> Point blk -> STM m (Maybe (ExtLedgerState blk))
forall (m :: * -> *) blk.
(Monad (STM m), LedgerSupportsProtocol blk) =>
ChainDB m blk -> Point blk -> STM m (Maybe (ExtLedgerState blk))
ChainDB.getPastLedger ChainDB m blk
getChainDB)
            (Point (Header blk) -> Point blk
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (Point (Header blk) -> Point blk)
-> (AnchoredFragment (Header blk) -> Point (Header blk))
-> AnchoredFragment (Header blk)
-> Point blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnchoredFragment (Header blk) -> Point (Header blk)
forall block. AnchoredFragment block -> Point block
AF.anchorPoint (AnchoredFragment (Header blk) -> Point blk)
-> STM m (AnchoredFragment (Header blk)) -> STM m (Point blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChainDB m blk -> STM m (AnchoredFragment (Header blk))
forall (m :: * -> *) blk.
ChainDB m blk -> STM m (AnchoredFragment (Header blk))
ChainDB.getCurrentChain ChainDB m blk
getChainDB)

      , hTxMonitorServer :: LocalTxMonitorServer (GenTxId blk) (GenTx blk) SlotNo m ()
hTxMonitorServer =
          Mempool m blk
-> LocalTxMonitorServer (GenTxId blk) (GenTx blk) SlotNo m ()
forall blk (m :: * -> *).
(MonadSTM m, LedgerSupportsMempool blk) =>
Mempool m blk
-> LocalTxMonitorServer (GenTxId blk) (GenTx blk) SlotNo m ()
localTxMonitorServer
            Mempool m blk
getMempool
      }

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

-- | Node-to-client protocol codecs needed to run 'Handlers'.
data Codecs' blk serialisedBlk e m bCS bTX bSQ bTM = Codecs {
      forall {k} blk (serialisedBlk :: k) e (m :: * -> *) bCS bTX bSQ
       bTM.
Codecs' blk serialisedBlk e m bCS bTX bSQ bTM
-> Codec (ChainSync serialisedBlk (Point blk) (Tip blk)) e m bCS
cChainSyncCodec    :: Codec (ChainSync serialisedBlk (Point blk) (Tip blk))   e m bCS
    , forall {k} blk (serialisedBlk :: k) e (m :: * -> *) bCS bTX bSQ
       bTM.
Codecs' blk serialisedBlk e m bCS bTX bSQ bTM
-> Codec (LocalTxSubmission (GenTx blk) (ApplyTxErr blk)) e m bTX
cTxSubmissionCodec :: Codec (LocalTxSubmission (GenTx blk) (ApplyTxErr blk))  e m bTX
    , forall {k} blk (serialisedBlk :: k) e (m :: * -> *) bCS bTX bSQ
       bTM.
Codecs' blk serialisedBlk e m bCS bTX bSQ bTM
-> Codec
     (LocalStateQuery blk (Point blk) (Query blk)) e State m bSQ
cStateQueryCodec   :: Stateful.Codec (LocalStateQuery blk (Point blk) (Query blk)) e LocalStateQuery.State m bSQ
    , forall {k} blk (serialisedBlk :: k) e (m :: * -> *) bCS bTX bSQ
       bTM.
Codecs' blk serialisedBlk e m bCS bTX bSQ bTM
-> Codec (LocalTxMonitor (GenTxId blk) (GenTx blk) SlotNo) e m bTM
cTxMonitorCodec    :: Codec (LocalTxMonitor (GenTxId blk) (GenTx blk) SlotNo) e m bTM
    }

type Codecs blk e m bCS bTX bSQ bTM =
    Codecs' blk (Serialised blk) e m bCS bTX bSQ bTM
type DefaultCodecs blk m =
    Codecs' blk (Serialised blk) DeserialiseFailure m ByteString ByteString ByteString ByteString
type ClientCodecs blk  m =
    Codecs' blk blk DeserialiseFailure m ByteString ByteString ByteString ByteString

-- | Protocol codecs for the node-to-client protocols
--
-- We pass the 'BlockConfig' here, even though it is currently unused. If at any
-- point we want to introduce local protocols that for example send Byron blocks
-- or headers across, we will need to have the epoch size, which comes from the
-- Byron config. Unlike the full 'TopLevelConfig', it should not be difficult
-- for a wallet to construct the 'BlockConfig'.
--
-- NOTE: Somewhat confusingly, 'pcChainSyncCodec' currently /does/ send Byron
-- blocks across, but it does not deserialize them (the user of the codec is
-- itself responsible for doing that), which is why it currently does not need
-- the config.
--
-- Implementation mode: currently none of the consensus encoders/decoders do
-- anything different based on the version, so @_version@ is unused; it's just
-- that not all codecs are used, depending on the version number.
defaultCodecs :: forall m blk.
                 ( MonadST m
                 , SerialiseNodeToClientConstraints blk
                 , ShowQuery (BlockQuery blk)
                 , StandardHash blk
                 , Serialise (HeaderHash blk)
                 )
              => CodecConfig blk
              -> BlockNodeToClientVersion blk
              -> N.NodeToClientVersion
              -> DefaultCodecs blk m
defaultCodecs :: forall (m :: * -> *) blk.
(MonadST m, SerialiseNodeToClientConstraints blk,
 ShowQuery (BlockQuery blk), StandardHash blk,
 Serialise (HeaderHash blk)) =>
CodecConfig blk
-> BlockNodeToClientVersion blk
-> NodeToClientVersion
-> DefaultCodecs blk m
defaultCodecs CodecConfig blk
ccfg BlockNodeToClientVersion blk
version NodeToClientVersion
networkVersion = Codecs {
      cChainSyncCodec :: Codec
  (ChainSync (Serialised blk) (Point blk) (Tip blk))
  DeserialiseFailure
  m
  ByteString
cChainSyncCodec =
        (Serialised blk -> Encoding)
-> (forall s. Decoder s (Serialised blk))
-> (Point blk -> Encoding)
-> (forall s. Decoder s (Point blk))
-> (Tip blk -> Encoding)
-> (forall s. Decoder s (Tip blk))
-> Codec
     (ChainSync (Serialised 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
          Serialised blk -> Encoding
forall a. SerialiseNodeToClient blk a => a -> Encoding
enc
          Decoder s (Serialised blk)
forall s. Decoder s (Serialised blk)
forall a s. SerialiseNodeToClient blk a => Decoder s a
dec
          ((HeaderHash blk -> Encoding) -> Point blk -> Encoding
forall {k} (block :: k).
(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 {k} (block :: k).
(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 {k} (blk :: k).
(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 {k} (blk :: k).
(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))

    , cTxSubmissionCodec :: Codec
  (LocalTxSubmission (GenTx blk) (ApplyTxErr blk))
  DeserialiseFailure
  m
  ByteString
cTxSubmissionCodec =
        (GenTx blk -> Encoding)
-> (forall s. Decoder s (GenTx blk))
-> (ApplyTxErr blk -> Encoding)
-> (forall s. Decoder s (ApplyTxErr blk))
-> Codec
     (LocalTxSubmission (GenTx blk) (ApplyTxErr blk))
     DeserialiseFailure
     m
     ByteString
forall tx reject (m :: * -> *).
MonadST m =>
(tx -> Encoding)
-> (forall s. Decoder s tx)
-> (reject -> Encoding)
-> (forall s. Decoder s reject)
-> Codec
     (LocalTxSubmission tx reject) DeserialiseFailure m ByteString
codecLocalTxSubmission
          GenTx blk -> Encoding
forall a. SerialiseNodeToClient blk a => a -> Encoding
enc
          Decoder s (GenTx blk)
forall s. Decoder s (GenTx blk)
forall a s. SerialiseNodeToClient blk a => Decoder s a
dec
          ApplyTxErr blk -> Encoding
forall a. SerialiseNodeToClient blk a => a -> Encoding
enc
          Decoder s (ApplyTxErr blk)
forall s. Decoder s (ApplyTxErr blk)
forall a s. SerialiseNodeToClient blk a => Decoder s a
dec

    , cStateQueryCodec :: Codec
  (LocalStateQuery blk (Point blk) (Query blk))
  DeserialiseFailure
  State
  m
  ByteString
cStateQueryCodec =
        NodeToClientVersion
-> (Point blk -> Encoding)
-> (forall s. Decoder s (Point blk))
-> (forall result. Query blk result -> Encoding)
-> (forall s. Decoder s (Some (Query blk)))
-> (forall result. Query blk result -> result -> Encoding)
-> (forall result. Query blk result -> forall s. Decoder s result)
-> Codec
     (LocalStateQuery blk (Point blk) (Query blk))
     DeserialiseFailure
     State
     m
     ByteString
forall block point (query :: * -> *) (m :: * -> *).
(MonadST m, ShowQuery query) =>
NodeToClientVersion
-> (point -> Encoding)
-> (forall s. Decoder s point)
-> (forall result. query result -> Encoding)
-> (forall s. Decoder s (Some query))
-> (forall result. query result -> result -> Encoding)
-> (forall result. query result -> forall s. Decoder s result)
-> Codec
     (LocalStateQuery block point query)
     DeserialiseFailure
     State
     m
     ByteString
codecLocalStateQuery
          NodeToClientVersion
networkVersion
          ((HeaderHash blk -> Encoding) -> Point blk -> Encoding
forall {k} (block :: k).
(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 {k} (block :: k).
(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))
          (CodecConfig blk
-> QueryVersion
-> BlockNodeToClientVersion blk
-> SomeSecond Query blk
-> Encoding
forall blk.
(Typeable blk, Show (SomeSecond BlockQuery blk),
 SerialiseNodeToClient blk (SomeSecond BlockQuery blk)) =>
CodecConfig blk
-> QueryVersion
-> BlockNodeToClientVersion blk
-> SomeSecond Query blk
-> Encoding
queryEncodeNodeToClient CodecConfig blk
ccfg QueryVersion
queryVersion BlockNodeToClientVersion blk
version (SomeSecond Query blk -> Encoding)
-> (Query blk result -> SomeSecond Query blk)
-> Query blk result
-> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Query blk result -> SomeSecond Query blk
forall {k1} {k2} (f :: k1 -> k2 -> *) (a :: k1) (b :: k2).
f a b -> SomeSecond f a
SomeSecond)
          ((\(SomeSecond Query blk b
qry) -> Query blk b -> Some (Query blk)
forall {k} (f :: k -> *) (a :: k). f a -> Some f
Some Query blk b
qry) (SomeSecond Query blk -> Some (Query blk))
-> Decoder s (SomeSecond Query blk) -> Decoder s (Some (Query blk))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CodecConfig blk
-> QueryVersion
-> BlockNodeToClientVersion blk
-> forall s. Decoder s (SomeSecond Query blk)
forall blk.
SerialiseNodeToClient blk (SomeSecond BlockQuery blk) =>
CodecConfig blk
-> QueryVersion
-> BlockNodeToClientVersion blk
-> forall s. Decoder s (SomeSecond Query blk)
queryDecodeNodeToClient CodecConfig blk
ccfg QueryVersion
queryVersion BlockNodeToClientVersion blk
version)
          (CodecConfig blk
-> BlockNodeToClientVersion blk
-> Query blk result
-> result
-> Encoding
forall result.
CodecConfig blk
-> BlockNodeToClientVersion blk
-> Query blk result
-> result
-> Encoding
forall blk (query :: * -> *) result.
SerialiseResult blk query =>
CodecConfig blk
-> BlockNodeToClientVersion blk
-> query result
-> result
-> Encoding
encodeResult CodecConfig blk
ccfg BlockNodeToClientVersion blk
version)
          (CodecConfig blk
-> BlockNodeToClientVersion blk
-> Query blk result
-> forall s. Decoder s result
forall result.
CodecConfig blk
-> BlockNodeToClientVersion blk
-> Query blk result
-> forall s. Decoder s result
forall blk (query :: * -> *) result.
SerialiseResult blk query =>
CodecConfig blk
-> BlockNodeToClientVersion blk
-> query result
-> forall s. Decoder s result
decodeResult CodecConfig blk
ccfg BlockNodeToClientVersion blk
version)

    , cTxMonitorCodec :: Codec
  (LocalTxMonitor (GenTxId blk) (GenTx blk) SlotNo)
  DeserialiseFailure
  m
  ByteString
cTxMonitorCodec =
        (GenTxId blk -> Encoding)
-> (forall s. Decoder s (GenTxId blk))
-> (GenTx blk -> Encoding)
-> (forall s. Decoder s (GenTx blk))
-> (SlotNo -> Encoding)
-> (forall s. Decoder s SlotNo)
-> Codec
     (LocalTxMonitor (GenTxId blk) (GenTx blk) SlotNo)
     DeserialiseFailure
     m
     ByteString
forall txid tx slot (m :: * -> *) ptcl.
(MonadST m, ptcl ~ LocalTxMonitor txid tx slot) =>
(txid -> Encoding)
-> (forall s. Decoder s txid)
-> (tx -> Encoding)
-> (forall s. Decoder s tx)
-> (slot -> Encoding)
-> (forall s. Decoder s slot)
-> Codec
     (LocalTxMonitor txid tx slot) DeserialiseFailure m ByteString
codecLocalTxMonitor
          GenTxId blk -> Encoding
forall a. SerialiseNodeToClient blk a => a -> Encoding
enc Decoder s (GenTxId blk)
forall s. Decoder s (GenTxId blk)
forall a s. SerialiseNodeToClient blk a => Decoder s a
dec
          GenTx blk -> Encoding
forall a. SerialiseNodeToClient blk a => a -> Encoding
enc Decoder s (GenTx blk)
forall s. Decoder s (GenTx blk)
forall a s. SerialiseNodeToClient blk a => Decoder s a
dec
          SlotNo -> Encoding
forall a. SerialiseNodeToClient blk a => a -> Encoding
enc Decoder s SlotNo
forall s. Decoder s SlotNo
forall a s. SerialiseNodeToClient blk a => Decoder s a
dec
    }
  where
    queryVersion :: QueryVersion
    queryVersion :: QueryVersion
queryVersion = NodeToClientVersion -> QueryVersion
nodeToClientVersionToQueryVersion NodeToClientVersion
networkVersion

    p :: Proxy blk
    p :: Proxy blk
p = Proxy blk
forall {k} (t :: k). Proxy t
Proxy

    enc :: SerialiseNodeToClient blk a => a -> Encoding
    enc :: forall a. SerialiseNodeToClient blk a => a -> Encoding
enc = CodecConfig blk -> BlockNodeToClientVersion blk -> a -> Encoding
forall blk a.
SerialiseNodeToClient blk a =>
CodecConfig blk -> BlockNodeToClientVersion blk -> a -> Encoding
encodeNodeToClient CodecConfig blk
ccfg BlockNodeToClientVersion blk
version

    dec :: SerialiseNodeToClient blk a => forall s. Decoder s a
    dec :: forall a s. SerialiseNodeToClient blk a => Decoder s a
dec = CodecConfig blk
-> BlockNodeToClientVersion blk -> forall s. Decoder s a
forall blk a.
SerialiseNodeToClient blk a =>
CodecConfig blk
-> BlockNodeToClientVersion blk -> forall s. Decoder s a
decodeNodeToClient CodecConfig blk
ccfg BlockNodeToClientVersion blk
version

-- | Protocol codecs for the node-to-client protocols which serialise
-- / deserialise blocks in /chain-sync/ protocol.
--
clientCodecs :: forall m blk.
                ( MonadST m
                , SerialiseNodeToClientConstraints blk
                , ShowQuery (BlockQuery blk)
                , StandardHash blk
                , Serialise (HeaderHash blk)
                )
             => CodecConfig blk
             -> BlockNodeToClientVersion blk
             -> N.NodeToClientVersion
             -> ClientCodecs blk m
clientCodecs :: forall (m :: * -> *) blk.
(MonadST m, SerialiseNodeToClientConstraints blk,
 ShowQuery (BlockQuery blk), StandardHash blk,
 Serialise (HeaderHash blk)) =>
CodecConfig blk
-> BlockNodeToClientVersion blk
-> NodeToClientVersion
-> ClientCodecs blk m
clientCodecs CodecConfig blk
ccfg BlockNodeToClientVersion blk
version NodeToClientVersion
networkVersion = Codecs {
      cChainSyncCodec :: Codec
  (ChainSync blk (Point blk) (Tip blk))
  DeserialiseFailure
  m
  ByteString
cChainSyncCodec =
        (blk -> Encoding)
-> (forall s. Decoder s blk)
-> (Point blk -> Encoding)
-> (forall s. Decoder s (Point blk))
-> (Tip blk -> Encoding)
-> (forall s. Decoder s (Tip blk))
-> Codec
     (ChainSync 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
          blk -> Encoding
forall a. SerialiseNodeToClient blk a => a -> Encoding
enc
          Decoder s blk
forall s. Decoder s blk
forall a s. SerialiseNodeToClient blk a => Decoder s a
dec
          ((HeaderHash blk -> Encoding) -> Point blk -> Encoding
forall {k} (block :: k).
(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 {k} (block :: k).
(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 {k} (blk :: k).
(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 {k} (blk :: k).
(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))

    , cTxSubmissionCodec :: Codec
  (LocalTxSubmission (GenTx blk) (ApplyTxErr blk))
  DeserialiseFailure
  m
  ByteString
cTxSubmissionCodec =
        (GenTx blk -> Encoding)
-> (forall s. Decoder s (GenTx blk))
-> (ApplyTxErr blk -> Encoding)
-> (forall s. Decoder s (ApplyTxErr blk))
-> Codec
     (LocalTxSubmission (GenTx blk) (ApplyTxErr blk))
     DeserialiseFailure
     m
     ByteString
forall tx reject (m :: * -> *).
MonadST m =>
(tx -> Encoding)
-> (forall s. Decoder s tx)
-> (reject -> Encoding)
-> (forall s. Decoder s reject)
-> Codec
     (LocalTxSubmission tx reject) DeserialiseFailure m ByteString
codecLocalTxSubmission
          GenTx blk -> Encoding
forall a. SerialiseNodeToClient blk a => a -> Encoding
enc
          Decoder s (GenTx blk)
forall s. Decoder s (GenTx blk)
forall a s. SerialiseNodeToClient blk a => Decoder s a
dec
          ApplyTxErr blk -> Encoding
forall a. SerialiseNodeToClient blk a => a -> Encoding
enc
          Decoder s (ApplyTxErr blk)
forall s. Decoder s (ApplyTxErr blk)
forall a s. SerialiseNodeToClient blk a => Decoder s a
dec

    , cStateQueryCodec :: Codec
  (LocalStateQuery blk (Point blk) (Query blk))
  DeserialiseFailure
  State
  m
  ByteString
cStateQueryCodec =
        NodeToClientVersion
-> (Point blk -> Encoding)
-> (forall s. Decoder s (Point blk))
-> (forall result. Query blk result -> Encoding)
-> (forall s. Decoder s (Some (Query blk)))
-> (forall result. Query blk result -> result -> Encoding)
-> (forall result. Query blk result -> forall s. Decoder s result)
-> Codec
     (LocalStateQuery blk (Point blk) (Query blk))
     DeserialiseFailure
     State
     m
     ByteString
forall block point (query :: * -> *) (m :: * -> *).
(MonadST m, ShowQuery query) =>
NodeToClientVersion
-> (point -> Encoding)
-> (forall s. Decoder s point)
-> (forall result. query result -> Encoding)
-> (forall s. Decoder s (Some query))
-> (forall result. query result -> result -> Encoding)
-> (forall result. query result -> forall s. Decoder s result)
-> Codec
     (LocalStateQuery block point query)
     DeserialiseFailure
     State
     m
     ByteString
codecLocalStateQuery
          NodeToClientVersion
networkVersion
          ((HeaderHash blk -> Encoding) -> Point blk -> Encoding
forall {k} (block :: k).
(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 {k} (block :: k).
(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))
          (CodecConfig blk
-> QueryVersion
-> BlockNodeToClientVersion blk
-> SomeSecond Query blk
-> Encoding
forall blk.
(Typeable blk, Show (SomeSecond BlockQuery blk),
 SerialiseNodeToClient blk (SomeSecond BlockQuery blk)) =>
CodecConfig blk
-> QueryVersion
-> BlockNodeToClientVersion blk
-> SomeSecond Query blk
-> Encoding
queryEncodeNodeToClient CodecConfig blk
ccfg QueryVersion
queryVersion BlockNodeToClientVersion blk
version (SomeSecond Query blk -> Encoding)
-> (Query blk result -> SomeSecond Query blk)
-> Query blk result
-> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Query blk result -> SomeSecond Query blk
forall {k1} {k2} (f :: k1 -> k2 -> *) (a :: k1) (b :: k2).
f a b -> SomeSecond f a
SomeSecond)
          ((\(SomeSecond Query blk b
qry) -> Query blk b -> Some (Query blk)
forall {k} (f :: k -> *) (a :: k). f a -> Some f
Some Query blk b
qry) (SomeSecond Query blk -> Some (Query blk))
-> Decoder s (SomeSecond Query blk) -> Decoder s (Some (Query blk))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CodecConfig blk
-> QueryVersion
-> BlockNodeToClientVersion blk
-> forall s. Decoder s (SomeSecond Query blk)
forall blk.
SerialiseNodeToClient blk (SomeSecond BlockQuery blk) =>
CodecConfig blk
-> QueryVersion
-> BlockNodeToClientVersion blk
-> forall s. Decoder s (SomeSecond Query blk)
queryDecodeNodeToClient CodecConfig blk
ccfg QueryVersion
queryVersion BlockNodeToClientVersion blk
version)
          (CodecConfig blk
-> BlockNodeToClientVersion blk
-> Query blk result
-> result
-> Encoding
forall result.
CodecConfig blk
-> BlockNodeToClientVersion blk
-> Query blk result
-> result
-> Encoding
forall blk (query :: * -> *) result.
SerialiseResult blk query =>
CodecConfig blk
-> BlockNodeToClientVersion blk
-> query result
-> result
-> Encoding
encodeResult CodecConfig blk
ccfg BlockNodeToClientVersion blk
version)
          (CodecConfig blk
-> BlockNodeToClientVersion blk
-> Query blk result
-> forall s. Decoder s result
forall result.
CodecConfig blk
-> BlockNodeToClientVersion blk
-> Query blk result
-> forall s. Decoder s result
forall blk (query :: * -> *) result.
SerialiseResult blk query =>
CodecConfig blk
-> BlockNodeToClientVersion blk
-> query result
-> forall s. Decoder s result
decodeResult CodecConfig blk
ccfg BlockNodeToClientVersion blk
version)

    , cTxMonitorCodec :: Codec
  (LocalTxMonitor (GenTxId blk) (GenTx blk) SlotNo)
  DeserialiseFailure
  m
  ByteString
cTxMonitorCodec =
        (GenTxId blk -> Encoding)
-> (forall s. Decoder s (GenTxId blk))
-> (GenTx blk -> Encoding)
-> (forall s. Decoder s (GenTx blk))
-> (SlotNo -> Encoding)
-> (forall s. Decoder s SlotNo)
-> Codec
     (LocalTxMonitor (GenTxId blk) (GenTx blk) SlotNo)
     DeserialiseFailure
     m
     ByteString
forall txid tx slot (m :: * -> *) ptcl.
(MonadST m, ptcl ~ LocalTxMonitor txid tx slot) =>
(txid -> Encoding)
-> (forall s. Decoder s txid)
-> (tx -> Encoding)
-> (forall s. Decoder s tx)
-> (slot -> Encoding)
-> (forall s. Decoder s slot)
-> Codec
     (LocalTxMonitor txid tx slot) DeserialiseFailure m ByteString
codecLocalTxMonitor
          GenTxId blk -> Encoding
forall a. SerialiseNodeToClient blk a => a -> Encoding
enc Decoder s (GenTxId blk)
forall s. Decoder s (GenTxId blk)
forall a s. SerialiseNodeToClient blk a => Decoder s a
dec
          GenTx blk -> Encoding
forall a. SerialiseNodeToClient blk a => a -> Encoding
enc Decoder s (GenTx blk)
forall s. Decoder s (GenTx blk)
forall a s. SerialiseNodeToClient blk a => Decoder s a
dec
          SlotNo -> Encoding
forall a. SerialiseNodeToClient blk a => a -> Encoding
enc Decoder s SlotNo
forall s. Decoder s SlotNo
forall a s. SerialiseNodeToClient blk a => Decoder s a
dec
    }
  where
    queryVersion :: QueryVersion
    queryVersion :: QueryVersion
queryVersion = NodeToClientVersion -> QueryVersion
nodeToClientVersionToQueryVersion NodeToClientVersion
networkVersion

    p :: Proxy blk
    p :: Proxy blk
p = Proxy blk
forall {k} (t :: k). Proxy t
Proxy

    enc :: SerialiseNodeToClient blk a => a -> Encoding
    enc :: forall a. SerialiseNodeToClient blk a => a -> Encoding
enc = CodecConfig blk -> BlockNodeToClientVersion blk -> a -> Encoding
forall blk a.
SerialiseNodeToClient blk a =>
CodecConfig blk -> BlockNodeToClientVersion blk -> a -> Encoding
encodeNodeToClient CodecConfig blk
ccfg BlockNodeToClientVersion blk
version

    dec :: SerialiseNodeToClient blk a => forall s. Decoder s a
    dec :: forall a s. SerialiseNodeToClient blk a => Decoder s a
dec = CodecConfig blk
-> BlockNodeToClientVersion blk -> forall s. Decoder s a
forall blk a.
SerialiseNodeToClient blk a =>
CodecConfig blk
-> BlockNodeToClientVersion blk -> forall s. Decoder s a
decodeNodeToClient CodecConfig blk
ccfg BlockNodeToClientVersion blk
version

-- | Identity codecs used in tests.
identityCodecs :: (Monad m, BlockSupportsLedgerQuery blk)
               => Codecs blk CodecFailure m
                    (AnyMessage (ChainSync (Serialised blk) (Point blk) (Tip blk)))
                    (AnyMessage (LocalTxSubmission (GenTx blk) (ApplyTxErr blk)))
                    (Stateful.AnyMessage (LocalStateQuery blk (Point blk) (Query blk)) LocalStateQuery.State)
                    (AnyMessage (LocalTxMonitor (GenTxId blk) (GenTx blk) SlotNo))
identityCodecs :: forall (m :: * -> *) blk.
(Monad m, BlockSupportsLedgerQuery blk) =>
Codecs
  blk
  CodecFailure
  m
  (AnyMessage (ChainSync (Serialised blk) (Point blk) (Tip blk)))
  (AnyMessage (LocalTxSubmission (GenTx blk) (ApplyTxErr blk)))
  (AnyMessage (LocalStateQuery blk (Point blk) (Query blk)) State)
  (AnyMessage (LocalTxMonitor (GenTxId blk) (GenTx blk) SlotNo))
identityCodecs = Codecs {
      cChainSyncCodec :: Codec
  (ChainSync (Serialised blk) (Point blk) (Tip blk))
  CodecFailure
  m
  (AnyMessage (ChainSync (Serialised blk) (Point blk) (Tip blk)))
cChainSyncCodec    = Codec
  (ChainSync (Serialised blk) (Point blk) (Tip blk))
  CodecFailure
  m
  (AnyMessage (ChainSync (Serialised blk) (Point blk) (Tip blk)))
forall {k} {k1} {k2} (header :: k) (point :: k1) (tip :: k2)
       (m :: * -> *).
Monad m =>
Codec
  (ChainSync header point tip)
  CodecFailure
  m
  (AnyMessage (ChainSync header point tip))
codecChainSyncId
    , cTxSubmissionCodec :: Codec
  (LocalTxSubmission (GenTx blk) (ApplyTxErr blk))
  CodecFailure
  m
  (AnyMessage (LocalTxSubmission (GenTx blk) (ApplyTxErr blk)))
cTxSubmissionCodec = Codec
  (LocalTxSubmission (GenTx blk) (ApplyTxErr blk))
  CodecFailure
  m
  (AnyMessage (LocalTxSubmission (GenTx blk) (ApplyTxErr blk)))
forall {k} {k1} (tx :: k) (reject :: k1) (m :: * -> *).
Monad m =>
Codec
  (LocalTxSubmission tx reject)
  CodecFailure
  m
  (AnyMessage (LocalTxSubmission tx reject))
codecLocalTxSubmissionId
    , cStateQueryCodec :: Codec
  (LocalStateQuery blk (Point blk) (Query blk))
  CodecFailure
  State
  m
  (AnyMessage (LocalStateQuery blk (Point blk) (Query blk)) State)
cStateQueryCodec   = (forall result1 result2.
 Query blk result1
 -> Query blk result2 -> Maybe (result1 :~: result2))
-> Codec
     (LocalStateQuery blk (Point blk) (Query blk))
     CodecFailure
     State
     m
     (AnyMessage (LocalStateQuery blk (Point blk) (Query blk)) State)
forall block point (query :: * -> *) (m :: * -> *).
Monad m =>
(forall result1 result2.
 query result1 -> query result2 -> Maybe (result1 :~: result2))
-> Codec
     (LocalStateQuery block point query)
     CodecFailure
     State
     m
     (AnyMessage (LocalStateQuery block point query) State)
codecLocalStateQueryId Query blk result1
-> Query blk result2 -> Maybe (result1 :~: result2)
forall result1 result2.
Query blk result1
-> Query blk result2 -> Maybe (result1 :~: result2)
forall (f :: * -> *) a b.
SameDepIndex f =>
f a -> f b -> Maybe (a :~: b)
sameDepIndex
    , cTxMonitorCodec :: Codec
  (LocalTxMonitor (GenTxId blk) (GenTx blk) SlotNo)
  CodecFailure
  m
  (AnyMessage (LocalTxMonitor (GenTxId blk) (GenTx blk) SlotNo))
cTxMonitorCodec    = Codec
  (LocalTxMonitor (GenTxId blk) (GenTx blk) SlotNo)
  CodecFailure
  m
  (AnyMessage (LocalTxMonitor (GenTxId blk) (GenTx blk) SlotNo))
forall {k} {k1} {k2} (txid :: k) (tx :: k1) (slot :: k2)
       (m :: * -> *) ptcl.
(Monad m, ptcl ~ LocalTxMonitor txid tx slot) =>
Codec ptcl CodecFailure m (AnyMessage ptcl)
codecLocalTxMonitorId
    }

{-------------------------------------------------------------------------------
  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 {
      forall {k} peer blk (e :: k) (f :: * -> *).
Tracers' peer blk e f
-> f (TraceLabelPeer
        peer
        (TraceSendRecv (ChainSync (Serialised blk) (Point blk) (Tip blk))))
tChainSyncTracer    :: f (TraceLabelPeer peer (TraceSendRecv (ChainSync (Serialised blk) (Point blk) (Tip blk))))
    , forall {k} peer blk (e :: k) (f :: * -> *).
Tracers' peer blk e f
-> f (TraceLabelPeer
        peer
        (TraceSendRecv (LocalTxSubmission (GenTx blk) (ApplyTxErr blk))))
tTxSubmissionTracer :: f (TraceLabelPeer peer (TraceSendRecv (LocalTxSubmission (GenTx blk) (ApplyTxErr blk))))
    , forall {k} peer blk (e :: k) (f :: * -> *).
Tracers' peer blk e f
-> f (TraceLabelPeer
        peer
        (TraceSendRecv
           (LocalStateQuery blk (Point blk) (Query blk)) State))
tStateQueryTracer   :: f (TraceLabelPeer peer (Stateful.TraceSendRecv (LocalStateQuery blk (Point blk) (Query blk)) LocalStateQuery.State))
    , forall {k} peer blk (e :: k) (f :: * -> *).
Tracers' peer blk e f
-> f (TraceLabelPeer
        peer
        (TraceSendRecv (LocalTxMonitor (GenTxId blk) (GenTx blk) SlotNo)))
tTxMonitorTracer    :: f (TraceLabelPeer peer (TraceSendRecv (LocalTxMonitor (GenTxId blk) (GenTx blk) SlotNo)))
    }

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 {
        tChainSyncTracer :: f (TraceLabelPeer
     peer
     (TraceSendRecv (ChainSync (Serialised blk) (Point blk) (Tip blk))))
tChainSyncTracer    = (Tracers' peer blk e f
 -> f (TraceLabelPeer
         peer
         (TraceSendRecv
            (ChainSync (Serialised blk) (Point blk) (Tip blk)))))
-> f (TraceLabelPeer
        peer
        (TraceSendRecv (ChainSync (Serialised 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 (Serialised blk) (Point blk) (Tip blk))))
forall {k} peer blk (e :: k) (f :: * -> *).
Tracers' peer blk e f
-> f (TraceLabelPeer
        peer
        (TraceSendRecv (ChainSync (Serialised blk) (Point blk) (Tip blk))))
tChainSyncTracer
      , tTxSubmissionTracer :: f (TraceLabelPeer
     peer
     (TraceSendRecv (LocalTxSubmission (GenTx blk) (ApplyTxErr blk))))
tTxSubmissionTracer = (Tracers' peer blk e f
 -> f (TraceLabelPeer
         peer
         (TraceSendRecv (LocalTxSubmission (GenTx blk) (ApplyTxErr blk)))))
-> f (TraceLabelPeer
        peer
        (TraceSendRecv (LocalTxSubmission (GenTx blk) (ApplyTxErr blk))))
forall a. Semigroup a => (Tracers' peer blk e f -> a) -> a
f Tracers' peer blk e f
-> f (TraceLabelPeer
        peer
        (TraceSendRecv (LocalTxSubmission (GenTx blk) (ApplyTxErr blk))))
forall {k} peer blk (e :: k) (f :: * -> *).
Tracers' peer blk e f
-> f (TraceLabelPeer
        peer
        (TraceSendRecv (LocalTxSubmission (GenTx blk) (ApplyTxErr blk))))
tTxSubmissionTracer
      , tStateQueryTracer :: f (TraceLabelPeer
     peer
     (TraceSendRecv
        (LocalStateQuery blk (Point blk) (Query blk)) State))
tStateQueryTracer   = (Tracers' peer blk e f
 -> f (TraceLabelPeer
         peer
         (TraceSendRecv
            (LocalStateQuery blk (Point blk) (Query blk)) State)))
-> f (TraceLabelPeer
        peer
        (TraceSendRecv
           (LocalStateQuery blk (Point blk) (Query blk)) State))
forall a. Semigroup a => (Tracers' peer blk e f -> a) -> a
f Tracers' peer blk e f
-> f (TraceLabelPeer
        peer
        (TraceSendRecv
           (LocalStateQuery blk (Point blk) (Query blk)) State))
forall {k} peer blk (e :: k) (f :: * -> *).
Tracers' peer blk e f
-> f (TraceLabelPeer
        peer
        (TraceSendRecv
           (LocalStateQuery blk (Point blk) (Query blk)) State))
tStateQueryTracer
      , tTxMonitorTracer :: f (TraceLabelPeer
     peer
     (TraceSendRecv (LocalTxMonitor (GenTxId blk) (GenTx blk) SlotNo)))
tTxMonitorTracer    = (Tracers' peer blk e f
 -> f (TraceLabelPeer
         peer
         (TraceSendRecv (LocalTxMonitor (GenTxId blk) (GenTx blk) SlotNo))))
-> f (TraceLabelPeer
        peer
        (TraceSendRecv (LocalTxMonitor (GenTxId blk) (GenTx blk) SlotNo)))
forall a. Semigroup a => (Tracers' peer blk e f -> a) -> a
f Tracers' peer blk e f
-> f (TraceLabelPeer
        peer
        (TraceSendRecv (LocalTxMonitor (GenTxId blk) (GenTx blk) SlotNo)))
forall {k} peer blk (e :: k) (f :: * -> *).
Tracers' peer blk e f
-> f (TraceLabelPeer
        peer
        (TraceSendRecv (LocalTxMonitor (GenTxId blk) (GenTx blk) SlotNo)))
tTxMonitorTracer
      }
    where
      f :: forall a. Semigroup a
        => (Tracers' peer blk e f -> a)
        -> a
      f :: forall a. Semigroup a => (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 :: forall {k} (m :: * -> *) peer blk (e :: k).
Monad m =>
Tracers m peer blk e
nullTracers = Tracers {
      tChainSyncTracer :: Tracer
  m
  (TraceLabelPeer
     peer
     (TraceSendRecv (ChainSync (Serialised blk) (Point blk) (Tip blk))))
tChainSyncTracer    = Tracer
  m
  (TraceLabelPeer
     peer
     (TraceSendRecv (ChainSync (Serialised blk) (Point blk) (Tip blk))))
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
    , tTxSubmissionTracer :: Tracer
  m
  (TraceLabelPeer
     peer
     (TraceSendRecv (LocalTxSubmission (GenTx blk) (ApplyTxErr blk))))
tTxSubmissionTracer = Tracer
  m
  (TraceLabelPeer
     peer
     (TraceSendRecv (LocalTxSubmission (GenTx blk) (ApplyTxErr blk))))
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
    , tStateQueryTracer :: Tracer
  m
  (TraceLabelPeer
     peer
     (TraceSendRecv
        (LocalStateQuery blk (Point blk) (Query blk)) State))
tStateQueryTracer   = Tracer
  m
  (TraceLabelPeer
     peer
     (TraceSendRecv
        (LocalStateQuery blk (Point blk) (Query blk)) State))
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
    , tTxMonitorTracer :: Tracer
  m
  (TraceLabelPeer
     peer
     (TraceSendRecv (LocalTxMonitor (GenTxId blk) (GenTx blk) SlotNo)))
tTxMonitorTracer    = Tracer
  m
  (TraceLabelPeer
     peer
     (TraceSendRecv (LocalTxMonitor (GenTxId blk) (GenTx blk) SlotNo)))
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
    }

showTracers :: ( Show peer
               , Show (GenTx blk)
               , Show (GenTxId blk)
               , Show (ApplyTxErr blk)
               , ShowQuery (BlockQuery blk)
               , HasHeader blk
               )
            => Tracer m String -> Tracers m peer blk e
showTracers :: forall {k} peer blk (m :: * -> *) (e :: k).
(Show peer, Show (GenTx blk), Show (GenTxId blk),
 Show (ApplyTxErr blk), ShowQuery (BlockQuery blk),
 HasHeader blk) =>
Tracer m String -> Tracers m peer blk e
showTracers Tracer m String
tr = Tracers {
      tChainSyncTracer :: Tracer
  m
  (TraceLabelPeer
     peer
     (TraceSendRecv (ChainSync (Serialised blk) (Point blk) (Tip blk))))
tChainSyncTracer    = Tracer m String
-> Tracer
     m
     (TraceLabelPeer
        peer
        (TraceSendRecv (ChainSync (Serialised blk) (Point blk) (Tip blk))))
forall a (m :: * -> *). Show a => Tracer m String -> Tracer m a
showTracing Tracer m String
tr
    , tTxSubmissionTracer :: Tracer
  m
  (TraceLabelPeer
     peer
     (TraceSendRecv (LocalTxSubmission (GenTx blk) (ApplyTxErr blk))))
tTxSubmissionTracer = Tracer m String
-> Tracer
     m
     (TraceLabelPeer
        peer
        (TraceSendRecv (LocalTxSubmission (GenTx blk) (ApplyTxErr blk))))
forall a (m :: * -> *). Show a => Tracer m String -> Tracer m a
showTracing Tracer m String
tr
    , tStateQueryTracer :: Tracer
  m
  (TraceLabelPeer
     peer
     (TraceSendRecv
        (LocalStateQuery blk (Point blk) (Query blk)) State))
tStateQueryTracer   = Tracer m String
-> Tracer
     m
     (TraceLabelPeer
        peer
        (TraceSendRecv
           (LocalStateQuery blk (Point blk) (Query blk)) State))
forall a (m :: * -> *). Show a => Tracer m String -> Tracer m a
showTracing Tracer m String
tr
    , tTxMonitorTracer :: Tracer
  m
  (TraceLabelPeer
     peer
     (TraceSendRecv (LocalTxMonitor (GenTxId blk) (GenTx blk) SlotNo)))
tTxMonitorTracer    = Tracer m String
-> Tracer
     m
     (TraceLabelPeer
        peer
        (TraceSendRecv (LocalTxMonitor (GenTxId blk) (GenTx blk) SlotNo)))
forall a (m :: * -> *). Show a => Tracer m String -> Tracer m a
showTracing Tracer m String
tr
    }

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

-- | A node-to-client application
type App m peer bytes a = peer -> Channel m bytes -> m (a, Maybe bytes)

-- | Applications for the node-to-client (i.e., local) protocols
--
-- See 'Network.Mux.Types.MuxApplication'
data Apps m peer bCS bTX bSQ bTM a = Apps {
      -- | Start a local chain sync server.
      forall (m :: * -> *) peer bCS bTX bSQ bTM a.
Apps m peer bCS bTX bSQ bTM a -> App m peer bCS a
aChainSyncServer    :: App m peer bCS a

      -- | Start a local transaction submission server.
    , forall (m :: * -> *) peer bCS bTX bSQ bTM a.
Apps m peer bCS bTX bSQ bTM a -> App m peer bTX a
aTxSubmissionServer :: App m peer bTX a

      -- | Start a local state query server.
    , forall (m :: * -> *) peer bCS bTX bSQ bTM a.
Apps m peer bCS bTX bSQ bTM a -> App m peer bSQ a
aStateQueryServer   :: App m peer bSQ a

      -- | Start a local transaction monitor server
    , forall (m :: * -> *) peer bCS bTX bSQ bTM a.
Apps m peer bCS bTX bSQ bTM a -> App m peer bTM a
aTxMonitorServer    :: App m peer bTM a
    }

-- | Construct the 'NetworkApplication' for the node-to-client protocols
mkApps ::
     forall m addrNTN addrNTC blk e bCS bTX bSQ bTM.
     ( IOLike m
     , Exception e
     , ShowProxy blk
     , ShowProxy (ApplyTxErr blk)
     , ShowProxy (BlockQuery blk)
     , ShowProxy (GenTx blk)
     , ShowProxy (GenTxId blk)
     , ShowQuery (BlockQuery blk)
     )
  => NodeKernel m addrNTN addrNTC blk
  -> Tracers m addrNTC blk e
  -> Codecs blk e m bCS bTX bSQ bTM
  -> Handlers m addrNTC blk
  -> Apps m addrNTC bCS bTX bSQ bTM ()
mkApps :: forall (m :: * -> *) addrNTN addrNTC blk e bCS bTX bSQ bTM.
(IOLike m, Exception e, ShowProxy blk, ShowProxy (ApplyTxErr blk),
 ShowProxy (BlockQuery blk), ShowProxy (GenTx blk),
 ShowProxy (GenTxId blk), ShowQuery (BlockQuery blk)) =>
NodeKernel m addrNTN addrNTC blk
-> Tracers m addrNTC blk e
-> Codecs blk e m bCS bTX bSQ bTM
-> Handlers m addrNTC blk
-> Apps m addrNTC bCS bTX bSQ bTM ()
mkApps NodeKernel m addrNTN addrNTC blk
kernel Tracers {Tracer
  m
  (TraceLabelPeer
     addrNTC
     (TraceSendRecv (ChainSync (Serialised blk) (Point blk) (Tip blk))))
Tracer
  m
  (TraceLabelPeer
     addrNTC
     (TraceSendRecv (LocalTxMonitor (GenTxId blk) (GenTx blk) SlotNo)))
Tracer
  m
  (TraceLabelPeer
     addrNTC
     (TraceSendRecv (LocalTxSubmission (GenTx blk) (ApplyTxErr blk))))
Tracer
  m
  (TraceLabelPeer
     addrNTC
     (TraceSendRecv
        (LocalStateQuery blk (Point blk) (Query blk)) State))
tChainSyncTracer :: forall {k} peer blk (e :: k) (f :: * -> *).
Tracers' peer blk e f
-> f (TraceLabelPeer
        peer
        (TraceSendRecv (ChainSync (Serialised blk) (Point blk) (Tip blk))))
tTxSubmissionTracer :: forall {k} peer blk (e :: k) (f :: * -> *).
Tracers' peer blk e f
-> f (TraceLabelPeer
        peer
        (TraceSendRecv (LocalTxSubmission (GenTx blk) (ApplyTxErr blk))))
tStateQueryTracer :: forall {k} peer blk (e :: k) (f :: * -> *).
Tracers' peer blk e f
-> f (TraceLabelPeer
        peer
        (TraceSendRecv
           (LocalStateQuery blk (Point blk) (Query blk)) State))
tTxMonitorTracer :: forall {k} peer blk (e :: k) (f :: * -> *).
Tracers' peer blk e f
-> f (TraceLabelPeer
        peer
        (TraceSendRecv (LocalTxMonitor (GenTxId blk) (GenTx blk) SlotNo)))
tChainSyncTracer :: Tracer
  m
  (TraceLabelPeer
     addrNTC
     (TraceSendRecv (ChainSync (Serialised blk) (Point blk) (Tip blk))))
tTxSubmissionTracer :: Tracer
  m
  (TraceLabelPeer
     addrNTC
     (TraceSendRecv (LocalTxSubmission (GenTx blk) (ApplyTxErr blk))))
tStateQueryTracer :: Tracer
  m
  (TraceLabelPeer
     addrNTC
     (TraceSendRecv
        (LocalStateQuery blk (Point blk) (Query blk)) State))
tTxMonitorTracer :: Tracer
  m
  (TraceLabelPeer
     addrNTC
     (TraceSendRecv (LocalTxMonitor (GenTxId blk) (GenTx blk) SlotNo)))
..} Codecs {Codec (ChainSync (Serialised blk) (Point blk) (Tip blk)) e m bCS
Codec (LocalTxMonitor (GenTxId blk) (GenTx blk) SlotNo) e m bTM
Codec (LocalTxSubmission (GenTx blk) (ApplyTxErr blk)) e m bTX
Codec (LocalStateQuery blk (Point blk) (Query blk)) e State m bSQ
cChainSyncCodec :: forall {k} blk (serialisedBlk :: k) e (m :: * -> *) bCS bTX bSQ
       bTM.
Codecs' blk serialisedBlk e m bCS bTX bSQ bTM
-> Codec (ChainSync serialisedBlk (Point blk) (Tip blk)) e m bCS
cTxSubmissionCodec :: forall {k} blk (serialisedBlk :: k) e (m :: * -> *) bCS bTX bSQ
       bTM.
Codecs' blk serialisedBlk e m bCS bTX bSQ bTM
-> Codec (LocalTxSubmission (GenTx blk) (ApplyTxErr blk)) e m bTX
cStateQueryCodec :: forall {k} blk (serialisedBlk :: k) e (m :: * -> *) bCS bTX bSQ
       bTM.
Codecs' blk serialisedBlk e m bCS bTX bSQ bTM
-> Codec
     (LocalStateQuery blk (Point blk) (Query blk)) e State m bSQ
cTxMonitorCodec :: forall {k} blk (serialisedBlk :: k) e (m :: * -> *) bCS bTX bSQ
       bTM.
Codecs' blk serialisedBlk e m bCS bTX bSQ bTM
-> Codec (LocalTxMonitor (GenTxId blk) (GenTx blk) SlotNo) e m bTM
cChainSyncCodec :: Codec (ChainSync (Serialised blk) (Point blk) (Tip blk)) e m bCS
cTxSubmissionCodec :: Codec (LocalTxSubmission (GenTx blk) (ApplyTxErr blk)) e m bTX
cStateQueryCodec :: Codec (LocalStateQuery blk (Point blk) (Query blk)) e State m bSQ
cTxMonitorCodec :: Codec (LocalTxMonitor (GenTxId blk) (GenTx blk) SlotNo) e m bTM
..} Handlers {LocalStateQueryServer blk (Point blk) (Query blk) m ()
LocalTxMonitorServer (GenTxId blk) (GenTx blk) SlotNo m ()
LocalTxSubmissionServer (GenTx blk) (ApplyTxErr blk) m ()
Follower m blk (WithPoint blk (Serialised blk))
-> ChainSyncServer (Serialised blk) (Point blk) (Tip blk) m ()
hChainSyncServer :: forall {k} (m :: * -> *) (peer :: k) blk.
Handlers m peer blk
-> Follower m blk (WithPoint blk (Serialised blk))
-> ChainSyncServer (Serialised blk) (Point blk) (Tip blk) m ()
hTxSubmissionServer :: forall {k} (m :: * -> *) (peer :: k) blk.
Handlers m peer blk
-> LocalTxSubmissionServer (GenTx blk) (ApplyTxErr blk) m ()
hStateQueryServer :: forall {k} (m :: * -> *) (peer :: k) blk.
Handlers m peer blk
-> LocalStateQueryServer blk (Point blk) (Query blk) m ()
hTxMonitorServer :: forall {k} (m :: * -> *) (peer :: k) blk.
Handlers m peer blk
-> LocalTxMonitorServer (GenTxId blk) (GenTx blk) SlotNo m ()
hChainSyncServer :: Follower m blk (WithPoint blk (Serialised blk))
-> ChainSyncServer (Serialised blk) (Point blk) (Tip blk) m ()
hTxSubmissionServer :: LocalTxSubmissionServer (GenTx blk) (ApplyTxErr blk) m ()
hStateQueryServer :: LocalStateQueryServer blk (Point blk) (Query blk) m ()
hTxMonitorServer :: LocalTxMonitorServer (GenTxId blk) (GenTx blk) SlotNo m ()
..} =
    Apps {App m addrNTC bCS ()
App m addrNTC bTX ()
App m addrNTC bSQ ()
App m addrNTC bTM ()
aChainSyncServer :: App m addrNTC bCS ()
aTxSubmissionServer :: App m addrNTC bTX ()
aStateQueryServer :: App m addrNTC bSQ ()
aTxMonitorServer :: App m addrNTC bTM ()
aChainSyncServer :: App m addrNTC bCS ()
aTxSubmissionServer :: App m addrNTC bTX ()
aStateQueryServer :: App m addrNTC bSQ ()
aTxMonitorServer :: App m addrNTC bTM ()
..}
  where
    aChainSyncServer
      :: addrNTC
      -> Channel m bCS
      -> m ((), Maybe bCS)
    aChainSyncServer :: App m addrNTC bCS ()
aChainSyncServer addrNTC
them Channel m bCS
channel = do
      String -> m ()
forall (m :: * -> *). MonadThread m => String -> m ()
labelThisThread String
"LocalChainSyncServer"
      (ResourceRegistry m
 -> m (Follower m blk (WithPoint blk (Serialised blk))))
-> (Follower m blk (WithPoint blk (Serialised blk)) -> m ())
-> (Follower m blk (WithPoint blk (Serialised blk))
    -> m ((), Maybe bCS))
-> m ((), Maybe bCS)
forall (m :: * -> *) a r.
(MonadSTM m, MonadMask m, MonadThread m, HasCallStack) =>
(ResourceRegistry m -> m a) -> (a -> m ()) -> (a -> m r) -> m r
bracketWithPrivateRegistry
        (ChainDB m blk
-> ResourceRegistry m
-> m (Follower m blk (WithPoint blk (Serialised blk)))
forall (m :: * -> *) blk.
ChainDB m blk
-> ResourceRegistry m
-> m (Follower m blk (WithPoint blk (Serialised blk)))
chainSyncBlockServerFollower (NodeKernel m addrNTN addrNTC blk -> ChainDB m blk
forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernel m addrNTN addrNTC blk -> ChainDB m blk
getChainDB NodeKernel m addrNTN addrNTC blk
kernel))
        Follower m blk (WithPoint blk (Serialised blk)) -> m ()
forall (m :: * -> *) blk a. Follower m blk a -> m ()
ChainDB.followerClose
        ((Follower m blk (WithPoint blk (Serialised blk))
  -> m ((), Maybe bCS))
 -> m ((), Maybe bCS))
-> (Follower m blk (WithPoint blk (Serialised blk))
    -> m ((), Maybe bCS))
-> m ((), Maybe bCS)
forall a b. (a -> b) -> a -> b
$ \Follower m blk (WithPoint blk (Serialised blk))
flr ->
          Tracer
  m
  (TraceSendRecv (ChainSync (Serialised blk) (Point blk) (Tip blk)))
-> Codec (ChainSync (Serialised blk) (Point blk) (Tip blk)) e m bCS
-> Channel m bCS
-> Peer
     (ChainSync (Serialised blk) (Point blk) (Tip blk))
     'AsServer
     'NonPipelined
     'StIdle
     m
     ()
-> m ((), Maybe bCS)
forall ps (st :: ps) (pr :: PeerRole) failure bytes (m :: * -> *)
       a.
(MonadThrow m, ShowProxy ps,
 forall (st' :: ps) stok. (stok ~ StateToken st') => Show stok,
 Show failure) =>
Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> Channel m bytes
-> Peer ps pr 'NonPipelined st m a
-> m (a, Maybe bytes)
runPeer
            ((TraceSendRecv (ChainSync (Serialised blk) (Point blk) (Tip blk))
 -> TraceLabelPeer
      addrNTC
      (TraceSendRecv (ChainSync (Serialised blk) (Point blk) (Tip blk))))
-> Tracer
     m
     (TraceLabelPeer
        addrNTC
        (TraceSendRecv (ChainSync (Serialised blk) (Point blk) (Tip blk))))
-> Tracer
     m
     (TraceSendRecv (ChainSync (Serialised blk) (Point blk) (Tip blk)))
forall a' a. (a' -> a) -> Tracer m a -> Tracer m a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap (addrNTC
-> TraceSendRecv (ChainSync (Serialised blk) (Point blk) (Tip blk))
-> TraceLabelPeer
     addrNTC
     (TraceSendRecv (ChainSync (Serialised blk) (Point blk) (Tip blk)))
forall peerid a. peerid -> a -> TraceLabelPeer peerid a
TraceLabelPeer addrNTC
them) Tracer
  m
  (TraceLabelPeer
     addrNTC
     (TraceSendRecv (ChainSync (Serialised blk) (Point blk) (Tip blk))))
tChainSyncTracer)
            Codec (ChainSync (Serialised blk) (Point blk) (Tip blk)) e m bCS
cChainSyncCodec
            Channel m bCS
channel
            (Peer
   (ChainSync (Serialised blk) (Point blk) (Tip blk))
   'AsServer
   'NonPipelined
   'StIdle
   m
   ()
 -> m ((), Maybe bCS))
-> Peer
     (ChainSync (Serialised blk) (Point blk) (Tip blk))
     'AsServer
     'NonPipelined
     'StIdle
     m
     ()
-> m ((), Maybe bCS)
forall a b. (a -> b) -> a -> b
$ ChainSyncServer (Serialised blk) (Point blk) (Tip blk) m ()
-> Peer
     (ChainSync (Serialised blk) (Point blk) (Tip blk))
     'AsServer
     'NonPipelined
     'StIdle
     m
     ()
forall header point tip (m :: * -> *) a.
Monad m =>
ChainSyncServer header point tip m a
-> Server (ChainSync header point tip) 'NonPipelined 'StIdle m a
chainSyncServerPeer
            (ChainSyncServer (Serialised blk) (Point blk) (Tip blk) m ()
 -> Peer
      (ChainSync (Serialised blk) (Point blk) (Tip blk))
      'AsServer
      'NonPipelined
      'StIdle
      m
      ())
-> ChainSyncServer (Serialised blk) (Point blk) (Tip blk) m ()
-> Peer
     (ChainSync (Serialised blk) (Point blk) (Tip blk))
     'AsServer
     'NonPipelined
     'StIdle
     m
     ()
forall a b. (a -> b) -> a -> b
$ Follower m blk (WithPoint blk (Serialised blk))
-> ChainSyncServer (Serialised blk) (Point blk) (Tip blk) m ()
hChainSyncServer Follower m blk (WithPoint blk (Serialised blk))
flr

    aTxSubmissionServer
      :: addrNTC
      -> Channel m bTX
      -> m ((), Maybe bTX)
    aTxSubmissionServer :: App m addrNTC bTX ()
aTxSubmissionServer addrNTC
them Channel m bTX
channel = do
      String -> m ()
forall (m :: * -> *). MonadThread m => String -> m ()
labelThisThread String
"LocalTxSubmissionServer"
      Tracer
  m (TraceSendRecv (LocalTxSubmission (GenTx blk) (ApplyTxErr blk)))
-> Codec (LocalTxSubmission (GenTx blk) (ApplyTxErr blk)) e m bTX
-> Channel m bTX
-> Peer
     (LocalTxSubmission (GenTx blk) (ApplyTxErr blk))
     'AsServer
     'NonPipelined
     'StIdle
     m
     ()
-> m ((), Maybe bTX)
forall ps (st :: ps) (pr :: PeerRole) failure bytes (m :: * -> *)
       a.
(MonadThrow m, ShowProxy ps,
 forall (st' :: ps) stok. (stok ~ StateToken st') => Show stok,
 Show failure) =>
Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> Channel m bytes
-> Peer ps pr 'NonPipelined st m a
-> m (a, Maybe bytes)
runPeer
        ((TraceSendRecv (LocalTxSubmission (GenTx blk) (ApplyTxErr blk))
 -> TraceLabelPeer
      addrNTC
      (TraceSendRecv (LocalTxSubmission (GenTx blk) (ApplyTxErr blk))))
-> Tracer
     m
     (TraceLabelPeer
        addrNTC
        (TraceSendRecv (LocalTxSubmission (GenTx blk) (ApplyTxErr blk))))
-> Tracer
     m (TraceSendRecv (LocalTxSubmission (GenTx blk) (ApplyTxErr blk)))
forall a' a. (a' -> a) -> Tracer m a -> Tracer m a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap (addrNTC
-> TraceSendRecv (LocalTxSubmission (GenTx blk) (ApplyTxErr blk))
-> TraceLabelPeer
     addrNTC
     (TraceSendRecv (LocalTxSubmission (GenTx blk) (ApplyTxErr blk)))
forall peerid a. peerid -> a -> TraceLabelPeer peerid a
TraceLabelPeer addrNTC
them) Tracer
  m
  (TraceLabelPeer
     addrNTC
     (TraceSendRecv (LocalTxSubmission (GenTx blk) (ApplyTxErr blk))))
tTxSubmissionTracer)
        Codec (LocalTxSubmission (GenTx blk) (ApplyTxErr blk)) e m bTX
cTxSubmissionCodec
        Channel m bTX
channel
        (m (LocalTxSubmissionServer (GenTx blk) (ApplyTxErr blk) m ())
-> Peer
     (LocalTxSubmission (GenTx blk) (ApplyTxErr blk))
     'AsServer
     'NonPipelined
     'StIdle
     m
     ()
forall tx reject (m :: * -> *) a.
Monad m =>
m (LocalTxSubmissionServer tx reject m a)
-> Server (LocalTxSubmission tx reject) 'NonPipelined 'StIdle m a
localTxSubmissionServerPeer (LocalTxSubmissionServer (GenTx blk) (ApplyTxErr blk) m ()
-> m (LocalTxSubmissionServer (GenTx blk) (ApplyTxErr blk) m ())
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LocalTxSubmissionServer (GenTx blk) (ApplyTxErr blk) m ()
hTxSubmissionServer))

    aStateQueryServer
      :: addrNTC
      -> Channel m bSQ
      -> m ((), Maybe bSQ)
    aStateQueryServer :: App m addrNTC bSQ ()
aStateQueryServer addrNTC
them Channel m bSQ
channel = do
      String -> m ()
forall (m :: * -> *). MonadThread m => String -> m ()
labelThisThread String
"LocalStateQueryServer"
      Tracer
  m
  (TraceSendRecv (LocalStateQuery blk (Point blk) (Query blk)) State)
-> Codec
     (LocalStateQuery blk (Point blk) (Query blk)) e State m bSQ
-> Channel m bSQ
-> State 'StIdle
-> Peer
     (LocalStateQuery blk (Point blk) (Query blk))
     'AsServer
     'StIdle
     State
     m
     ()
-> m ((), Maybe bSQ)
forall ps (st :: ps) (pr :: PeerRole) failure bytes (f :: ps -> *)
       (m :: * -> *) a.
(MonadAsync m, MonadMask m, Show failure,
 forall (st' :: ps) stok. (stok ~ StateToken st') => Show stok,
 ShowProxy ps) =>
Tracer m (TraceSendRecv ps f)
-> Codec ps failure f m bytes
-> Channel m bytes
-> f st
-> Peer ps pr st f m a
-> m (a, Maybe bytes)
Stateful.runPeer
        ((TraceSendRecv (LocalStateQuery blk (Point blk) (Query blk)) State
 -> TraceLabelPeer
      addrNTC
      (TraceSendRecv
         (LocalStateQuery blk (Point blk) (Query blk)) State))
-> Tracer
     m
     (TraceLabelPeer
        addrNTC
        (TraceSendRecv
           (LocalStateQuery blk (Point blk) (Query blk)) State))
-> Tracer
     m
     (TraceSendRecv (LocalStateQuery blk (Point blk) (Query blk)) State)
forall a' a. (a' -> a) -> Tracer m a -> Tracer m a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap (addrNTC
-> TraceSendRecv
     (LocalStateQuery blk (Point blk) (Query blk)) State
-> TraceLabelPeer
     addrNTC
     (TraceSendRecv (LocalStateQuery blk (Point blk) (Query blk)) State)
forall peerid a. peerid -> a -> TraceLabelPeer peerid a
TraceLabelPeer addrNTC
them) Tracer
  m
  (TraceLabelPeer
     addrNTC
     (TraceSendRecv
        (LocalStateQuery blk (Point blk) (Query blk)) State))
tStateQueryTracer)
        Codec (LocalStateQuery blk (Point blk) (Query blk)) e State m bSQ
cStateQueryCodec
        Channel m bSQ
channel
        State 'StIdle
forall {block} {point} {query :: * -> *}. State 'StIdle
LocalStateQuery.StateIdle
        (LocalStateQueryServer blk (Point blk) (Query blk) m ()
-> Peer
     (LocalStateQuery blk (Point blk) (Query blk))
     'AsServer
     'StIdle
     State
     m
     ()
forall block point (query :: * -> *) (m :: * -> *) a.
Monad m =>
LocalStateQueryServer block point query m a
-> Server (LocalStateQuery block point query) 'StIdle State m a
localStateQueryServerPeer LocalStateQueryServer blk (Point blk) (Query blk) m ()
hStateQueryServer)

    aTxMonitorServer
      :: addrNTC
      -> Channel m bTM
      -> m ((), Maybe bTM)
    aTxMonitorServer :: App m addrNTC bTM ()
aTxMonitorServer addrNTC
them Channel m bTM
channel = do
      String -> m ()
forall (m :: * -> *). MonadThread m => String -> m ()
labelThisThread String
"LocalTxMonitorServer"
      Tracer
  m (TraceSendRecv (LocalTxMonitor (GenTxId blk) (GenTx blk) SlotNo))
-> Codec (LocalTxMonitor (GenTxId blk) (GenTx blk) SlotNo) e m bTM
-> Channel m bTM
-> Peer
     (LocalTxMonitor (GenTxId blk) (GenTx blk) SlotNo)
     'AsServer
     'NonPipelined
     'StIdle
     m
     ()
-> m ((), Maybe bTM)
forall ps (st :: ps) (pr :: PeerRole) failure bytes (m :: * -> *)
       a.
(MonadThrow m, ShowProxy ps,
 forall (st' :: ps) stok. (stok ~ StateToken st') => Show stok,
 Show failure) =>
Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> Channel m bytes
-> Peer ps pr 'NonPipelined st m a
-> m (a, Maybe bytes)
runPeer
        ((TraceSendRecv (LocalTxMonitor (GenTxId blk) (GenTx blk) SlotNo)
 -> TraceLabelPeer
      addrNTC
      (TraceSendRecv (LocalTxMonitor (GenTxId blk) (GenTx blk) SlotNo)))
-> Tracer
     m
     (TraceLabelPeer
        addrNTC
        (TraceSendRecv (LocalTxMonitor (GenTxId blk) (GenTx blk) SlotNo)))
-> Tracer
     m (TraceSendRecv (LocalTxMonitor (GenTxId blk) (GenTx blk) SlotNo))
forall a' a. (a' -> a) -> Tracer m a -> Tracer m a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap (addrNTC
-> TraceSendRecv (LocalTxMonitor (GenTxId blk) (GenTx blk) SlotNo)
-> TraceLabelPeer
     addrNTC
     (TraceSendRecv (LocalTxMonitor (GenTxId blk) (GenTx blk) SlotNo))
forall peerid a. peerid -> a -> TraceLabelPeer peerid a
TraceLabelPeer addrNTC
them) Tracer
  m
  (TraceLabelPeer
     addrNTC
     (TraceSendRecv (LocalTxMonitor (GenTxId blk) (GenTx blk) SlotNo)))
tTxMonitorTracer)
        Codec (LocalTxMonitor (GenTxId blk) (GenTx blk) SlotNo) e m bTM
cTxMonitorCodec
        Channel m bTM
channel
        (LocalTxMonitorServer (GenTxId blk) (GenTx blk) SlotNo m ()
-> Peer
     (LocalTxMonitor (GenTxId blk) (GenTx blk) SlotNo)
     'AsServer
     'NonPipelined
     'StIdle
     m
     ()
forall txid tx slot (m :: * -> *) a.
Monad m =>
LocalTxMonitorServer txid tx slot m a
-> Server (LocalTxMonitor txid tx slot) 'NonPipelined 'StIdle m a
localTxMonitorServerPeer LocalTxMonitorServer (GenTxId blk) (GenTx blk) SlotNo m ()
hTxMonitorServer)

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

-- | A projection from 'NetworkApplication' to a server-side
-- 'OuroborosApplication' for the node-to-client protocols.
responder ::
     N.NodeToClientVersion
  -> Apps m (ConnectionId peer) b b b b a
  -> OuroborosApplicationWithMinimalCtx 'ResponderMode peer b m Void a
responder :: forall (m :: * -> *) peer b a.
NodeToClientVersion
-> Apps m (ConnectionId peer) b b b b a
-> OuroborosApplicationWithMinimalCtx
     'ResponderMode peer b m Void a
responder NodeToClientVersion
version Apps {App m (ConnectionId peer) b a
aChainSyncServer :: forall (m :: * -> *) peer bCS bTX bSQ bTM a.
Apps m peer bCS bTX bSQ bTM a -> App m peer bCS a
aTxSubmissionServer :: forall (m :: * -> *) peer bCS bTX bSQ bTM a.
Apps m peer bCS bTX bSQ bTM a -> App m peer bTX a
aStateQueryServer :: forall (m :: * -> *) peer bCS bTX bSQ bTM a.
Apps m peer bCS bTX bSQ bTM a -> App m peer bSQ a
aTxMonitorServer :: forall (m :: * -> *) peer bCS bTX bSQ bTM a.
Apps m peer bCS bTX bSQ bTM a -> App m peer bTM a
aChainSyncServer :: App m (ConnectionId peer) b a
aTxSubmissionServer :: App m (ConnectionId peer) b a
aStateQueryServer :: App m (ConnectionId peer) b a
aTxMonitorServer :: App m (ConnectionId peer) b a
..} =
    NodeToClientProtocols 'ResponderMode peer b m Void a
-> NodeToClientVersion
-> OuroborosApplicationWithMinimalCtx
     'ResponderMode peer b m Void a
forall (appType :: MuxMode) addr bytes (m :: * -> *) a b.
NodeToClientProtocols appType addr bytes m a b
-> NodeToClientVersion
-> OuroborosApplicationWithMinimalCtx appType addr bytes m a b
nodeToClientProtocols
      (NodeToClientProtocols {
          localChainSyncProtocol :: RunMiniProtocolWithMinimalCtx 'ResponderMode peer b m Void a
localChainSyncProtocol =
            MiniProtocolCb (ResponderContext peer) b m a
-> RunMiniProtocolWithMinimalCtx 'ResponderMode peer b m Void a
forall responderCtx bytes (m :: * -> *) b initiatorCtx.
MiniProtocolCb responderCtx bytes m b
-> RunMiniProtocol
     'ResponderMode initiatorCtx responderCtx bytes m Void b
ResponderProtocolOnly (MiniProtocolCb (ResponderContext peer) b m a
 -> RunMiniProtocolWithMinimalCtx 'ResponderMode peer b m Void a)
-> MiniProtocolCb (ResponderContext peer) b m a
-> RunMiniProtocolWithMinimalCtx 'ResponderMode peer b m Void a
forall a b. (a -> b) -> a -> b
$ (ResponderContext peer -> Channel m b -> m (a, Maybe b))
-> MiniProtocolCb (ResponderContext peer) b m a
forall ctx (m :: * -> *) bytes a.
(ctx -> Channel m bytes -> m (a, Maybe bytes))
-> MiniProtocolCb ctx bytes m a
MiniProtocolCb ((ResponderContext peer -> Channel m b -> m (a, Maybe b))
 -> MiniProtocolCb (ResponderContext peer) b m a)
-> (ResponderContext peer -> Channel m b -> m (a, Maybe b))
-> MiniProtocolCb (ResponderContext peer) b m a
forall a b. (a -> b) -> a -> b
$ \ResponderContext peer
ctx ->
              App m (ConnectionId peer) b a
aChainSyncServer (ResponderContext peer -> ConnectionId peer
forall addr. ResponderContext addr -> ConnectionId addr
rcConnectionId ResponderContext peer
ctx),
          localTxSubmissionProtocol :: RunMiniProtocolWithMinimalCtx 'ResponderMode peer b m Void a
localTxSubmissionProtocol =
            MiniProtocolCb (ResponderContext peer) b m a
-> RunMiniProtocolWithMinimalCtx 'ResponderMode peer b m Void a
forall responderCtx bytes (m :: * -> *) b initiatorCtx.
MiniProtocolCb responderCtx bytes m b
-> RunMiniProtocol
     'ResponderMode initiatorCtx responderCtx bytes m Void b
ResponderProtocolOnly (MiniProtocolCb (ResponderContext peer) b m a
 -> RunMiniProtocolWithMinimalCtx 'ResponderMode peer b m Void a)
-> MiniProtocolCb (ResponderContext peer) b m a
-> RunMiniProtocolWithMinimalCtx 'ResponderMode peer b m Void a
forall a b. (a -> b) -> a -> b
$ (ResponderContext peer -> Channel m b -> m (a, Maybe b))
-> MiniProtocolCb (ResponderContext peer) b m a
forall ctx (m :: * -> *) bytes a.
(ctx -> Channel m bytes -> m (a, Maybe bytes))
-> MiniProtocolCb ctx bytes m a
MiniProtocolCb ((ResponderContext peer -> Channel m b -> m (a, Maybe b))
 -> MiniProtocolCb (ResponderContext peer) b m a)
-> (ResponderContext peer -> Channel m b -> m (a, Maybe b))
-> MiniProtocolCb (ResponderContext peer) b m a
forall a b. (a -> b) -> a -> b
$ \ResponderContext peer
ctx ->
              App m (ConnectionId peer) b a
aTxSubmissionServer (ResponderContext peer -> ConnectionId peer
forall addr. ResponderContext addr -> ConnectionId addr
rcConnectionId ResponderContext peer
ctx),
          localStateQueryProtocol :: RunMiniProtocolWithMinimalCtx 'ResponderMode peer b m Void a
localStateQueryProtocol =
            MiniProtocolCb (ResponderContext peer) b m a
-> RunMiniProtocolWithMinimalCtx 'ResponderMode peer b m Void a
forall responderCtx bytes (m :: * -> *) b initiatorCtx.
MiniProtocolCb responderCtx bytes m b
-> RunMiniProtocol
     'ResponderMode initiatorCtx responderCtx bytes m Void b
ResponderProtocolOnly (MiniProtocolCb (ResponderContext peer) b m a
 -> RunMiniProtocolWithMinimalCtx 'ResponderMode peer b m Void a)
-> MiniProtocolCb (ResponderContext peer) b m a
-> RunMiniProtocolWithMinimalCtx 'ResponderMode peer b m Void a
forall a b. (a -> b) -> a -> b
$ (ResponderContext peer -> Channel m b -> m (a, Maybe b))
-> MiniProtocolCb (ResponderContext peer) b m a
forall ctx (m :: * -> *) bytes a.
(ctx -> Channel m bytes -> m (a, Maybe bytes))
-> MiniProtocolCb ctx bytes m a
MiniProtocolCb ((ResponderContext peer -> Channel m b -> m (a, Maybe b))
 -> MiniProtocolCb (ResponderContext peer) b m a)
-> (ResponderContext peer -> Channel m b -> m (a, Maybe b))
-> MiniProtocolCb (ResponderContext peer) b m a
forall a b. (a -> b) -> a -> b
$ \ResponderContext peer
ctx ->
              App m (ConnectionId peer) b a
aStateQueryServer (ResponderContext peer -> ConnectionId peer
forall addr. ResponderContext addr -> ConnectionId addr
rcConnectionId ResponderContext peer
ctx),
          localTxMonitorProtocol :: RunMiniProtocolWithMinimalCtx 'ResponderMode peer b m Void a
localTxMonitorProtocol =
            MiniProtocolCb (ResponderContext peer) b m a
-> RunMiniProtocolWithMinimalCtx 'ResponderMode peer b m Void a
forall responderCtx bytes (m :: * -> *) b initiatorCtx.
MiniProtocolCb responderCtx bytes m b
-> RunMiniProtocol
     'ResponderMode initiatorCtx responderCtx bytes m Void b
ResponderProtocolOnly (MiniProtocolCb (ResponderContext peer) b m a
 -> RunMiniProtocolWithMinimalCtx 'ResponderMode peer b m Void a)
-> MiniProtocolCb (ResponderContext peer) b m a
-> RunMiniProtocolWithMinimalCtx 'ResponderMode peer b m Void a
forall a b. (a -> b) -> a -> b
$ (ResponderContext peer -> Channel m b -> m (a, Maybe b))
-> MiniProtocolCb (ResponderContext peer) b m a
forall ctx (m :: * -> *) bytes a.
(ctx -> Channel m bytes -> m (a, Maybe bytes))
-> MiniProtocolCb ctx bytes m a
MiniProtocolCb ((ResponderContext peer -> Channel m b -> m (a, Maybe b))
 -> MiniProtocolCb (ResponderContext peer) b m a)
-> (ResponderContext peer -> Channel m b -> m (a, Maybe b))
-> MiniProtocolCb (ResponderContext peer) b m a
forall a b. (a -> b) -> a -> b
$ \ResponderContext peer
ctx ->
              App m (ConnectionId peer) b a
aTxMonitorServer (ResponderContext peer -> ConnectionId peer
forall addr. ResponderContext addr -> ConnectionId addr
rcConnectionId ResponderContext peer
ctx)
        })
      NodeToClientVersion
version