{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

-- | Implement ChainSync and BlockFetch servers on top of just the immutable DB.
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.ResourceRegistry
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 qualified Network.Mux as Mux
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.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 (..)
  , 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 'Mux.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 'Mux.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 :: Mode) 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 =
      [ StartOnDemandOrEagerly
-> MiniProtocolNum
-> (MiniProtocolParameters -> MiniProtocolLimits)
-> MiniProtocolCb responderCtx ByteString m ()
-> MiniProtocol
     'ResponderMode initiatorCtx responderCtx ByteString m Void ()
forall {responderCtx} {bytes} {m :: * -> *} {b} {initiatorCtx}.
StartOnDemandOrEagerly
-> MiniProtocolNum
-> (MiniProtocolParameters -> MiniProtocolLimits)
-> MiniProtocolCb responderCtx bytes m b
-> MiniProtocol
     'ResponderMode initiatorCtx responderCtx bytes m Void b
mkMiniProtocol
          StartOnDemandOrEagerly
Mux.StartOnDemandAny
          MiniProtocolNum
N2N.keepAliveMiniProtocolNum
          MiniProtocolParameters -> MiniProtocolLimits
N2N.keepAliveProtocolLimits
          MiniProtocolCb responderCtx ByteString m ()
forall {ctx}. MiniProtocolCb ctx ByteString m ()
keepAliveProt
      , StartOnDemandOrEagerly
-> MiniProtocolNum
-> (MiniProtocolParameters -> MiniProtocolLimits)
-> MiniProtocolCb responderCtx ByteString m ()
-> MiniProtocol
     'ResponderMode initiatorCtx responderCtx ByteString m Void ()
forall {responderCtx} {bytes} {m :: * -> *} {b} {initiatorCtx}.
StartOnDemandOrEagerly
-> MiniProtocolNum
-> (MiniProtocolParameters -> MiniProtocolLimits)
-> MiniProtocolCb responderCtx bytes m b
-> MiniProtocol
     'ResponderMode initiatorCtx responderCtx bytes m Void b
mkMiniProtocol
          StartOnDemandOrEagerly
Mux.StartOnDemand
          MiniProtocolNum
N2N.chainSyncMiniProtocolNum
          MiniProtocolParameters -> MiniProtocolLimits
N2N.chainSyncProtocolLimits
          MiniProtocolCb responderCtx ByteString m ()
forall {ctx}. MiniProtocolCb ctx ByteString m ()
chainSyncProt
      , StartOnDemandOrEagerly
-> MiniProtocolNum
-> (MiniProtocolParameters -> MiniProtocolLimits)
-> MiniProtocolCb responderCtx ByteString m ()
-> MiniProtocol
     'ResponderMode initiatorCtx responderCtx ByteString m Void ()
forall {responderCtx} {bytes} {m :: * -> *} {b} {initiatorCtx}.
StartOnDemandOrEagerly
-> MiniProtocolNum
-> (MiniProtocolParameters -> MiniProtocolLimits)
-> MiniProtocolCb responderCtx bytes m b
-> MiniProtocol
     'ResponderMode initiatorCtx responderCtx bytes m Void b
mkMiniProtocol
          StartOnDemandOrEagerly
Mux.StartOnDemand
          MiniProtocolNum
N2N.blockFetchMiniProtocolNum
          MiniProtocolParameters -> MiniProtocolLimits
N2N.blockFetchProtocolLimits
          MiniProtocolCb responderCtx ByteString m ()
forall {ctx}. MiniProtocolCb ctx ByteString m ()
blockFetchProt
      , StartOnDemandOrEagerly
-> MiniProtocolNum
-> (MiniProtocolParameters -> MiniProtocolLimits)
-> MiniProtocolCb responderCtx ByteString m ()
-> MiniProtocol
     'ResponderMode initiatorCtx responderCtx ByteString m Void ()
forall {responderCtx} {bytes} {m :: * -> *} {b} {initiatorCtx}.
StartOnDemandOrEagerly
-> MiniProtocolNum
-> (MiniProtocolParameters -> MiniProtocolLimits)
-> MiniProtocolCb responderCtx bytes m b
-> MiniProtocol
     'ResponderMode initiatorCtx responderCtx bytes m Void b
mkMiniProtocol
          StartOnDemandOrEagerly
Mux.StartOnDemand
          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 bytes (m :: * -> *) 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 'NonPipelined 'StClient m ()
-> m ((), Maybe ByteString)
forall ps (st :: ps) (pr :: PeerRole) failure bytes (m :: * -> *)
       a.
(MonadThrow m, ShowProxy ps,
 forall (st' :: ps) stok. (stok ~ StateToken st') => Show stok,
 Show failure) =>
Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> Channel m bytes
-> Peer ps pr 'NonPipelined st m a
-> m (a, Maybe bytes)
runPeer 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 'NonPipelined 'StClient m ()
 -> m ((), Maybe ByteString))
-> Peer KeepAlive 'AsServer 'NonPipelined 'StClient m ()
-> m ((), Maybe ByteString)
forall a b. (a -> b) -> a -> b
$
            KeepAliveServer m ()
-> Peer KeepAlive 'AsServer 'NonPipelined 'StClient m ()
forall (m :: * -> *) a.
Functor m =>
KeepAliveServer m a -> Server KeepAlive 'NonPipelined '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 bytes (m :: * -> *) 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.
(MonadSTM m, MonadMask m, MonadThread 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
     'NonPipelined
     'StIdle
     m
     ()
-> m ((), Maybe ByteString)
forall ps (st :: ps) (pr :: PeerRole) failure bytes (m :: * -> *)
       a.
(MonadThrow m, ShowProxy ps,
 forall (st' :: ps) stok. (stok ~ StateToken st') => Show stok,
 Show failure) =>
Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> Channel m bytes
-> Peer ps pr 'NonPipelined st m a
-> m (a, Maybe bytes)
runPeer 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
   'NonPipelined
   'StIdle
   m
   ()
 -> m ((), Maybe ByteString))
