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

-- | Intended for qualified import
module Ouroboros.Consensus.Network.NodeToClient (
    -- * Handlers
    Handlers (..)
  , mkHandlers
    -- * Codecs
  , Codecs' (..)
  , Codecs
  , DefaultCodecs
  , ClientCodecs
  , defaultCodecs
  , clientCodecs
  , 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           Control.Tracer
import           Data.ByteString.Lazy (ByteString)
import           Data.Void (Void)

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.Codec
import           Ouroboros.Network.Driver
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
import           Ouroboros.Network.Protocol.LocalTxSubmission.Codec
import           Ouroboros.Network.Protocol.LocalTxSubmission.Server
import           Ouroboros.Network.Protocol.LocalTxSubmission.Type

import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.Ledger.Extended
import           Ouroboros.Consensus.Ledger.Query
import           Ouroboros.Consensus.Ledger.SupportsMempool
import           Ouroboros.Consensus.MiniProtocol.ChainSync.Server
import           Ouroboros.Consensus.MiniProtocol.LocalStateQuery.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           Ouroboros.Consensus.Util (ShowProxy)
import           Ouroboros.Consensus.Util.IOLike
import           Ouroboros.Consensus.Util.Orphans ()
import           Ouroboros.Consensus.Util.ResourceRegistry

import qualified Ouroboros.Consensus.Storage.ChainDB.API as ChainDB

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

-- | Protocol handlers for node-to-client (local) communication
data Handlers m peer blk = Handlers {
      Handlers m peer blk
-> ResourceRegistry m
-> ChainSyncServer (Serialised blk) (Point blk) (Tip blk) m ()
hChainSyncServer
        :: ResourceRegistry m
        -> ChainSyncServer (Serialised blk) (Point blk) (Tip blk) m ()

    , Handlers m peer blk
-> LocalTxSubmissionServer (GenTx blk) (ApplyTxErr blk) m ()
hTxSubmissionServer
        :: LocalTxSubmissionServer (GenTx blk) (ApplyTxErr blk) m ()

    , Handlers m peer blk
-> LocalStateQueryServer blk (Point blk) (Query blk) m ()
hStateQueryServer
        :: LocalStateQueryServer blk (Point blk) (Query blk) m ()
    }

mkHandlers
  :: forall m blk remotePeer localPeer.
     (IOLike m, LedgerSupportsMempool blk, QueryLedger blk)
  => NodeArgs   m remotePeer localPeer blk
  -> NodeKernel m remotePeer localPeer blk
  -> Handlers   m            localPeer blk
mkHandlers :: NodeArgs m remotePeer localPeer blk
-> NodeKernel m remotePeer localPeer blk
-> Handlers m localPeer blk
mkHandlers NodeArgs {TopLevelConfig blk
$sel:cfg:NodeArgs :: forall (m :: * -> *) remotePeer localPeer blk.
NodeArgs m remotePeer localPeer blk -> TopLevelConfig blk
cfg :: TopLevelConfig blk
cfg, Tracers m remotePeer localPeer blk
$sel:tracers:NodeArgs :: forall (m :: * -> *) remotePeer localPeer blk.
NodeArgs m remotePeer localPeer blk
-> Tracers m remotePeer localPeer blk
tracers :: Tracers m remotePeer localPeer blk
tracers} 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} =
    Handlers :: forall (m :: * -> *) peer blk.
(ResourceRegistry m
 -> ChainSyncServer (Serialised blk) (Point blk) (Tip blk) m ())
