{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module Cardano.Tools.ImmDBServer.MiniProtocols (immDBServer) where
import qualified Codec.CBOR.Decoding as CBOR
import qualified Codec.CBOR.Encoding as CBOR
import Control.Monad (forever)
import Control.Tracer
import Data.Bifunctor (bimap)
import qualified Data.ByteString.Lazy as BL
import Data.Functor ((<&>))
import qualified Data.Map.Strict as Map
import Data.Typeable (Typeable)
import Data.Void (Void)
import GHC.Generics (Generic)
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.MiniProtocol.BlockFetch.Server
(blockFetchServer')
import Ouroboros.Consensus.MiniProtocol.ChainSync.Server
(chainSyncServerForFollower)
import Ouroboros.Consensus.Network.NodeToNode (Codecs (..))
import qualified Ouroboros.Consensus.Network.NodeToNode as Consensus.N2N
import Ouroboros.Consensus.Node (stdVersionDataNTN)
import Ouroboros.Consensus.Node.NetworkProtocolVersion
import Ouroboros.Consensus.Node.Run (SerialiseNodeToNodeConstraints)
import Ouroboros.Consensus.Storage.ChainDB.API (Follower (..))
import qualified Ouroboros.Consensus.Storage.ChainDB.API as ChainDB
import Ouroboros.Consensus.Storage.Common
import Ouroboros.Consensus.Storage.ImmutableDB.API (ImmutableDB)
import qualified Ouroboros.Consensus.Storage.ImmutableDB.API as ImmutableDB
import Ouroboros.Consensus.Util
import Ouroboros.Consensus.Util.IOLike
import Ouroboros.Consensus.Util.ResourceRegistry
import Ouroboros.Network.Block (ChainUpdate (..), Tip (..))
import Ouroboros.Network.Driver (runPeer)
import Ouroboros.Network.KeepAlive (keepAliveServer)
import Ouroboros.Network.Magic (NetworkMagic)
import Ouroboros.Network.Mux (MiniProtocol (..), MiniProtocolCb (..),
MuxMode (..), OuroborosApplication (..),
OuroborosApplicationWithMinimalCtx, RunMiniProtocol (..))
import Ouroboros.Network.NodeToNode (NodeToNodeVersionData (..),
Versions (..))
import qualified Ouroboros.Network.NodeToNode as N2N
import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing (..))
import Ouroboros.Network.Protocol.BlockFetch.Server
import Ouroboros.Network.Protocol.ChainSync.Server
import Ouroboros.Network.Protocol.Handshake.Version (Version (..))
import Ouroboros.Network.Protocol.KeepAlive.Server
(keepAliveServerPeer)
immDBServer ::
forall m blk addr.
( IOLike m
, HasHeader blk
, ShowProxy blk
, SerialiseNodeToNodeConstraints blk
, SupportedNetworkProtocolVersion blk
)
=> CodecConfig blk
-> (NodeToNodeVersion -> addr -> CBOR.Encoding)
-> (NodeToNodeVersion -> forall s . CBOR.Decoder s addr)
-> ImmutableDB m blk
-> NetworkMagic
-> Versions NodeToNodeVersion NodeToNodeVersionData
(OuroborosApplicationWithMinimalCtx 'ResponderMode addr BL.ByteString m Void ())
immDBServer :: forall (m :: * -> *) blk addr.
(IOLike m, HasHeader blk, ShowProxy blk,
SerialiseNodeToNodeConstraints blk,
SupportedNetworkProtocolVersion blk) =>
CodecConfig blk
-> (NodeToNodeVersion -> addr -> Encoding)
-> (NodeToNodeVersion -> forall s. Decoder s addr)
-> ImmutableDB m blk
-> NetworkMagic
-> Versions
NodeToNodeVersion
NodeToNodeVersionData
(OuroborosApplicationWithMinimalCtx
'ResponderMode addr ByteString m Void ())
immDBServer CodecConfig blk
codecCfg NodeToNodeVersion -> addr -> Encoding
encAddr NodeToNodeVersion -> forall s. Decoder s addr
decAddr ImmutableDB m blk
immDB NetworkMagic
networkMagic = do
(NodeToNodeVersion
-> BlockNodeToNodeVersion blk
-> OuroborosApplicationWithMinimalCtx
'ResponderMode addr ByteString m Void ())
-> Versions
NodeToNodeVersion
NodeToNodeVersionData
(OuroborosApplicationWithMinimalCtx
'ResponderMode addr ByteString m Void ())
forall r.
(NodeToNodeVersion -> BlockNodeToNodeVersion blk -> r)
-> Versions NodeToNodeVersion NodeToNodeVersionData r
forAllVersions NodeToNodeVersion
-> BlockNodeToNodeVersion blk
-> OuroborosApplicationWithMinimalCtx
'ResponderMode addr ByteString m Void ()
application
where
forAllVersions ::
(NodeToNodeVersion -> BlockNodeToNodeVersion blk -> r)
-> Versions NodeToNodeVersion NodeToNodeVersionData r
forAllVersions :: forall r.
(NodeToNodeVersion -> BlockNodeToNodeVersion blk -> r)
-> Versions NodeToNodeVersion NodeToNodeVersionData r
forAllVersions NodeToNodeVersion -> BlockNodeToNodeVersion blk -> r
mkR =
Map NodeToNodeVersion (Version NodeToNodeVersionData r)
-> Versions NodeToNodeVersion NodeToNodeVersionData r
forall vNum vData r.
Map vNum (Version vData r) -> Versions vNum vData r
Versions
(Map NodeToNodeVersion (Version NodeToNodeVersionData r)
-> Versions NodeToNodeVersion NodeToNodeVersionData r)
-> Map NodeToNodeVersion (Version NodeToNodeVersionData r)
-> Versions NodeToNodeVersion NodeToNodeVersionData r
forall a b. (a -> b) -> a -> b
$ (NodeToNodeVersion
-> BlockNodeToNodeVersion blk -> Version NodeToNodeVersionData r)
-> Map NodeToNodeVersion (BlockNodeToNodeVersion blk)
-> Map NodeToNodeVersion (Version NodeToNodeVersionData r)
forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey NodeToNodeVersion
-> BlockNodeToNodeVersion blk -> Version NodeToNodeVersionData r
mkVersion
(Map NodeToNodeVersion (BlockNodeToNodeVersion blk)
-> Map NodeToNodeVersion (Version NodeToNodeVersionData r))
-> Map NodeToNodeVersion (BlockNodeToNodeVersion blk)
-> Map NodeToNodeVersion (Version NodeToNodeVersionData r)
forall a b. (a -> b) -> a -> b
$ Proxy blk -> Map NodeToNodeVersion (BlockNodeToNodeVersion blk)
forall blk.
SupportedNetworkProtocolVersion blk =>
Proxy blk -> Map NodeToNodeVersion (BlockNodeToNodeVersion blk)
supportedNodeToNodeVersions (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @blk)
where
mkVersion :: NodeToNodeVersion
-> BlockNodeToNodeVersion blk -> Version NodeToNodeVersionData r
mkVersion NodeToNodeVersion
version BlockNodeToNodeVersion blk
blockVersion = Version {
versionApplication :: NodeToNodeVersionData -> r
versionApplication = r -> NodeToNodeVersionData -> r
forall a b. a -> b -> a
const (r -> NodeToNodeVersionData -> r)
-> r -> NodeToNodeVersionData -> r
forall a b. (a -> b) -> a -> b
$ NodeToNodeVersion -> BlockNodeToNodeVersion blk -> r
mkR NodeToNodeVersion
version BlockNodeToNodeVersion blk
blockVersion
, versionData :: NodeToNodeVersionData
versionData =
NetworkMagic
-> DiffusionMode -> PeerSharing -> NodeToNodeVersionData
stdVersionDataNTN
NetworkMagic
networkMagic
DiffusionMode
N2N.InitiatorOnlyDiffusionMode
PeerSharing
PeerSharingDisabled
}
application ::
NodeToNodeVersion
-> BlockNodeToNodeVersion blk
-> OuroborosApplicationWithMinimalCtx 'ResponderMode addr BL.ByteString m Void ()
application :: NodeToNodeVersion
-> BlockNodeToNodeVersion blk
-> OuroborosApplicationWithMinimalCtx
'ResponderMode addr ByteString m Void ()
application NodeToNodeVersion
version BlockNodeToNodeVersion blk
blockVersion =
[MiniProtocol
'ResponderMode
(MinimalInitiatorContext addr)
(ResponderContext addr)
ByteString
m
Void
()]
-> OuroborosApplicationWithMinimalCtx
'ResponderMode addr ByteString m Void ()
forall (mode :: MuxMode) initiatorCtx responderCtx bytes
(m :: * -> *) a b.
[MiniProtocol mode initiatorCtx responderCtx bytes m a b]
-> OuroborosApplication mode initiatorCtx responderCtx bytes m a b
OuroborosApplication [MiniProtocol
'ResponderMode
(MinimalInitiatorContext addr)
(ResponderContext addr)
ByteString
m
Void
()]
forall {initiatorCtx} {responderCtx}.
[MiniProtocol
'ResponderMode initiatorCtx responderCtx ByteString m Void ()]
miniprotocols
where
miniprotocols :: [MiniProtocol
'ResponderMode initiatorCtx responderCtx ByteString m Void ()]
miniprotocols =
[ MiniProtocolNum
-> (MiniProtocolParameters -> MiniProtocolLimits)
-> MiniProtocolCb responderCtx ByteString m ()
-> MiniProtocol
'ResponderMode initiatorCtx responderCtx ByteString m Void ()
forall {responderCtx} {bytes} {m :: * -> *} {b} {initiatorCtx}.
MiniProtocolNum
-> (MiniProtocolParameters -> MiniProtocolLimits)
-> MiniProtocolCb responderCtx bytes m b
-> MiniProtocol
'ResponderMode initiatorCtx responderCtx bytes m Void b
mkMiniProtocol
MiniProtocolNum
N2N.keepAliveMiniProtocolNum
MiniProtocolParameters -> MiniProtocolLimits
N2N.keepAliveProtocolLimits
MiniProtocolCb responderCtx ByteString m ()
forall {ctx}. MiniProtocolCb ctx ByteString m ()
keepAliveProt
, MiniProtocolNum
-> (MiniProtocolParameters -> MiniProtocolLimits)
-> MiniProtocolCb responderCtx ByteString m ()
-> MiniProtocol
'ResponderMode initiatorCtx responderCtx ByteString m Void ()
forall {responderCtx} {bytes} {m :: * -> *} {b} {initiatorCtx}.
MiniProtocolNum
-> (MiniProtocolParameters -> MiniProtocolLimits)
-> MiniProtocolCb responderCtx bytes m b
-> MiniProtocol
'ResponderMode initiatorCtx responderCtx bytes m Void b
mkMiniProtocol
MiniProtocolNum
N2N.chainSyncMiniProtocolNum
MiniProtocolParameters -> MiniProtocolLimits
N2N.chainSyncProtocolLimits
MiniProtocolCb responderCtx ByteString m ()
forall {ctx}. MiniProtocolCb ctx ByteString m ()
chainSyncProt
, MiniProtocolNum
-> (MiniProtocolParameters -> MiniProtocolLimits)
-> MiniProtocolCb responderCtx ByteString m ()
-> MiniProtocol
'ResponderMode initiatorCtx responderCtx ByteString m Void ()
forall {responderCtx} {bytes} {m :: * -> *} {b} {initiatorCtx}.
MiniProtocolNum
-> (MiniProtocolParameters -> MiniProtocolLimits)
-> MiniProtocolCb responderCtx bytes m b
-> MiniProtocol
'ResponderMode initiatorCtx responderCtx bytes m Void b
mkMiniProtocol
MiniProtocolNum
N2N.blockFetchMiniProtocolNum
MiniProtocolParameters -> MiniProtocolLimits
N2N.blockFetchProtocolLimits
MiniProtocolCb responderCtx ByteString m ()
forall {ctx}. MiniProtocolCb ctx ByteString m ()
blockFetchProt
, MiniProtocolNum
-> (MiniProtocolParameters -> MiniProtocolLimits)
-> MiniProtocolCb responderCtx ByteString m ()
-> MiniProtocol
'ResponderMode initiatorCtx responderCtx ByteString m Void ()
forall {responderCtx} {bytes} {m :: * -> *} {b} {initiatorCtx}.
MiniProtocolNum
-> (MiniProtocolParameters -> MiniProtocolLimits)
-> MiniProtocolCb responderCtx bytes m b
-> MiniProtocol
'ResponderMode initiatorCtx responderCtx bytes m Void b
mkMiniProtocol
MiniProtocolNum
N2N.txSubmissionMiniProtocolNum
MiniProtocolParameters -> MiniProtocolLimits
N2N.txSubmissionProtocolLimits
MiniProtocolCb responderCtx ByteString m ()
forall {ctx} {bytes} {a}. MiniProtocolCb ctx bytes m a
txSubmissionProt
]
where
Consensus.N2N.Codecs {
Codec KeepAlive DeserialiseFailure m ByteString
cKeepAliveCodec :: Codec KeepAlive DeserialiseFailure m ByteString
cKeepAliveCodec :: forall blk addr e (m :: * -> *) bCS bSCS bBF bSBF bTX bKA bPS.
Codecs blk addr e m bCS bSCS bBF bSBF bTX bKA bPS
-> Codec KeepAlive e m bKA
cKeepAliveCodec
, Codec
(ChainSync (SerialisedHeader blk) (Point blk) (Tip blk))
DeserialiseFailure
m
ByteString
cChainSyncCodecSerialised :: Codec
(ChainSync (SerialisedHeader blk) (Point blk) (Tip blk))
DeserialiseFailure
m
ByteString
cChainSyncCodecSerialised :: forall blk addr e (m :: * -> *) bCS bSCS bBF bSBF bTX bKA bPS.
Codecs blk addr e m bCS bSCS bBF bSBF bTX bKA bPS
-> Codec
(ChainSync (SerialisedHeader blk) (Point blk) (Tip blk)) e m bSCS
cChainSyncCodecSerialised
, Codec
(BlockFetch (Serialised blk) (Point blk))
DeserialiseFailure
m
ByteString
cBlockFetchCodecSerialised :: Codec
(BlockFetch (Serialised blk) (Point blk))
DeserialiseFailure
m
ByteString
cBlockFetchCodecSerialised :: forall blk addr e (m :: * -> *) bCS bSCS bBF bSBF bTX bKA bPS.
Codecs blk addr e m bCS bSCS bBF bSBF bTX bKA bPS
-> Codec (BlockFetch (Serialised blk) (Point blk)) e m bSBF
cBlockFetchCodecSerialised
} =
CodecConfig blk
-> BlockNodeToNodeVersion blk
-> (NodeToNodeVersion -> addr -> Encoding)
-> (NodeToNodeVersion -> forall s. Decoder s addr)
-> NodeToNodeVersion
-> Codecs
blk
addr
DeserialiseFailure
m
ByteString
ByteString
ByteString
ByteString
ByteString
ByteString
ByteString
forall (m :: * -> *) blk addr.
(IOLike m, SerialiseNodeToNodeConstraints blk) =>
CodecConfig blk
-> BlockNodeToNodeVersion blk
-> (NodeToNodeVersion -> addr -> Encoding)
-> (NodeToNodeVersion -> forall s. Decoder s addr)
-> NodeToNodeVersion
-> Codecs
blk
addr
DeserialiseFailure
m
ByteString
ByteString
ByteString
ByteString
ByteString
ByteString
ByteString
Consensus.N2N.defaultCodecs CodecConfig blk
codecCfg BlockNodeToNodeVersion blk
blockVersion NodeToNodeVersion -> addr -> Encoding
encAddr NodeToNodeVersion -> Decoder s addr
NodeToNodeVersion -> forall s. Decoder s addr
decAddr NodeToNodeVersion
version
keepAliveProt :: MiniProtocolCb ctx ByteString m ()
keepAliveProt =
(ctx -> Channel m ByteString -> m ((), Maybe ByteString))
-> MiniProtocolCb ctx ByteString m ()
forall ctx (m :: * -> *) bytes a.
(ctx -> Channel m bytes -> m (a, Maybe bytes))
-> MiniProtocolCb ctx bytes m a
MiniProtocolCb ((ctx -> Channel m ByteString -> m ((), Maybe ByteString))
-> MiniProtocolCb ctx ByteString m ())
-> (ctx -> Channel m ByteString -> m ((), Maybe ByteString))
-> MiniProtocolCb ctx ByteString m ()
forall a b. (a -> b) -> a -> b
$ \ctx
_ctx Channel m ByteString
channel ->
Tracer m (TraceSendRecv KeepAlive)
-> Codec KeepAlive DeserialiseFailure m ByteString
-> Channel m ByteString
-> Peer KeepAlive 'AsServer 'StClient m ()
-> m ((), Maybe ByteString)
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 Tracer m (TraceSendRecv KeepAlive)
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer Codec KeepAlive DeserialiseFailure m ByteString
cKeepAliveCodec Channel m ByteString
channel
(Peer KeepAlive 'AsServer 'StClient m ()
-> m ((), Maybe ByteString))
-> Peer KeepAlive 'AsServer 'StClient m ()
-> m ((), Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ KeepAliveServer m () -> Peer KeepAlive 'AsServer 'StClient m ()
forall (m :: * -> *) a.
Functor m =>
KeepAliveServer m a -> Peer KeepAlive 'AsServer 'StClient m a
keepAliveServerPeer KeepAliveServer m ()
forall (m :: * -> *). Applicative m => KeepAliveServer m ()
keepAliveServer
chainSyncProt :: MiniProtocolCb ctx ByteString m ()
chainSyncProt =
(ctx -> Channel m ByteString -> m ((), Maybe ByteString))
-> MiniProtocolCb ctx ByteString m ()
forall ctx (m :: * -> *) bytes a.
(ctx -> Channel m bytes -> m (a, Maybe bytes))
-> MiniProtocolCb ctx bytes m a
MiniProtocolCb ((ctx -> Channel m ByteString -> m ((), Maybe ByteString))
-> MiniProtocolCb ctx ByteString m ())
-> (ctx -> Channel m ByteString -> m ((), Maybe ByteString))
-> MiniProtocolCb ctx ByteString m ()
forall a b. (a -> b) -> a -> b
$ \ctx
_ctx Channel m ByteString
channel ->
(ResourceRegistry m -> m ((), Maybe ByteString))
-> m ((), Maybe ByteString)
forall (m :: * -> *) a.
(IOLike m, HasCallStack) =>
(ResourceRegistry m -> m a) -> m a
withRegistry
((ResourceRegistry m -> m ((), Maybe ByteString))
-> m ((), Maybe ByteString))
-> (ResourceRegistry m -> m ((), Maybe ByteString))
-> m ((), Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ Tracer
m
(TraceSendRecv
(ChainSync (SerialisedHeader blk) (Point blk) (Tip blk)))
-> Codec
(ChainSync (SerialisedHeader blk) (Point blk) (Tip blk))
DeserialiseFailure
m
ByteString
-> Channel m ByteString
-> Peer
(ChainSync (SerialisedHeader blk) (Point blk) (Tip blk))
'AsServer
'StIdle
m
()
-> m ((), Maybe ByteString)
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 Tracer
m
(TraceSendRecv
(ChainSync (SerialisedHeader blk) (Point blk) (Tip blk)))
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer Codec
(ChainSync (SerialisedHeader blk) (Point blk) (Tip blk))
DeserialiseFailure
m
ByteString
cChainSyncCodecSerialised Channel m ByteString
channel
(Peer
(ChainSync (SerialisedHeader blk) (Point blk) (Tip blk))
'AsServer
'StIdle
m
()
-> m ((), Maybe ByteString))
-> (ResourceRegistry m
-> Peer
(ChainSync (SerialisedHeader blk) (Point blk) (Tip blk))
'AsServer
'StIdle
m
())
-> ResourceRegistry m
-> m ((), Maybe ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainSyncServer (SerialisedHeader blk) (Point blk) (Tip blk) m ()
-> Peer
(ChainSync (SerialisedHeader blk) (Point blk) (Tip blk))
'AsServer
'StIdle
m
()
forall header point tip (m :: * -> *) a.
Monad m =>
ChainSyncServer header point tip m a
-> Peer (ChainSync header point tip) 'AsServer 'StIdle m a
chainSyncServerPeer
(ChainSyncServer (SerialisedHeader blk) (Point blk) (Tip blk) m ()
-> Peer
(ChainSync (SerialisedHeader blk) (Point blk) (Tip blk))
'AsServer
'StIdle
m
())
-> (ResourceRegistry m
-> ChainSyncServer
(SerialisedHeader blk) (Point blk) (Tip blk) m ())
-> ResourceRegistry m
-> Peer
(ChainSync (SerialisedHeader blk) (Point blk) (Tip blk))
'AsServer
'StIdle
m
()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImmutableDB m blk
-> BlockComponent blk (WithPoint blk (SerialisedHeader blk))
-> ResourceRegistry m
-> ChainSyncServer
(SerialisedHeader blk) (Point blk) (Tip blk) m ()
forall (m :: * -> *) blk a.
(IOLike m, HasHeader blk) =>
ImmutableDB m blk
-> BlockComponent blk (WithPoint blk a)
-> ResourceRegistry m
-> ChainSyncServer a (Point blk) (Tip blk) m ()
chainSyncServer ImmutableDB m blk
immDB BlockComponent blk (WithPoint blk (SerialisedHeader blk))
forall blk.
BlockComponent blk (WithPoint blk (SerialisedHeader blk))
ChainDB.getSerialisedHeaderWithPoint
blockFetchProt :: MiniProtocolCb ctx ByteString m ()
blockFetchProt =
(ctx -> Channel m ByteString -> m ((), Maybe ByteString))
-> MiniProtocolCb ctx ByteString m ()
forall ctx (m :: * -> *) bytes a.
(ctx -> Channel m bytes -> m (a, Maybe bytes))
-> MiniProtocolCb ctx bytes m a
MiniProtocolCb ((ctx -> Channel m ByteString -> m ((), Maybe ByteString))
-> MiniProtocolCb ctx ByteString m ())
-> (ctx -> Channel m ByteString -> m ((), Maybe ByteString))
-> MiniProtocolCb ctx ByteString m ()
forall a b. (a -> b) -> a -> b
$ \ctx
_ctx Channel m ByteString
channel ->
(ResourceRegistry m -> m ((), Maybe ByteString))
-> m ((), Maybe ByteString)
forall (m :: * -> *) a.
(IOLike m, HasCallStack) =>
(ResourceRegistry m -> m a) -> m a
withRegistry
((ResourceRegistry m -> m ((), Maybe ByteString))
-> m ((), Maybe ByteString))
-> (ResourceRegistry m -> m ((), Maybe ByteString))
-> m ((), Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ Tracer m (TraceSendRecv (BlockFetch (Serialised blk) (Point blk)))
-> Codec
(BlockFetch (Serialised blk) (Point blk))
DeserialiseFailure
m
ByteString
-> Channel m ByteString
-> Peer
(BlockFetch (Serialised blk) (Point blk)) 'AsServer 'BFIdle m ()
-> m ((), Maybe ByteString)
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 Tracer m (TraceSendRecv (BlockFetch (Serialised blk) (Point blk)))
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer Codec
(BlockFetch (Serialised blk) (Point blk))
DeserialiseFailure
m
ByteString
cBlockFetchCodecSerialised Channel m ByteString
channel
(Peer
(BlockFetch (Serialised blk) (Point blk)) 'AsServer 'BFIdle m ()
-> m ((), Maybe ByteString))
-> (ResourceRegistry m
-> Peer
(BlockFetch (Serialised blk) (Point blk)) 'AsServer 'BFIdle m ())
-> ResourceRegistry m
-> m ((), Maybe ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockFetchServer (Serialised blk) (Point blk) m ()
-> Peer
(BlockFetch (Serialised blk) (Point blk)) 'AsServer 'BFIdle m ()
forall block point (m :: * -> *) a.
Functor m =>
BlockFetchServer block point m a
-> Peer (BlockFetch block point) 'AsServer 'BFIdle m a
blockFetchServerPeer
(BlockFetchServer (Serialised blk) (Point blk) m ()
-> Peer
(BlockFetch (Serialised blk) (Point blk)) 'AsServer 'BFIdle m ())
-> (ResourceRegistry m
-> BlockFetchServer (Serialised blk) (Point blk) m ())
-> ResourceRegistry m
-> Peer
(BlockFetch (Serialised blk) (Point blk)) 'AsServer 'BFIdle m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImmutableDB m blk
-> BlockComponent blk (WithPoint blk (Serialised blk))
-> ResourceRegistry m
-> BlockFetchServer (Serialised blk) (Point blk) m ()
forall (m :: * -> *) blk a.
(IOLike m, StandardHash blk, Typeable blk) =>
ImmutableDB m blk
-> BlockComponent blk (WithPoint blk a)
-> ResourceRegistry m
-> BlockFetchServer a (Point blk) m ()
blockFetchServer ImmutableDB m blk
immDB BlockComponent blk (WithPoint blk (Serialised blk))
forall blk. BlockComponent blk (WithPoint blk (Serialised blk))
ChainDB.getSerialisedBlockWithPoint
txSubmissionProt :: MiniProtocolCb ctx bytes m a
txSubmissionProt =
(ctx -> Channel m bytes -> m (a, Maybe bytes))
-> MiniProtocolCb ctx bytes m a
forall ctx (m :: * -> *) bytes a.
(ctx -> Channel m bytes -> m (a, Maybe bytes))
-> MiniProtocolCb ctx bytes m a
MiniProtocolCb ((ctx -> Channel m bytes -> m (a, Maybe bytes))
-> MiniProtocolCb ctx bytes m a)
-> (ctx -> Channel m bytes -> m (a, Maybe bytes))
-> MiniProtocolCb ctx bytes m a
forall a b. (a -> b) -> a -> b
$ \ctx
_ctx Channel m bytes
_channel -> m () -> m (a, Maybe bytes)
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (m () -> m (a, Maybe bytes)) -> m () -> m (a, Maybe bytes)
forall a b. (a -> b) -> a -> b
$ DiffTime -> m ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
10
mkMiniProtocol :: MiniProtocolNum
-> (MiniProtocolParameters -> MiniProtocolLimits)
-> MiniProtocolCb responderCtx bytes m b
-> MiniProtocol
'ResponderMode initiatorCtx responderCtx bytes m Void b
mkMiniProtocol MiniProtocolNum
miniProtocolNum MiniProtocolParameters -> MiniProtocolLimits
limits MiniProtocolCb responderCtx bytes m b
proto = MiniProtocol {
MiniProtocolNum
miniProtocolNum :: MiniProtocolNum
miniProtocolNum :: MiniProtocolNum
miniProtocolNum
, miniProtocolLimits :: MiniProtocolLimits
miniProtocolLimits = MiniProtocolParameters -> MiniProtocolLimits
limits MiniProtocolParameters
N2N.defaultMiniProtocolParameters
, miniProtocolRun :: RunMiniProtocol
'ResponderMode initiatorCtx responderCtx bytes m Void b
miniProtocolRun = MiniProtocolCb responderCtx bytes m b
-> RunMiniProtocol
'ResponderMode initiatorCtx responderCtx bytes m Void b
forall responderCtx bytes (m :: * -> *) b initiatorCtx.
MiniProtocolCb responderCtx bytes m b
-> RunMiniProtocol
'ResponderMode initiatorCtx responderCtx bytes m Void b
ResponderProtocolOnly MiniProtocolCb responderCtx bytes m b
proto
}
data ChainSyncIntersection blk =
JustNegotiatedIntersection !(Point blk)
| AlreadySentRollbackToIntersection
deriving stock ((forall x.
ChainSyncIntersection blk -> Rep (ChainSyncIntersection blk) x)
-> (forall x.
Rep (ChainSyncIntersection blk) x -> ChainSyncIntersection blk)
-> Generic (ChainSyncIntersection blk)
forall x.
Rep (ChainSyncIntersection blk) x -> ChainSyncIntersection blk
forall x.
ChainSyncIntersection blk -> Rep (ChainSyncIntersection blk) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall k (blk :: k) x.
Rep (ChainSyncIntersection blk) x -> ChainSyncIntersection blk
forall k (blk :: k) x.
ChainSyncIntersection blk -> Rep (ChainSyncIntersection blk) x
$cfrom :: forall k (blk :: k) x.
ChainSyncIntersection blk -> Rep (ChainSyncIntersection blk) x
from :: forall x.
ChainSyncIntersection blk -> Rep (ChainSyncIntersection blk) x
$cto :: forall k (blk :: k) x.
Rep (ChainSyncIntersection blk) x -> ChainSyncIntersection blk
to :: forall x.
Rep (ChainSyncIntersection blk) x -> ChainSyncIntersection blk
Generic)
deriving anyclass (Context -> ChainSyncIntersection blk -> IO (Maybe ThunkInfo)
Proxy (ChainSyncIntersection blk) -> String
(Context -> ChainSyncIntersection blk -> IO (Maybe ThunkInfo))
-> (Context -> ChainSyncIntersection blk -> IO (Maybe ThunkInfo))
-> (Proxy (ChainSyncIntersection blk) -> String)
-> NoThunks (ChainSyncIntersection blk)
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
forall k (blk :: k).
StandardHash blk =>
Context -> ChainSyncIntersection blk -> IO (Maybe ThunkInfo)
forall k (blk :: k).
StandardHash blk =>
Proxy (ChainSyncIntersection blk) -> String
$cnoThunks :: forall k (blk :: k).
StandardHash blk =>
Context -> ChainSyncIntersection blk -> IO (Maybe ThunkInfo)
noThunks :: Context -> ChainSyncIntersection blk -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall k (blk :: k).
StandardHash blk =>
Context -> ChainSyncIntersection blk -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> ChainSyncIntersection blk -> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall k (blk :: k).
StandardHash blk =>
Proxy (ChainSyncIntersection blk) -> String
showTypeOf :: Proxy (ChainSyncIntersection blk) -> String
NoThunks)
chainSyncServer ::
forall m blk a. (IOLike m, HasHeader blk)
=> ImmutableDB m blk
-> BlockComponent blk (ChainDB.WithPoint blk a)
-> ResourceRegistry m
-> ChainSyncServer a (Point blk) (Tip blk) m ()
chainSyncServer :: forall (m :: * -> *) blk a.
(IOLike m, HasHeader blk) =>
ImmutableDB m blk
-> BlockComponent blk (WithPoint blk a)
-> ResourceRegistry m
-> ChainSyncServer a (Point blk) (Tip blk) m ()
chainSyncServer ImmutableDB m blk
immDB BlockComponent blk (WithPoint blk a)
blockComponent ResourceRegistry m
registry = m (ServerStIdle a (Point blk) (Tip blk) m ())
-> ChainSyncServer a (Point blk) (Tip blk) m ()
forall header point tip (m :: * -> *) a.
m (ServerStIdle header point tip m a)
-> ChainSyncServer header point tip m a
ChainSyncServer (m (ServerStIdle a (Point blk) (Tip blk) m ())
-> ChainSyncServer a (Point blk) (Tip blk) m ())
-> m (ServerStIdle a (Point blk) (Tip blk) m ())
-> ChainSyncServer a (Point blk) (Tip blk) m ()
forall a b. (a -> b) -> a -> b
$ do
Follower m blk (WithPoint blk a)
follower <- m (Follower m blk (WithPoint blk a))
newImmutableDBFollower
ChainSyncServer a (Point blk) (Tip blk) m ()
-> m (ServerStIdle a (Point blk) (Tip blk) m ())
forall header point tip (m :: * -> *) a.
ChainSyncServer header point tip m a
-> m (ServerStIdle header point tip m a)
runChainSyncServer (ChainSyncServer a (Point blk) (Tip blk) m ()
-> m (ServerStIdle a (Point blk) (Tip blk) m ()))
-> ChainSyncServer a (Point blk) (Tip blk) m ()
-> m (ServerStIdle a (Point blk) (Tip blk) m ())
forall a b. (a -> b) -> a -> b
$
Tracer m (TraceChainSyncServerEvent blk)
-> STM m (Tip blk)
-> Follower m blk (WithPoint blk a)
-> ChainSyncServer a (Point blk) (Tip blk) m ()
forall (m :: * -> *) blk b.
IOLike m =>
Tracer m (TraceChainSyncServerEvent blk)
-> STM m (Tip blk)
-> Follower m blk (WithPoint blk b)
-> ChainSyncServer b (Point blk) (Tip blk) m ()
chainSyncServerForFollower Tracer m (TraceChainSyncServerEvent blk)
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer STM m (Tip blk)
getImmutableTip Follower m blk (WithPoint blk a)
follower
where
newImmutableDBFollower :: m (Follower m blk (ChainDB.WithPoint blk a))
newImmutableDBFollower :: m (Follower m blk (WithPoint blk a))
newImmutableDBFollower = do
StrictTVar m (Iterator m blk (WithPoint blk a))
varIterator <-
Iterator m blk (WithPoint blk a)
-> m (StrictTVar m (Iterator m blk (WithPoint blk a)))
forall (m :: * -> *) a.
(HasCallStack, MonadSTM m, NoThunks a) =>
a -> m (StrictTVar m a)
newTVarIO (Iterator m blk (WithPoint blk a)
-> m (StrictTVar m (Iterator m blk (WithPoint blk a))))
-> m (Iterator m blk (WithPoint blk a))
-> m (StrictTVar m (Iterator m blk (WithPoint blk a)))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ImmutableDB m blk
-> ResourceRegistry m
-> BlockComponent blk (WithPoint blk a)
-> m (Iterator m blk (WithPoint blk a))
forall (m :: * -> *) blk b.
(MonadSTM m, MonadThrow m, HasHeader blk, HasCallStack) =>
ImmutableDB m blk
-> ResourceRegistry m
-> BlockComponent blk b
-> m (Iterator m blk b)
ImmutableDB.streamAll ImmutableDB m blk
immDB ResourceRegistry m
registry BlockComponent blk (WithPoint blk a)
blockComponent
StrictTVar m (ChainSyncIntersection blk)
varIntersection <-
ChainSyncIntersection blk
-> m (StrictTVar m (ChainSyncIntersection blk))
forall (m :: * -> *) a.
(HasCallStack, MonadSTM m, NoThunks a) =>
a -> m (StrictTVar m a)
newTVarIO (ChainSyncIntersection blk
-> m (StrictTVar m (ChainSyncIntersection blk)))
-> ChainSyncIntersection blk
-> m (StrictTVar m (ChainSyncIntersection blk))
forall a b. (a -> b) -> a -> b
$ Point blk -> ChainSyncIntersection blk
forall {k} (blk :: k). Point blk -> ChainSyncIntersection blk
JustNegotiatedIntersection Point blk
forall {k} (block :: k). Point block
GenesisPoint
let followerInstructionBlocking :: m (ChainUpdate blk (WithPoint blk a))
followerInstructionBlocking =
StrictTVar m (ChainSyncIntersection blk)
-> m (ChainSyncIntersection blk)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> m a
readTVarIO StrictTVar m (ChainSyncIntersection blk)
varIntersection m (ChainSyncIntersection blk)
-> (ChainSyncIntersection blk
-> m (ChainUpdate blk (WithPoint blk a)))
-> m (ChainUpdate blk (WithPoint blk a))
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
JustNegotiatedIntersection Point blk
intersectionPt -> do
STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$
StrictTVar m (ChainSyncIntersection blk)
-> ChainSyncIntersection blk -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (ChainSyncIntersection blk)
varIntersection ChainSyncIntersection blk
forall {k} (blk :: k). ChainSyncIntersection blk
AlreadySentRollbackToIntersection
ChainUpdate blk (WithPoint blk a)
-> m (ChainUpdate blk (WithPoint blk a))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ChainUpdate blk (WithPoint blk a)
-> m (ChainUpdate blk (WithPoint blk a)))
-> ChainUpdate blk (WithPoint blk a)
-> m (ChainUpdate blk (WithPoint blk a))
forall a b. (a -> b) -> a -> b
$ Point blk -> ChainUpdate blk (WithPoint blk a)
forall {k} (block :: k) a. Point block -> ChainUpdate block a
RollBack Point blk
intersectionPt
ChainSyncIntersection blk
AlreadySentRollbackToIntersection -> do
Iterator m blk (WithPoint blk a)
iterator <- StrictTVar m (Iterator m blk (WithPoint blk a))
-> m (Iterator m blk (WithPoint blk a))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> m a
readTVarIO StrictTVar m (Iterator m blk (WithPoint blk a))
varIterator
Iterator m blk (WithPoint blk a)
-> HasCallStack => m (IteratorResult (WithPoint blk a))
forall (m :: * -> *) blk b.
Iterator m blk b -> HasCallStack => m (IteratorResult b)
ImmutableDB.iteratorNext Iterator m blk (WithPoint blk a)
iterator m (IteratorResult (WithPoint blk a))
-> (IteratorResult (WithPoint blk a)
-> m (ChainUpdate blk (WithPoint blk a)))
-> m (ChainUpdate blk (WithPoint blk a))
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
IteratorResult (WithPoint blk a)
ImmutableDB.IteratorExhausted -> do
Iterator m blk (WithPoint blk a) -> HasCallStack => m ()
forall (m :: * -> *) blk b.
Iterator m blk b -> HasCallStack => m ()
ImmutableDB.iteratorClose Iterator m blk (WithPoint blk a)
iterator
ImmDBServerException -> m (ChainUpdate blk (WithPoint blk a))
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO ImmDBServerException
ReachedImmutableTip
ImmutableDB.IteratorResult WithPoint blk a
a ->
ChainUpdate blk (WithPoint blk a)
-> m (ChainUpdate blk (WithPoint blk a))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ChainUpdate blk (WithPoint blk a)
-> m (ChainUpdate blk (WithPoint blk a)))
-> ChainUpdate blk (WithPoint blk a)
-> m (ChainUpdate blk (WithPoint blk a))
forall a b. (a -> b) -> a -> b
$ WithPoint blk a -> ChainUpdate blk (WithPoint blk a)
forall {k} (block :: k) a. a -> ChainUpdate block a
AddBlock WithPoint blk a
a
followerClose :: m ()
followerClose = Iterator m blk (WithPoint blk a) -> m ()
Iterator m blk (WithPoint blk a) -> HasCallStack => m ()
forall (m :: * -> *) blk b.
Iterator m blk b -> HasCallStack => m ()
ImmutableDB.iteratorClose (Iterator m blk (WithPoint blk a) -> m ())
-> m (Iterator m blk (WithPoint blk a)) -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< StrictTVar m (Iterator m blk (WithPoint blk a))
-> m (Iterator m blk (WithPoint blk a))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> m a
readTVarIO StrictTVar m (Iterator m blk (WithPoint blk a))
varIterator
followerForward :: [Point blk] -> m (Maybe (Point blk))
followerForward [] = Maybe (Point blk) -> m (Maybe (Point blk))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Point blk)
forall a. Maybe a
Nothing
followerForward (Point blk
pt : [Point blk]
pts) =
ImmutableDB m blk
-> ResourceRegistry m
-> BlockComponent blk (WithPoint blk a)
-> Point blk
-> m (Either (MissingBlock blk) (Iterator m blk (WithPoint blk a)))
forall (m :: * -> *) blk b.
(MonadSTM m, HasHeader blk, HasCallStack) =>
ImmutableDB m blk
-> ResourceRegistry m
-> BlockComponent blk b
-> Point blk
-> m (Either (MissingBlock blk) (Iterator m blk b))
ImmutableDB.streamAfterPoint ImmutableDB m blk
immDB ResourceRegistry m
registry BlockComponent blk (WithPoint blk a)
blockComponent Point blk
pt m (Either (MissingBlock blk) (Iterator m blk (WithPoint blk a)))
-> (Either (MissingBlock blk) (Iterator m blk (WithPoint blk a))
-> m (Maybe (Point blk)))
-> m (Maybe (Point blk))
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Left MissingBlock blk
_ -> [Point blk] -> m (Maybe (Point blk))
followerForward [Point blk]
pts
Right Iterator m blk (WithPoint blk a)
iterator -> do
m ()
followerClose
STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
StrictTVar m (Iterator m blk (WithPoint blk a))
-> Iterator m blk (WithPoint blk a) -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (Iterator m blk (WithPoint blk a))
varIterator Iterator m blk (WithPoint blk a)
iterator
StrictTVar m (ChainSyncIntersection blk)
-> ChainSyncIntersection blk -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (ChainSyncIntersection blk)
varIntersection (ChainSyncIntersection blk -> STM m ())
-> ChainSyncIntersection blk -> STM m ()
forall a b. (a -> b) -> a -> b
$ Point blk -> ChainSyncIntersection blk
forall {k} (blk :: k). Point blk -> ChainSyncIntersection blk
JustNegotiatedIntersection Point blk
pt
Maybe (Point blk) -> m (Maybe (Point blk))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Point blk) -> m (Maybe (Point blk)))
-> Maybe (Point blk) -> m (Maybe (Point blk))
forall a b. (a -> b) -> a -> b
$ Point blk -> Maybe (Point blk)
forall a. a -> Maybe a
Just Point blk
pt
Follower m blk (WithPoint blk a)
-> m (Follower m blk (WithPoint blk a))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Follower {
followerInstruction :: m (Maybe (ChainUpdate blk (WithPoint blk a)))
followerInstruction = ChainUpdate blk (WithPoint blk a)
-> Maybe (ChainUpdate blk (WithPoint blk a))
forall a. a -> Maybe a
Just (ChainUpdate blk (WithPoint blk a)
-> Maybe (ChainUpdate blk (WithPoint blk a)))
-> m (ChainUpdate blk (WithPoint blk a))
-> m (Maybe (ChainUpdate blk (WithPoint blk a)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (ChainUpdate blk (WithPoint blk a))
followerInstructionBlocking
, m (ChainUpdate blk (WithPoint blk a))
followerInstructionBlocking :: m (ChainUpdate blk (WithPoint blk a))
followerInstructionBlocking :: m (ChainUpdate blk (WithPoint blk a))
followerInstructionBlocking
, [Point blk] -> m (Maybe (Point blk))
followerForward :: [Point blk] -> m (Maybe (Point blk))
followerForward :: [Point blk] -> m (Maybe (Point blk))
followerForward
, m ()
followerClose :: m ()
followerClose :: m ()
followerClose
}
getImmutableTip :: STM m (Tip blk)
getImmutableTip :: STM m (Tip blk)
getImmutableTip = ImmutableDB m blk -> STM m (WithOrigin (Tip blk))
forall (m :: * -> *) blk.
HasCallStack =>
ImmutableDB m blk -> STM m (WithOrigin (Tip blk))
ImmutableDB.getTip ImmutableDB m blk
immDB STM m (WithOrigin (Tip blk))
-> (WithOrigin (Tip blk) -> Tip blk) -> STM m (Tip blk)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
WithOrigin (Tip blk)
Origin -> Tip blk
forall {k} (b :: k). Tip b
TipGenesis
NotOrigin Tip blk
tip -> SlotNo -> HeaderHash blk -> BlockNo -> Tip blk
forall {k} (b :: k). SlotNo -> HeaderHash b -> BlockNo -> Tip b
Tip SlotNo
tipSlotNo HeaderHash blk
tipHash BlockNo
tipBlockNo
where
ImmutableDB.Tip SlotNo
tipSlotNo IsEBB
_ BlockNo
tipBlockNo HeaderHash blk
tipHash = Tip blk
tip
blockFetchServer ::
forall m blk a. (IOLike m, StandardHash blk, Typeable blk)
=> ImmutableDB m blk
-> BlockComponent blk (ChainDB.WithPoint blk a)
-> ResourceRegistry m
-> BlockFetchServer a (Point blk) m ()
blockFetchServer :: forall (m :: * -> *) blk a.
(IOLike m, StandardHash blk, Typeable blk) =>
ImmutableDB m blk
-> BlockComponent blk (WithPoint blk a)
-> ResourceRegistry m
-> BlockFetchServer a (Point blk) m ()
blockFetchServer ImmutableDB m blk
immDB BlockComponent blk (WithPoint blk a)
blockComponent ResourceRegistry m
registry =
Tracer m (TraceBlockFetchServerEvent blk)
-> (StreamFrom blk
-> StreamTo blk
-> m (Either
(UnknownRange blk) (Iterator m blk (WithPoint blk a))))
-> BlockFetchServer a (Point blk) m ()
forall (m :: * -> *) blk a.
(IOLike m, StandardHash blk, Typeable blk) =>
Tracer m (TraceBlockFetchServerEvent blk)
-> (StreamFrom blk
-> StreamTo blk
-> m (Either
(UnknownRange blk) (Iterator m blk (WithPoint blk a))))
-> BlockFetchServer a (Point blk) m ()
blockFetchServer' Tracer m (TraceBlockFetchServerEvent blk)
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer StreamFrom blk
-> StreamTo blk
-> m (Either (UnknownRange blk) (Iterator m blk (WithPoint blk a)))
forall {blk}.
StreamFrom blk
-> StreamTo blk
-> m (Either (UnknownRange blk) (Iterator m blk (WithPoint blk a)))
stream
where
stream :: StreamFrom blk
-> StreamTo blk
-> m (Either (UnknownRange blk) (Iterator m blk (WithPoint blk a)))
stream StreamFrom blk
from StreamTo blk
to =
(MissingBlock blk -> UnknownRange blk)
-> (Iterator m blk (WithPoint blk a)
-> Iterator m blk (WithPoint blk a))
-> Either (MissingBlock blk) (Iterator m blk (WithPoint blk a))
-> Either (UnknownRange blk) (Iterator m blk (WithPoint blk a))
forall a b c d. (a -> b) -> (c -> d) -> Either a c -> Either b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap MissingBlock blk -> UnknownRange blk
forall {blk}. MissingBlock blk -> UnknownRange blk
convertError Iterator m blk (WithPoint blk a)
-> Iterator m blk (WithPoint blk a)
forall {m :: * -> *} {blk} {b} {blk}.
Functor m =>
Iterator m blk b -> Iterator m blk b
convertIterator
(Either (MissingBlock blk) (Iterator m blk (WithPoint blk a))
-> Either (UnknownRange blk) (Iterator m blk (WithPoint blk a)))
-> m (Either (MissingBlock blk) (Iterator m blk (WithPoint blk a)))
-> m (Either (UnknownRange blk) (Iterator m blk (WithPoint blk a)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImmutableDB m blk
-> ResourceRegistry m
-> BlockComponent blk (WithPoint blk a)
-> StreamFrom blk
-> StreamTo blk
-> m (Either (MissingBlock blk) (Iterator m blk (WithPoint blk a)))
forall (m :: * -> *) blk b.
HasCallStack =>
ImmutableDB m blk
-> ResourceRegistry m
-> BlockComponent blk b
-> StreamFrom blk
-> StreamTo blk
-> m (Either (MissingBlock blk) (Iterator m blk b))
ImmutableDB.stream ImmutableDB m blk
immDB ResourceRegistry m
registry BlockComponent blk (WithPoint blk a)
blockComponent StreamFrom blk
from StreamTo blk
to
convertError :: MissingBlock blk -> UnknownRange blk
convertError = RealPoint blk -> UnknownRange blk
forall blk. RealPoint blk -> UnknownRange blk
ChainDB.MissingBlock (RealPoint blk -> UnknownRange blk)
-> (MissingBlock blk -> RealPoint blk)
-> MissingBlock blk
-> UnknownRange blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MissingBlock blk -> RealPoint blk
forall blk. MissingBlock blk -> RealPoint blk
ImmutableDB.missingBlockPoint
convertIterator :: Iterator m blk b -> Iterator m blk b
convertIterator Iterator m blk b
iterator = ChainDB.Iterator {
iteratorNext :: m (IteratorResult blk b)
ChainDB.iteratorNext = Iterator m blk b -> HasCallStack => m (IteratorResult b)
forall (m :: * -> *) blk b.
Iterator m blk b -> HasCallStack => m (IteratorResult b)
ImmutableDB.iteratorNext Iterator m blk b
iterator m (IteratorResult b)
-> (IteratorResult b -> IteratorResult blk b)
-> m (IteratorResult blk b)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
ImmutableDB.IteratorResult b
b -> b -> IteratorResult blk b
forall blk b. b -> IteratorResult blk b
ChainDB.IteratorResult b
b
IteratorResult b
ImmutableDB.IteratorExhausted -> IteratorResult blk b
forall blk b. IteratorResult blk b
ChainDB.IteratorExhausted
, iteratorClose :: m ()
ChainDB.iteratorClose = Iterator m blk b -> HasCallStack => m ()
forall (m :: * -> *) blk b.
Iterator m blk b -> HasCallStack => m ()
ImmutableDB.iteratorClose Iterator m blk b
iterator
}
data ImmDBServerException =
ReachedImmutableTip
| TriedToFetchGenesis
deriving stock (Int -> ImmDBServerException -> ShowS
[ImmDBServerException] -> ShowS
ImmDBServerException -> String
(Int -> ImmDBServerException -> ShowS)
-> (ImmDBServerException -> String)
-> ([ImmDBServerException] -> ShowS)
-> Show ImmDBServerException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ImmDBServerException -> ShowS
showsPrec :: Int -> ImmDBServerException -> ShowS
$cshow :: ImmDBServerException -> String
show :: ImmDBServerException -> String
$cshowList :: [ImmDBServerException] -> ShowS
showList :: [ImmDBServerException] -> ShowS
Show)
deriving anyclass (Show ImmDBServerException
Typeable ImmDBServerException
(Typeable ImmDBServerException, Show ImmDBServerException) =>
(ImmDBServerException -> SomeException)
-> (SomeException -> Maybe ImmDBServerException)
-> (ImmDBServerException -> String)
-> Exception ImmDBServerException
SomeException -> Maybe ImmDBServerException
ImmDBServerException -> String
ImmDBServerException -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e) -> (e -> String) -> Exception e
$ctoException :: ImmDBServerException -> SomeException
toException :: ImmDBServerException -> SomeException
$cfromException :: SomeException -> Maybe ImmDBServerException
fromException :: SomeException -> Maybe ImmDBServerException
$cdisplayException :: ImmDBServerException -> String
displayException :: ImmDBServerException -> String
Exception)