{-# 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           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 (..),
                     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 '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 (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.
(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 (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.
(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 (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
          }

-- | 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 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
                -- Otherwise, get the next block from the iterator (or fail).
                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)