-> LocalTxSubmissionServer (GenTx blk) (ApplyTxErr blk) m ()
-> LocalStateQueryServer blk (Point blk) (Query blk) m ()
-> Handlers m peer blk
Handlers {
        hChainSyncServer :: ResourceRegistry m
-> ChainSyncServer (Serialised blk) (Point blk) (Tip blk) m ()
hChainSyncServer =
          Tracer m (TraceChainSyncServerEvent blk)
-> ChainDB m blk
-> ResourceRegistry m
-> ChainSyncServer (Serialised blk) (Point blk) (Tip blk) m ()
forall (m :: * -> *) blk.
(IOLike m, HasHeader (Header blk)) =>
Tracer m (TraceChainSyncServerEvent blk)
-> ChainDB m blk
-> ResourceRegistry m
-> ChainSyncServer (Serialised blk) (Point blk) (Tip blk) m ()
chainSyncBlocksServer
            (Tracers m remotePeer localPeer blk
-> Tracer m (TraceChainSyncServerEvent blk)
forall remotePeer localPeer blk (f :: * -> *).
Tracers' remotePeer localPeer blk f
-> f (TraceChainSyncServerEvent blk)
Node.chainSyncServerBlockTracer Tracers m remotePeer localPeer blk
tracers)
            ChainDB m blk
getChainDB
      , hTxSubmissionServer :: LocalTxSubmissionServer (GenTx blk) (ApplyTxErr blk) m ()
hTxSubmissionServer =
          Tracer m (TraceLocalTxSubmissionServerEvent blk)
-> Mempool m blk TicketNo
-> LocalTxSubmissionServer (GenTx blk) (ApplyTxErr blk) m ()
forall (m :: * -> *) blk idx.
MonadSTM m =>
Tracer m (TraceLocalTxSubmissionServerEvent blk)
-> Mempool m blk idx
-> LocalTxSubmissionServer (GenTx blk) (ApplyTxErr blk) m ()
localTxSubmissionServer
            (Tracers m remotePeer localPeer blk
-> Tracer m (TraceLocalTxSubmissionServerEvent blk)
forall remotePeer localPeer blk (f :: * -> *).
Tracers' remotePeer localPeer blk f
-> f (TraceLocalTxSubmissionServerEvent blk)
Node.localTxSubmissionServerTracer Tracers m remotePeer localPeer blk
tracers)
            Mempool m blk TicketNo
getMempool
      , hStateQueryServer :: LocalStateQueryServer blk (Point blk) (Query blk) m ()
hStateQueryServer =
          ExtLedgerCfg blk
-> (Point blk -> STM m (Maybe (ExtLedgerState blk)))
-> STM m (Point blk)
-> LocalStateQueryServer blk (Point blk) (Query blk) m ()
forall (m :: * -> *) blk.
(IOLike m, QueryLedger blk) =>
ExtLedgerCfg 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 -> Point blk -> STM m (Maybe (ExtLedgerState blk))
forall (m :: * -> *) blk.
ChainDB m blk -> Point blk -> STM m (Maybe (ExtLedgerState blk))
ChainDB.getPastLedger ChainDB m blk
getChainDB)
            (Point (Header blk) -> Point blk
forall b b'.
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)
      }

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

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

type Codecs blk e m bCS bTX bSQ =
    Codecs' blk (Serialised blk) e m bCS bTX bSQ
type DefaultCodecs blk m =
    Codecs' blk (Serialised blk) DeserialiseFailure m ByteString ByteString ByteString
type ClientCodecs blk  m =
    Codecs' blk blk DeserialiseFailure m 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 (Query blk)
                 )
              => CodecConfig blk
              -> BlockNodeToClientVersion blk
              -> DefaultCodecs blk m
defaultCodecs :: CodecConfig blk
-> BlockNodeToClientVersion blk -> DefaultCodecs blk m
defaultCodecs CodecConfig blk
ccfg BlockNodeToClientVersion blk
version = Codecs :: forall blk serialisedBlk e (m :: * -> *) bCS bTX bSQ.
Codec (ChainSync serialisedBlk (Point blk) (Tip blk)) e m bCS
-> Codec (LocalTxSubmission (GenTx blk) (ApplyTxErr blk)) e m bTX
-> Codec (LocalStateQuery blk (Point blk) (Query blk)) e m bSQ
-> Codecs' blk serialisedBlk e m bCS bTX bSQ
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
          forall s. Decoder s (Serialised blk)
forall a s. SerialiseNodeToClient 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))

    , 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
          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
          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
  m
  ByteString