-> (ResourceRegistry m
    -> Peer
         (ChainSync (SerialisedHeader blk) (Point blk) (Tip blk))
         'AsServer
         'NonPipelined
         '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
     'NonPipelined
     'StIdle
     m
     ()
forall header point tip (m :: * -> *) a.
Monad m =>
ChainSyncServer header point tip m a
-> Server (ChainSync header point tip) 'NonPipelined 'StIdle m a
chainSyncServerPeer
              (ChainSyncServer (SerialisedHeader blk) (Point blk) (Tip blk) m ()
 -> Peer
      (ChainSync (SerialisedHeader blk) (Point blk) (Tip blk))
      'AsServer
      'NonPipelined
      'StIdle
      m
      ())
-> (ResourceRegistry m
    -> ChainSyncServer
         (SerialisedHeader blk) (Point blk) (Tip blk) m ())
-> ResourceRegistry m
-> Peer
     (ChainSync (SerialisedHeader blk) (Point blk) (Tip blk))
     'AsServer
     'NonPipelined
     '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 bytes (m :: * -> *) 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.
(MonadSTM m, MonadMask m, MonadThread 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
     'NonPipelined
     'BFIdle
     m
     ()
-> m ((), Maybe ByteString)
forall ps (st :: ps) (pr :: PeerRole) failure bytes (m :: * -> *)
       a.
(MonadThrow m, ShowProxy ps,
 forall (st' :: ps) stok. (stok ~ StateToken st') => Show stok,
 Show failure) =>
Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> Channel m bytes
-> Peer ps pr 'NonPipelined st m a
-> m (a, Maybe bytes)
runPeer 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
   'NonPipelined
   'BFIdle
   m
   ()
 -> m ((), Maybe ByteString))
-> (ResourceRegistry m
    -> Peer
         (BlockFetch (Serialised blk) (Point blk))
         'AsServer
         'NonPipelined
         '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
     'NonPipelined
     'BFIdle
     m
     ()
forall block point (m :: * -> *) a.
Functor m =>
BlockFetchServer block point m a
-> Server (BlockFetch block point) 'NonPipelined 'BFIdle m a
blockFetchServerPeer
              (BlockFetchServer (Serialised blk) (Point blk) m ()
 -> Peer
      (BlockFetch (Serialised blk) (Point blk))
      'AsServer
      'NonPipelined
      'BFIdle
      m
      ())
-> (ResourceRegistry m
    -> BlockFetchServer (Serialised blk) (Point blk) m ())
-> ResourceRegistry m
-> Peer
     (BlockFetch (Serialised blk) (Point blk))
     'AsServer
     'NonPipelined
     '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 =
        -- never reply, there is no timeout
        (ctx -> Channel m bytes -> m (a, Maybe bytes))
-> MiniProtocolCb ctx bytes m a
forall ctx bytes (m :: * -> *) 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 :: StartOnDemandOrEagerly
-> MiniProtocolNum
-> (MiniProtocolParameters -> MiniProtocolLimits)
-> MiniProtocolCb responderCtx bytes m b
-> MiniProtocol
     'ResponderMode initiatorCtx responderCtx bytes m Void b
mkMiniProtocol StartOnDemandOrEagerly
miniProtocolStart 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
        , StartOnDemandOrEagerly
miniProtocolStart :: StartOnDemandOrEagerly
miniProtocolStart :: StartOnDemandOrEagerly
miniProtocolStart
        }

-- | The ChainSync specification requires sending a rollback instruction to the
-- intersection point right after an intersection has been negotiated. (Opening
-- a connection implicitly negotiates the Genesis point as the intersection.)
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 (Follower m blk (WithPoint blk a))
newImmutableDBFollower
  runChainSyncServer $
    chainSyncServerForFollower nullTracer getImmutableTip follower
 where
  newImmutableDBFollower :: m (Follower m blk (ChainDB.WithPoint blk a))
  newImmutableDBFollower :: m (Follower m blk (WithPoint blk a))
newImmutableDBFollower = do
    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
    varIntersection <-
      newTVarIO $ JustNegotiatedIntersection GenesisPoint

    let 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
            -- Otherwise, get the next block from the iterator (or fail).
            ChainSyncIntersection blk
AlreadySentRollbackToIntersection -> do
              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
              ImmutableDB.iteratorNext iterator >>= \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 = 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 [] = 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

    pure
      Follower
        { followerInstruction = Just <$> followerInstructionBlocking
        , followerInstructionBlocking
        , followerForward
        , 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)
-> (ImmDBServerException -> Bool)
-> Exception ImmDBServerException
SomeException -> Maybe ImmDBServerException
ImmDBServerException -> Bool
ImmDBServerException -> String
ImmDBServerException -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e)
-> (e -> String)
-> (e -> Bool)
-> Exception e
$ctoException :: ImmDBServerException -> SomeException
toException :: ImmDBServerException -> SomeException
$cfromException :: SomeException -> Maybe ImmDBServerException
fromException :: SomeException -> Maybe ImmDBServerException
$cdisplayException :: ImmDBServerException -> String
displayException :: ImmDBServerException -> String
$cbacktraceDesired :: ImmDBServerException -> Bool
backtraceDesired :: ImmDBServerException -> Bool
Exception