cStateQueryCodec =
        (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
     m
     ByteString
forall k (block :: k) point (query :: * -> *) (m :: * -> *).
(MonadST m, ShowQuery query) =>
(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 m ByteString
codecLocalStateQuery
          ((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))
          (SomeSecond Query blk -> Encoding
forall a. SerialiseNodeToClient blk a => a -> Encoding
enc (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 (f :: * -> * -> *) a b. 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
<$> Decoder s (SomeSecond Query blk)
forall a s. SerialiseNodeToClient blk a => Decoder s a
dec)
          (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 blk (query :: * -> *) result.
SerialiseResult blk query =>
CodecConfig blk
-> BlockNodeToClientVersion blk
-> query result
-> forall s. Decoder s result
decodeResult CodecConfig blk
ccfg BlockNodeToClientVersion blk
version)
    }
  where
    p :: Proxy blk
    p :: Proxy blk
p = Proxy blk
forall k (t :: k). Proxy t
Proxy

    enc :: SerialiseNodeToClient blk a => a -> Encoding
    enc :: 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 s. 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 (Query blk)
                )
             => CodecConfig blk
             -> BlockNodeToClientVersion blk
             -> ClientCodecs blk m
clientCodecs :: CodecConfig blk
-> BlockNodeToClientVersion blk -> ClientCodecs blk m
clientCodecs CodecConfig blk
ccfg BlockNodeToClientVersion blk
version = Codecs :: forall blk serialisedBlk e (m :: * -> *) bCS bTX bSQ.
Codec (ChainSync serialisedBlk (Point blk) (Tip blk)) e m bCS
-> Codec (LocalTxSubmission (GenTx blk) (ApplyTxErr blk)) e m bTX
-> Codec (LocalStateQuery blk (Point blk) (Query blk)) e m bSQ
-> Codecs' blk serialisedBlk e m bCS bTX bSQ
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
          forall s. Decoder s blk
forall a s. SerialiseNodeToClient 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))

    , 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
          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
          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
  m
  ByteString
cStateQueryCodec =
        (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
     m
     ByteString
forall k (block :: k) point (query :: * -> *) (m :: * -> *).
(MonadST m, ShowQuery query) =>
(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 m ByteString
codecLocalStateQuery
          ((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))
          (SomeSecond Query blk -> Encoding
forall a. SerialiseNodeToClient blk a => a -> Encoding
enc (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 (f :: * -> * -> *) a b. 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
<$> Decoder s (SomeSecond Query blk)
forall a s. SerialiseNodeToClient blk a => Decoder s a
dec)
          (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 blk (query :: * -> *) result.
SerialiseResult blk query =>
CodecConfig blk
-> BlockNodeToClientVersion blk
-> query result
-> forall s. Decoder s result
decodeResult CodecConfig blk
ccfg BlockNodeToClientVersion blk
version)
    }
  where
    p :: Proxy blk
    p :: Proxy blk
p = Proxy blk
forall k (t :: k). Proxy t
Proxy

    enc :: SerialiseNodeToClient blk a => a -> Encoding
    enc :: 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 s. 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, QueryLedger 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)))
identityCodecs :: 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)))
identityCodecs = Codecs :: forall blk serialisedBlk e (m :: * -> *) bCS bTX bSQ.
Codec (ChainSync serialisedBlk (Point blk) (Tip blk)) e m bCS
-> Codec (LocalTxSubmission (GenTx blk) (ApplyTxErr blk)) e m bTX
-> Codec (LocalStateQuery blk (Point blk) (Query blk)) e m bSQ
-> Codecs' blk serialisedBlk e m bCS bTX bSQ
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 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
    , 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 k1 k2 (tx :: k1) (reject :: k2) (m :: * -> *).
Monad m =>
Codec
  (LocalTxSubmission tx reject)
  CodecFailure
  m
  (AnyMessage (LocalTxSubmission tx reject))
codecLocalTxSubmissionId
    , cStateQueryCodec :: Codec
  (LocalStateQuery blk (Point blk) (Query blk))
  CodecFailure
  m
  (AnyMessage (LocalStateQuery blk (Point blk) (Query blk)))
cStateQueryCodec   = (forall result1 result2.
 Query blk result1
 -> Query blk result2 -> Maybe (result1 :~: result2))
-> Codec
     (LocalStateQuery blk (Point blk) (Query blk))
     CodecFailure
     m
     (AnyMessage (LocalStateQuery blk (Point blk) (Query blk)))
forall k1 k2 (block :: k1) (point :: k2) (query :: * -> *)
       (m :: * -> *).
Monad m =>
(forall result1 result2.
 query result1 -> query result2 -> Maybe (result1 :~: result2))
-> Codec
     (LocalStateQuery block point query)
     CodecFailure
     m
     (AnyMessage (LocalStateQuery block point query))
codecLocalStateQueryId 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
    }

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

showTracers :: ( Show peer
               , Show (GenTx blk)
               , Show (ApplyTxErr blk)
               , ShowQuery (Query blk)
               , HasHeader 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 (Serialised blk) (Point blk) (Tip blk))))
-> f (TraceLabelPeer
        peer
        (TraceSendRecv (LocalTxSubmission (GenTx blk) (ApplyTxErr blk))))
-> f (TraceLabelPeer
        peer (TraceSendRecv (LocalStateQuery blk (Point blk) (Query blk))))
-> Tracers' peer blk e f
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))))
tStateQueryTracer   = Tracer m String
-> Tracer
     m
     (TraceLabelPeer
        peer (TraceSendRecv (LocalStateQuery blk (Point blk) (Query blk))))
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 a = Apps {
      -- | Start a local chain sync server.
      Apps m peer bCS bTX bSQ a -> App m peer bCS a
aChainSyncServer    :: App m peer bCS a

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

      -- | Start a local state query server.
    , Apps m peer bCS bTX bSQ a -> App m peer bSQ a
aStateQueryServer   :: App m peer bSQ a
    }

-- | Construct the 'NetworkApplication' for the node-to-client protocols
mkApps
  :: forall m peer blk e bCS bTX bSQ.
     ( IOLike m
     , Exception e
     , ShowProxy blk
     , ShowProxy (ApplyTxErr blk)
     , ShowProxy (Query blk)
     , ShowProxy (GenTx blk)
     , ShowQuery (Query blk)
     )
  => Tracers m peer blk e
  -> Codecs blk e m bCS bTX bSQ
  -> Handlers m peer blk
  -> Apps m peer bCS bTX bSQ ()
mkApps :: Tracers m peer blk e
-> Codecs blk e m bCS bTX bSQ
-> Handlers m peer blk
-> Apps m peer bCS bTX bSQ ()
mkApps Tracers {Tracer
  m
  (TraceLabelPeer
     peer
     (TraceSendRecv (ChainSync (Serialised blk) (Point blk) (Tip blk))))
Tracer
  m
  (TraceLabelPeer
     peer (TraceSendRecv (LocalStateQuery blk (Point blk) (Query blk))))
Tracer
  m
  (TraceLabelPeer
     peer
     (TraceSendRecv (LocalTxSubmission (GenTx blk) (ApplyTxErr blk))))
tStateQueryTracer :: Tracer
  m
  (TraceLabelPeer
     peer (TraceSendRecv (LocalStateQuery blk (Point blk) (Query blk))))
tTxSubmissionTracer :: Tracer
  m
  (TraceLabelPeer
     peer
     (TraceSendRecv (LocalTxSubmission (GenTx blk) (ApplyTxErr blk))))
tChainSyncTracer :: Tracer
  m
  (TraceLabelPeer
     peer
     (TraceSendRecv (ChainSync (Serialised blk) (Point blk) (Tip blk))))
tStateQueryTracer :: forall peer blk e (f :: * -> *).
Tracers' peer blk e f
-> f (TraceLabelPeer
        peer (TraceSendRecv (LocalStateQuery blk (Point blk) (Query blk))))
tTxSubmissionTracer :: forall peer blk e (f :: * -> *).
Tracers' peer blk e f
-> f (TraceLabelPeer
        peer
        (TraceSendRecv (LocalTxSubmission (GenTx blk) (ApplyTxErr blk))))
tChainSyncTracer :: forall peer blk e (f :: * -> *).
Tracers' peer blk e f
-> f (TraceLabelPeer
        peer
        (TraceSendRecv (ChainSync (Serialised blk) (Point blk) (Tip blk))))
..} Codecs {Codec (ChainSync (Serialised blk) (Point blk) (Tip blk)) e m bCS
Codec (LocalStateQuery blk (Point blk) (Query blk)) e m bSQ
Codec (LocalTxSubmission (GenTx blk) (ApplyTxErr blk)) e m bTX
cStateQueryCodec :: Codec (LocalStateQuery blk (Point blk) (Query blk)) e m bSQ
cTxSubmissionCodec :: Codec (LocalTxSubmission (GenTx blk) (ApplyTxErr blk)) e m bTX
cChainSyncCodec :: Codec (ChainSync (Serialised blk) (Point blk) (Tip blk)) e m bCS
cStateQueryCodec :: forall blk serialisedBlk e (m :: * -> *) bCS bTX bSQ.
Codecs' blk serialisedBlk e m bCS bTX bSQ
-> Codec (LocalStateQuery blk (Point blk) (Query blk)) e m bSQ
cTxSubmissionCodec :: forall blk serialisedBlk e (m :: * -> *) bCS bTX bSQ.
Codecs' blk serialisedBlk e m bCS bTX bSQ
-> Codec (LocalTxSubmission (GenTx blk) (ApplyTxErr blk)) e m bTX
cChainSyncCodec :: forall blk serialisedBlk e (m :: * -> *) bCS bTX bSQ.
Codecs' blk serialisedBlk e m bCS bTX bSQ
-> Codec (ChainSync serialisedBlk (Point blk) (Tip blk)) e m bCS
..} Handlers {LocalTxSubmissionServer (GenTx blk) (ApplyTxErr blk) m ()
LocalStateQueryServer blk (Point blk) (Query blk) m ()
ResourceRegistry m
-> ChainSyncServer (Serialised blk) (Point blk) (Tip blk) m ()
hStateQueryServer :: LocalStateQueryServer blk (Point blk) (Query blk) m ()
hTxSubmissionServer :: LocalTxSubmissionServer (GenTx blk) (ApplyTxErr blk) m ()
hChainSyncServer :: ResourceRegistry m
-> ChainSyncServer (Serialised blk) (Point blk) (Tip blk) m ()
hStateQueryServer :: forall (m :: * -> *) peer blk.
Handlers m peer blk
-> LocalStateQueryServer blk (Point blk) (Query blk) m ()
hTxSubmissionServer :: forall (m :: * -> *) peer blk.
Handlers m peer blk
-> LocalTxSubmissionServer (GenTx blk) (ApplyTxErr blk) m ()
hChainSyncServer :: forall (m :: * -> *) peer blk.
Handlers m peer blk
-> ResourceRegistry m
-> ChainSyncServer (Serialised blk) (Point blk) (Tip blk) m ()
..} =
    Apps :: forall (m :: * -> *) peer bCS bTX bSQ a.
App m peer bCS a
-> App m peer bTX a
-> App m peer bSQ a
-> Apps m peer bCS bTX bSQ a
Apps {peer -> Channel m bCS -> m ((), Maybe bCS)
peer -> Channel m bTX -> m ((), Maybe bTX)
peer -> Channel m bSQ -> m ((), Maybe bSQ)
aStateQueryServer :: peer -> Channel m bSQ -> m ((), Maybe bSQ)
aTxSubmissionServer :: peer -> Channel m bTX -> m ((), Maybe bTX)
aChainSyncServer :: peer -> Channel m bCS -> m ((), Maybe bCS)
aStateQueryServer :: peer -> Channel m bSQ -> m ((), Maybe bSQ)
aTxSubmissionServer :: peer -> Channel m bTX -> m ((), Maybe bTX)
aChainSyncServer :: peer -> Channel m bCS -> m ((), Maybe bCS)
..}
  where
    aChainSyncServer
      :: peer
      -> Channel m bCS
      -> m ((), Maybe bCS)
    aChainSyncServer :: peer -> Channel m bCS -> m ((), Maybe bCS)
aChainSyncServer peer
them Channel m bCS
channel = do
      String -> m ()
forall (m :: * -> *). MonadThread m => String -> m ()
labelThisThread String
"LocalChainSyncServer"
      (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 ->
        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
     'StIdle
     m
     ()
-> m ((), Maybe bCS)
forall ps (st :: ps) (pr :: PeerRole) failure bytes (m :: * -> *)
       a.
(MonadThrow m, Show failure,
 forall (st' :: ps). Show (ClientHasAgency st'),
 forall (st' :: ps). Show (ServerHasAgency st'), ShowProxy ps) =>
Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> Channel m bytes
-> Peer ps pr st m a
-> m (a, Maybe bytes)
runPeer
          ((TraceSendRecv (ChainSync (Serialised blk) (Point blk) (Tip blk))
 -> TraceLabelPeer
      peer
      (TraceSendRecv (ChainSync (Serialised blk) (Point blk) (Tip blk))))
-> Tracer
     m
     (TraceLabelPeer
        peer
        (TraceSendRecv (ChainSync (Serialised blk) (Point blk) (Tip blk))))
-> Tracer
     m
     (TraceSendRecv (ChainSync (Serialised blk) (Point blk) (Tip blk)))
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap (peer
-> TraceSendRecv (ChainSync (Serialised blk) (Point blk) (Tip blk))
-> TraceLabelPeer
     peer
     (TraceSendRecv (ChainSync (Serialised blk) (Point blk) (Tip blk)))
forall peerid a. peerid -> a -> TraceLabelPeer peerid a
TraceLabelPeer peer
them) Tracer
  m
  (TraceLabelPeer
     peer
     (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
   'StIdle
   m
   ()
 -> m ((), Maybe bCS))
-> Peer
     (ChainSync (Serialised blk) (Point blk) (Tip blk))
     'AsServer
     '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
     '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 (Serialised blk) (Point blk) (Tip blk) m ()
 -> Peer
      (ChainSync (Serialised blk) (Point blk) (Tip blk))
      'AsServer
      'StIdle
      m
      ())
-> ChainSyncServer (Serialised blk) (Point blk) (Tip blk) m ()
-> Peer
     (ChainSync (Serialised blk) (Point blk) (Tip blk))
     'AsServer
     'StIdle
     m
     ()
forall a b. (a -> b) -> a -> b
$ ResourceRegistry m
-> ChainSyncServer (Serialised blk) (Point blk) (Tip blk) m ()
hChainSyncServer ResourceRegistry m
registry

    aTxSubmissionServer
      :: peer
      -> Channel m bTX
      -> m ((), Maybe bTX)
    aTxSubmissionServer :: peer -> Channel m bTX -> m ((), Maybe bTX)
aTxSubmissionServer peer
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
     'StIdle
     m
     ()
-> m ((), Maybe bTX)
forall ps (st :: ps) (pr :: PeerRole) failure bytes (m :: * -> *)
       a.
(MonadThrow m, Show failure,
 forall (st' :: ps). Show (ClientHasAgency st'),
 forall (st' :: ps). Show (ServerHasAgency st'), ShowProxy ps) =>
Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> Channel m bytes
-> Peer ps pr st m a
-> m (a, Maybe bytes)
runPeer
        ((TraceSendRecv (LocalTxSubmission (GenTx blk) (ApplyTxErr blk))
 -> TraceLabelPeer
      peer
      (TraceSendRecv (LocalTxSubmission (GenTx blk) (ApplyTxErr blk))))
-> Tracer
     m
     (TraceLabelPeer
        peer
        (TraceSendRecv (LocalTxSubmission (GenTx blk) (ApplyTxErr blk))))
-> Tracer
     m (TraceSendRecv (LocalTxSubmission (GenTx blk) (ApplyTxErr blk)))
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap (peer
-> TraceSendRecv (LocalTxSubmission (GenTx blk) (ApplyTxErr blk))
-> TraceLabelPeer
     peer
     (TraceSendRecv (LocalTxSubmission (GenTx blk) (ApplyTxErr blk)))
forall peerid a. peerid -> a -> TraceLabelPeer peerid a
TraceLabelPeer peer
them) Tracer
  m
  (TraceLabelPeer
     peer
     (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
     'StIdle
     m
     ()
forall tx reject (m :: * -> *) a.
Monad m =>
m (LocalTxSubmissionServer tx reject m a)
-> Peer (LocalTxSubmission tx reject) 'AsServer 'StIdle m a
localTxSubmissionServerPeer (LocalTxSubmissionServer (GenTx blk) (ApplyTxErr blk) m ()
-> m (LocalTxSubmissionServer (GenTx blk) (ApplyTxErr blk) m ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure LocalTxSubmissionServer (GenTx blk) (ApplyTxErr blk) m ()
hTxSubmissionServer))

    aStateQueryServer
      :: peer
      -> Channel m bSQ
      -> m ((), Maybe bSQ)
    aStateQueryServer :: peer -> Channel m bSQ -> m ((), Maybe bSQ)
aStateQueryServer peer
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)))
-> Codec (LocalStateQuery blk (Point blk) (Query blk)) e m bSQ
-> Channel m bSQ
-> Peer
     (LocalStateQuery blk (Point blk) (Query blk))
     'AsServer
     'StIdle
     m
     ()
-> m ((), Maybe bSQ)
forall ps (st :: ps) (pr :: PeerRole) failure bytes (m :: * -> *)
       a.
(MonadThrow m, Show failure,
 forall (st' :: ps). Show (ClientHasAgency st'),
 forall (st' :: ps). Show (ServerHasAgency st'), ShowProxy ps) =>
Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> Channel m bytes
-> Peer ps pr st m a
-> m (a, Maybe bytes)
runPeer
        ((TraceSendRecv (LocalStateQuery blk (Point blk) (Query blk))
 -> TraceLabelPeer
      peer (TraceSendRecv (LocalStateQuery blk (Point blk) (Query blk))))
-> Tracer
     m
     (TraceLabelPeer
        peer (TraceSendRecv (LocalStateQuery blk (Point blk) (Query blk))))
-> Tracer
     m (TraceSendRecv (LocalStateQuery blk (Point blk) (Query blk)))
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap (peer
-> TraceSendRecv (LocalStateQuery blk (Point blk) (Query blk))
-> TraceLabelPeer
     peer (TraceSendRecv (LocalStateQuery blk (Point blk) (Query blk)))
forall peerid a. peerid -> a -> TraceLabelPeer peerid a
TraceLabelPeer peer
them) Tracer
  m
  (TraceLabelPeer
     peer (TraceSendRecv (LocalStateQuery blk (Point blk) (Query blk))))
tStateQueryTracer)
        Codec (LocalStateQuery blk (Point blk) (Query blk)) e m bSQ
cStateQueryCodec
        Channel m bSQ
channel
        (LocalStateQueryServer blk (Point blk) (Query blk) m ()
-> Peer
     (LocalStateQuery blk (Point blk) (Query blk))
     'AsServer
     'StIdle
     m
     ()
forall block point (query :: * -> *) (m :: * -> *) a.
Monad m =>
LocalStateQueryServer block point query m a
-> Peer (LocalStateQuery block point query) 'AsServer 'StIdle m a
localStateQueryServerPeer LocalStateQueryServer blk (Point blk) (Query blk) m ()
hStateQueryServer)

{-------------------------------------------------------------------------------
  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 a
  -> OuroborosApplication 'ResponderMode peer b m Void a
responder :: NodeToClientVersion
-> Apps m (ConnectionId peer) b b b a
-> OuroborosApplication 'ResponderMode peer b m Void a
responder NodeToClientVersion
version Apps {App m (ConnectionId peer) b a
aStateQueryServer :: App m (ConnectionId peer) b a
aTxSubmissionServer :: App m (ConnectionId peer) b a
aChainSyncServer :: App m (ConnectionId peer) b a
aStateQueryServer :: forall (m :: * -> *) peer bCS bTX bSQ a.
Apps m peer bCS bTX bSQ a -> App m peer bSQ a
aTxSubmissionServer :: forall (m :: * -> *) peer bCS bTX bSQ a.
Apps m peer bCS bTX bSQ a -> App m peer bTX a
aChainSyncServer :: forall (m :: * -> *) peer bCS bTX bSQ a.
Apps m peer bCS bTX bSQ a -> App m peer bCS a
..} =
    (ConnectionId peer
 -> STM m ControlMessage
 -> NodeToClientProtocols 'ResponderMode b m Void a)
-> NodeToClientVersion
-> OuroborosApplication 'ResponderMode peer b m Void a
forall addr (m :: * -> *) (appType :: MuxMode) bytes a b.
(ConnectionId addr
 -> STM m ControlMessage
 -> NodeToClientProtocols appType bytes m a b)
-> NodeToClientVersion
-> OuroborosApplication appType addr bytes m a b
nodeToClientProtocols
      (\ConnectionId peer
peer STM m ControlMessage
_shouldStopSTM -> NodeToClientProtocols :: 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
-> NodeToClientProtocols appType bytes m a b
NodeToClientProtocols {
          localChainSyncProtocol :: RunMiniProtocol 'ResponderMode b m Void a
localChainSyncProtocol =
            (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 (App m (ConnectionId peer) b a
aChainSyncServer ConnectionId peer
peer))),
          localTxSubmissionProtocol :: RunMiniProtocol 'ResponderMode b m Void a
localTxSubmissionProtocol =
            (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 (App m (ConnectionId peer) b a
aTxSubmissionServer ConnectionId peer
peer))),
          localStateQueryProtocol :: RunMiniProtocol 'ResponderMode b m Void a
localStateQueryProtocol =
            (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 (App m (ConnectionId peer) b a
aStateQueryServer ConnectionId peer
peer)))
        })
      NodeToClientVersion
version