{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE NoFieldSelectors #-}

module Cardano.Rpc.Server.NodeKernelAccess
  ( Type.NodeKernelAccess
  , nodeKernelSystemStart
  , securityParam
  , genesisConfig
  , readEraHistory
  , readHardForkSummary
  , readChainTipHeader
  , GenesisBundle (..)
  , mkNodeKernelAccess
  , fetchBlock
  , grabNodeKernelAccess
  , ChainChange (..)
  , ChainFollower (..)
  , withFollower
  )
where

import Cardano.Api
import Cardano.Api.Consensus qualified as Consensus
import Cardano.Rpc.Server.Internal.Monad (MonadRpc, grab)
import Cardano.Rpc.Server.Internal.TimedCache (newTimedCache)
import Cardano.Rpc.Server.Internal.Tracing
import Cardano.Rpc.Server.NodeKernelAccess.Internal.Type (GenesisBundle (..))
import Cardano.Rpc.Server.NodeKernelAccess.Internal.Type qualified as Type

import Ouroboros.Consensus.Cardano.Block (CardanoEras)
import Ouroboros.Consensus.HardFork.History qualified as History

import RIO (MonadUnliftIO, atomically, bracket, throwIO, withRunInIO)

import Control.Tracer (Tracer, traceWith)
import Data.ByteString (ByteString)
import Data.ByteString.Lazy qualified as BSL
import Data.IORef
import Data.SOP.Strict (NP (..))
import Data.Text (pack)
import Data.Time.Clock (DiffTime)
-- Imported narrowly: grpc-spec exports an unrelated ':*' which would otherwise
-- make the 'NP' pattern match in 'readGenesisBundle' ambiguous.
import Network.GRPC.Spec (GrpcError (..), GrpcException (..))

-- | Construct 'NodeKernelAccess' from a consensus 'Consensus.NodeKernel'.
-- Returns 'Nothing' and traces the block type for non-Cardano block types.
mkNodeKernelAccess
  :: MonadIO m
  => Tracer m TraceRpc
  -- ^ Tracer for RPC events
  -> GenesisHashShelley
  -- ^ Boot-time Shelley genesis hash
  -> ShelleyGenesisFile In
  -- ^ Path to the Shelley genesis file the node was configured with
  -> Consensus.BlockType blk
  -- ^ Block type witness
  -> Consensus.NodeKernel IO addrNTN addrNTC blk
  -- ^ Consensus node kernel
  -> m (Maybe Type.NodeKernelAccess)
mkNodeKernelAccess :: forall (m :: * -> *) blk addrNTN addrNTC.
MonadIO m =>
Tracer m TraceRpc
-> GenesisHashShelley
-> ShelleyGenesisFile 'In
-> BlockType blk
-> NodeKernel IO addrNTN addrNTC blk
-> m (Maybe NodeKernelAccess)
mkNodeKernelAccess Tracer m TraceRpc
tracer GenesisHashShelley
shelleyGenesisHash ShelleyGenesisFile 'In
shelleyGenesisFile BlockType blk
blockType NodeKernel IO addrNTN addrNTC blk
kernel = case BlockType blk
blockType of
  BlockType blk
Consensus.CardanoBlockType -> do
    genesisBundle <- GenesisHashShelley
-> ShelleyGenesisFile 'In
-> TopLevelConfig (HardForkBlock (CardanoEras StandardCrypto))
-> m GenesisBundle
forall (m :: * -> *).
MonadIO m =>
GenesisHashShelley
-> ShelleyGenesisFile 'In
-> TopLevelConfig (HardForkBlock (CardanoEras StandardCrypto))
-> m GenesisBundle
readGenesisBundle GenesisHashShelley
shelleyGenesisHash ShelleyGenesisFile 'In
shelleyGenesisFile TopLevelConfig blk
TopLevelConfig (HardForkBlock (CardanoEras StandardCrypto))
topLevelConfig
    pure $
      Just
        Type.NodeKernelAccess
          { Type.chainDb = chainDb
          , Type.systemStart = Consensus.nodeSystemStart topLevelConfig
          , Type.readHardForkSummary = readHardForkSummary'
          , Type.securityParam = Consensus.configSecurityParam topLevelConfig
          , Type.genesisConfig = genesisBundle
          }
   where
    chainDb :: ChainDB IO blk
chainDb = NodeKernel IO addrNTN addrNTC blk -> ChainDB IO blk
forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernel m addrNTN addrNTC blk -> ChainDB m blk
Consensus.getChainDB NodeKernel IO addrNTN addrNTC blk
kernel
    topLevelConfig :: TopLevelConfig blk
topLevelConfig = NodeKernel IO addrNTN addrNTC blk -> TopLevelConfig blk
forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernel m addrNTN addrNTC blk -> TopLevelConfig blk
Consensus.getTopLevelConfig NodeKernel IO addrNTN addrNTC blk
kernel
    ledgerConfig :: LedgerConfig blk
ledgerConfig = TopLevelConfig blk -> LedgerConfig blk
forall blk. TopLevelConfig blk -> LedgerConfig blk
Consensus.configLedger TopLevelConfig blk
topLevelConfig
    -- Primed because 'Cardano.Rpc.Server.NodeKernelAccess' also exports an
    -- accessor of the same name; this is the local action that feeds the
    -- corresponding record field above.
    --
    -- Read the current ledger state (cheap STM TVar read) and recompute
    -- the era summary on every call - O(number_of_eras).
    -- This is the same approach consensus uses for GetInterpreter queries
    -- (interpretQueryHardFork); neither path caches the summary.
    -- RunWithCachedSummary exists but is private to the blockchain time thread.
    readHardForkSummary'
      :: MonadIO n
      => n (History.Summary (CardanoEras Consensus.StandardCrypto))
    readHardForkSummary' :: forall (m :: * -> *).
MonadIO m =>
m (Summary (CardanoEras StandardCrypto))
readHardForkSummary' = IO (Summary (CardanoEras StandardCrypto))
-> n (Summary (CardanoEras StandardCrypto))
forall a. IO a -> n a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Summary (CardanoEras StandardCrypto))
 -> n (Summary (CardanoEras StandardCrypto)))
-> IO (Summary (CardanoEras StandardCrypto))
-> n (Summary (CardanoEras StandardCrypto))
forall a b. (a -> b) -> a -> b
$ do
      extLedger <- STM
  (ExtLedgerState
     (HardForkBlock (CardanoEras StandardCrypto)) EmptyMK)
-> IO
     (ExtLedgerState
        (HardForkBlock (CardanoEras StandardCrypto)) EmptyMK)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM
   (ExtLedgerState
      (HardForkBlock (CardanoEras StandardCrypto)) EmptyMK)
 -> IO
      (ExtLedgerState
         (HardForkBlock (CardanoEras StandardCrypto)) EmptyMK))
-> STM
     (ExtLedgerState
        (HardForkBlock (CardanoEras StandardCrypto)) EmptyMK)
-> IO
     (ExtLedgerState
        (HardForkBlock (CardanoEras StandardCrypto)) EmptyMK)
forall a b. (a -> b) -> a -> b
$ ChainDB IO blk -> STM IO (ExtLedgerState blk EmptyMK)
forall (m :: * -> *) blk.
ChainDB m blk -> STM m (ExtLedgerState blk EmptyMK)
Consensus.getCurrentLedger ChainDB IO blk
chainDb
      pure $ Consensus.hardForkSummary ledgerConfig (Consensus.ledgerState extLedger)
  BlockType blk
_ -> do
    -- unsupported block type
    Tracer m TraceRpc -> TraceRpc -> m ()
forall (m :: * -> *) a. Monad m => Tracer m a -> a -> m ()
traceWith Tracer m TraceRpc
tracer (TraceRpc -> m ()) -> (String -> TraceRpc) -> String -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TraceRpcNodeKernelAccess -> TraceRpc
forall t s. Inject t s => t -> s
inject (TraceRpcNodeKernelAccess -> TraceRpc)
-> (String -> TraceRpcNodeKernelAccess) -> String -> TraceRpc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> TraceRpcNodeKernelAccess
TraceRpcUnsupportedBlockType (Text -> TraceRpcNodeKernelAccess)
-> (String -> Text) -> String -> TraceRpcNodeKernelAccess
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ BlockType blk -> String
forall a. Show a => a -> String
show BlockType blk
blockType
    Maybe NodeKernelAccess -> m (Maybe NodeKernelAccess)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe NodeKernelAccess
forall a. Maybe a
Nothing

-- | How long the resolved Shelley genesis is kept after the request that last
-- needed it: five minutes.
--
-- Long enough that a client walking through several genesis queries pays the
-- re-read once, short enough that an idle node is back to retaining nothing
-- soon after being left alone.
shelleyGenesisExpiryTimeout :: DiffTime
shelleyGenesisExpiryTimeout :: DiffTime
shelleyGenesisExpiryTimeout = DiffTime
5 DiffTime -> DiffTime -> DiffTime
forall a. Num a => a -> a -> a
* DiffTime
60

-- | Gather the network's genesis configuration out of the node kernel's ledger
-- config, so that the RPC server shares the node's own genesis values instead of
-- holding a second copy alive for the lifetime of the process.
--
-- The per-era ledger configs are matched positionally and exhaustively, so a new
-- Cardano era is a compile error here rather than a silently misread genesis.
-- The Shelley slot is matched but not read. The node only has a compacted copy
-- with the initial funds erased, so the file is the only useful source and the
-- cache reads it when a caller asks.
--
-- The only thing allocated here is that empty cache. Nothing is read from disk
-- and no thread is started.
readGenesisBundle
  :: MonadIO m
  => GenesisHashShelley
  -> ShelleyGenesisFile In
  -> Consensus.TopLevelConfig (Consensus.CardanoBlock Consensus.StandardCrypto)
  -> m GenesisBundle
readGenesisBundle :: forall (m :: * -> *).
MonadIO m =>
GenesisHashShelley
-> ShelleyGenesisFile 'In
-> TopLevelConfig (HardForkBlock (CardanoEras StandardCrypto))
-> m GenesisBundle
readGenesisBundle GenesisHashShelley
shelleyGenesisHash ShelleyGenesisFile 'In
shelleyGenesisFile TopLevelConfig (HardForkBlock (CardanoEras StandardCrypto))
topLevelConfig =
  case PerEraLedgerConfig (CardanoEras StandardCrypto)
-> NP WrapPartialLedgerConfig (CardanoEras StandardCrypto)
forall (xs :: [*]).
PerEraLedgerConfig xs -> NP WrapPartialLedgerConfig xs
Consensus.getPerEraLedgerConfig PerEraLedgerConfig (CardanoEras StandardCrypto)
perEraLedgerConfig of
    Consensus.WrapPartialLedgerConfig PartialLedgerConfig x
byron
      :* WrapPartialLedgerConfig x
_shelley
      :* WrapPartialLedgerConfig x
_allegra
      :* WrapPartialLedgerConfig x
_mary
      :* Consensus.WrapPartialLedgerConfig PartialLedgerConfig x
alonzo
      :* WrapPartialLedgerConfig x
_babbage
      :* Consensus.WrapPartialLedgerConfig PartialLedgerConfig x
conway
      :* WrapPartialLedgerConfig x
_dijkstra
      :* NP WrapPartialLedgerConfig xs1
Nil -> do
        shelleyGenesisCache <- DiffTime -> m (TimedCache ShelleyGenesis)
forall (m :: * -> *) a. MonadIO m => DiffTime -> m (TimedCache a)
newTimedCache DiffTime
shelleyGenesisExpiryTimeout
        pure
          GenesisBundle
            { byronConfig = Consensus.byronLedgerConfig byron
            , shelleyGenesisHash
            , shelleyGenesis = (shelleyGenesisFile, shelleyGenesisCache)
            , alonzoGenesis =
                Consensus.shelleyLedgerTranslationContext $ Consensus.shelleyLedgerConfig alonzo
            , conwayGenesis =
                Consensus.shelleyLedgerTranslationContext $ Consensus.shelleyLedgerConfig conway
            }
 where
  perEraLedgerConfig :: PerEraLedgerConfig (CardanoEras StandardCrypto)
perEraLedgerConfig = HardForkLedgerConfig (CardanoEras StandardCrypto)
-> PerEraLedgerConfig (CardanoEras StandardCrypto)
forall (xs :: [*]).
HardForkLedgerConfig xs -> PerEraLedgerConfig xs
Consensus.hardForkLedgerConfigPerEra (HardForkLedgerConfig (CardanoEras StandardCrypto)
 -> PerEraLedgerConfig (CardanoEras StandardCrypto))
-> HardForkLedgerConfig (CardanoEras StandardCrypto)
-> PerEraLedgerConfig (CardanoEras StandardCrypto)
forall a b. (a -> b) -> a -> b
$ TopLevelConfig (HardForkBlock (CardanoEras StandardCrypto))
-> LedgerConfig (HardForkBlock (CardanoEras StandardCrypto))
forall blk. TopLevelConfig blk -> LedgerConfig blk
Consensus.configLedger TopLevelConfig (HardForkBlock (CardanoEras StandardCrypto))
topLevelConfig

-- | Grab the current 'NodeKernelAccess' from the environment, or throw
-- gRPC UNAVAILABLE if the node kernel has not yet initialised.
grabNodeKernelAccess
  :: MonadRpc e m
  => m Type.NodeKernelAccess
grabNodeKernelAccess :: forall e (m :: * -> *). MonadRpc e m => m NodeKernelAccess
grabNodeKernelAccess =
  m (IORef (Maybe NodeKernelAccess))
forall field env (m :: * -> *).
(Has field env, MonadReader env m) =>
m field
grab m (IORef (Maybe NodeKernelAccess))
-> (IORef (Maybe NodeKernelAccess) -> m (Maybe NodeKernelAccess))
-> m (Maybe NodeKernelAccess)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO (Maybe NodeKernelAccess) -> m (Maybe NodeKernelAccess)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe NodeKernelAccess) -> m (Maybe NodeKernelAccess))
-> (IORef (Maybe NodeKernelAccess) -> IO (Maybe NodeKernelAccess))
-> IORef (Maybe NodeKernelAccess)
-> m (Maybe NodeKernelAccess)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IORef (Maybe NodeKernelAccess) -> IO (Maybe NodeKernelAccess)
forall a. IORef a -> IO a
readIORef m (Maybe NodeKernelAccess)
-> (Maybe NodeKernelAccess -> m NodeKernelAccess)
-> m NodeKernelAccess
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe NodeKernelAccess
Nothing ->
      GrpcException -> m NodeKernelAccess
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO
        GrpcException
          { grpcError :: GrpcError
grpcError = GrpcError
GrpcUnavailable
          , grpcErrorMessage :: Maybe Text
grpcErrorMessage = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"Node kernel not yet initialised"
          , grpcErrorDetails :: Maybe ByteString
grpcErrorDetails = Maybe ByteString
forall a. Maybe a
Nothing
          , grpcErrorMetadata :: [CustomMetadata]
grpcErrorMetadata = []
          }
    Just NodeKernelAccess
nodeKernelAccess ->
      NodeKernelAccess -> m NodeKernelAccess
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NodeKernelAccess
nodeKernelAccess

-- | The network's system start time, extracted from genesis config.
-- Used together with 'readEraHistory' to convert slots to wall-clock time.
nodeKernelSystemStart :: Type.NodeKernelAccess -> SystemStart
nodeKernelSystemStart :: NodeKernelAccess -> SystemStart
nodeKernelSystemStart Type.NodeKernelAccess{systemStart :: NodeKernelAccess -> SystemStart
Type.systemStart = SystemStart
value} = SystemStart
value

-- | The protocol security parameter /k/: consensus never rolls back more
-- than /k/ blocks.
securityParam :: Type.NodeKernelAccess -> Consensus.SecurityParam
securityParam :: NodeKernelAccess -> SecurityParam
securityParam Type.NodeKernelAccess{securityParam :: NodeKernelAccess -> SecurityParam
Type.securityParam = SecurityParam
value} = SecurityParam
value

-- | The network's genesis configuration.
genesisConfig :: Type.NodeKernelAccess -> GenesisBundle
genesisConfig :: NodeKernelAccess -> GenesisBundle
genesisConfig Type.NodeKernelAccess{genesisConfig :: NodeKernelAccess -> GenesisBundle
Type.genesisConfig = GenesisBundle
value} = GenesisBundle
value

-- | Read the raw hard-fork era summary from the current ledger state, with
-- the era boundaries directly accessible.
readHardForkSummary
  :: MonadIO m
  => Type.NodeKernelAccess
  -> m (History.Summary (CardanoEras Consensus.StandardCrypto))
readHardForkSummary :: forall (m :: * -> *).
MonadIO m =>
NodeKernelAccess -> m (Summary (CardanoEras StandardCrypto))
readHardForkSummary Type.NodeKernelAccess{readHardForkSummary :: NodeKernelAccess
-> forall (m :: * -> *).
   MonadIO m =>
   m (Summary (CardanoEras StandardCrypto))
Type.readHardForkSummary = forall (m :: * -> *).
MonadIO m =>
m (Summary (CardanoEras StandardCrypto))
action} = m (Summary (CardanoEras StandardCrypto))
forall (m :: * -> *).
MonadIO m =>
m (Summary (CardanoEras StandardCrypto))
action

-- | Read current era history from the ledger state: the hard-fork era
-- summary wrapped into the opaque interpreter used for slot/time conversion
-- queries.
readEraHistory :: MonadIO m => Type.NodeKernelAccess -> m EraHistory
readEraHistory :: forall (m :: * -> *). MonadIO m => NodeKernelAccess -> m EraHistory
readEraHistory NodeKernelAccess
access = Interpreter (CardanoEras StandardCrypto) -> EraHistory
forall (xs :: [*]).
(HardForkBlock (CardanoEras StandardCrypto) ~ HardForkBlock xs) =>
Interpreter xs -> EraHistory
EraHistory (Interpreter (CardanoEras StandardCrypto) -> EraHistory)
-> (Summary (CardanoEras StandardCrypto)
    -> Interpreter (CardanoEras StandardCrypto))
-> Summary (CardanoEras StandardCrypto)
-> EraHistory
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Summary (CardanoEras StandardCrypto)
-> Interpreter (CardanoEras StandardCrypto)
forall (xs :: [*]). Summary xs -> Interpreter xs
Consensus.mkInterpreter (Summary (CardanoEras StandardCrypto) -> EraHistory)
-> m (Summary (CardanoEras StandardCrypto)) -> m EraHistory
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NodeKernelAccess -> m (Summary (CardanoEras StandardCrypto))
forall (m :: * -> *).
MonadIO m =>
NodeKernelAccess -> m (Summary (CardanoEras StandardCrypto))
readHardForkSummary NodeKernelAccess
access

-- | Read the current chain tip header from ChainDB, or 'Nothing' at origin.
readChainTipHeader
  :: MonadIO m
  => Type.NodeKernelAccess
  -> m (Maybe (Consensus.Header (Consensus.CardanoBlock Consensus.StandardCrypto)))
readChainTipHeader :: forall (m :: * -> *).
MonadIO m =>
NodeKernelAccess
-> m (Maybe (Header (HardForkBlock (CardanoEras StandardCrypto))))
readChainTipHeader Type.NodeKernelAccess{chainDb :: NodeKernelAccess
-> ChainDB IO (HardForkBlock (CardanoEras StandardCrypto))
Type.chainDb = ChainDB IO (HardForkBlock (CardanoEras StandardCrypto))
chainDb} = IO (Maybe (Header (HardForkBlock (CardanoEras StandardCrypto))))
-> m (Maybe (Header (HardForkBlock (CardanoEras StandardCrypto))))
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (Header (HardForkBlock (CardanoEras StandardCrypto))))
 -> m (Maybe (Header (HardForkBlock (CardanoEras StandardCrypto)))))
-> IO (Maybe (Header (HardForkBlock (CardanoEras StandardCrypto))))
-> m (Maybe (Header (HardForkBlock (CardanoEras StandardCrypto))))
forall a b. (a -> b) -> a -> b
$ ChainDB IO (HardForkBlock (CardanoEras StandardCrypto))
-> IO (Maybe (Header (HardForkBlock (CardanoEras StandardCrypto))))
forall (m :: * -> *) blk. ChainDB m blk -> m (Maybe (Header blk))
Consensus.getTipHeader ChainDB IO (HardForkBlock (CardanoEras StandardCrypto))
chainDb

-- | Fetch a raw block and its parsed era-contextualised form from ChainDB
-- by slot and header hash.
fetchBlock
  :: MonadIO m
  => Type.NodeKernelAccess
  -- ^ Node kernel access handle
  -> SlotNo
  -- ^ Block slot number
  -> Hash BlockHeader
  -- ^ Block header hash
  -> m (Maybe (ByteString, BlockInMode))
  -- ^ Raw CBOR bytes and the block in era context, or 'Nothing' if not found
fetchBlock :: forall (m :: * -> *).
MonadIO m =>
NodeKernelAccess
-> SlotNo
-> Hash BlockHeader
-> m (Maybe (ByteString, BlockInMode))
fetchBlock Type.NodeKernelAccess{chainDb :: NodeKernelAccess
-> ChainDB IO (HardForkBlock (CardanoEras StandardCrypto))
Type.chainDb = ChainDB IO (HardForkBlock (CardanoEras StandardCrypto))
chainDb} SlotNo
slot (HeaderHash ShortByteString
shortHash) = do
  let point :: RealPoint (HardForkBlock (CardanoEras StandardCrypto))
point = SlotNo
-> HeaderHash (HardForkBlock (CardanoEras StandardCrypto))
-> RealPoint (HardForkBlock (CardanoEras StandardCrypto))
forall blk. SlotNo -> HeaderHash blk -> RealPoint blk
Consensus.RealPoint SlotNo
slot (ShortByteString -> OneEraHash (CardanoEras StandardCrypto)
forall k (xs :: [k]). ShortByteString -> OneEraHash xs
Consensus.OneEraHash ShortByteString
shortHash)
      component :: BlockComponent
  (HardForkBlock (CardanoEras StandardCrypto))
  (ByteString, BlockInMode)
component = (,) (ByteString -> BlockInMode -> (ByteString, BlockInMode))
-> BlockComponent
     (HardForkBlock (CardanoEras StandardCrypto)) ByteString
-> BlockComponent
     (HardForkBlock (CardanoEras StandardCrypto))
     (BlockInMode -> (ByteString, BlockInMode))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ByteString -> ByteString)
-> BlockComponent
     (HardForkBlock (CardanoEras StandardCrypto)) ByteString
-> BlockComponent
     (HardForkBlock (CardanoEras StandardCrypto)) ByteString
forall a b.
(a -> b)
-> BlockComponent (HardForkBlock (CardanoEras StandardCrypto)) a
-> BlockComponent (HardForkBlock (CardanoEras StandardCrypto)) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> ByteString
BSL.toStrict BlockComponent
  (HardForkBlock (CardanoEras StandardCrypto)) ByteString
forall blk. BlockComponent blk ByteString
Consensus.GetRawBlock BlockComponent
  (HardForkBlock (CardanoEras StandardCrypto))
  (BlockInMode -> (ByteString, BlockInMode))
-> BlockComponent
     (HardForkBlock (CardanoEras StandardCrypto)) BlockInMode
-> BlockComponent
     (HardForkBlock (CardanoEras StandardCrypto))
     (ByteString, BlockInMode)
forall a b.
BlockComponent
  (HardForkBlock (CardanoEras StandardCrypto)) (a -> b)
-> BlockComponent (HardForkBlock (CardanoEras StandardCrypto)) a
-> BlockComponent (HardForkBlock (CardanoEras StandardCrypto)) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (HardForkBlock (CardanoEras StandardCrypto) -> BlockInMode)
-> BlockComponent
     (HardForkBlock (CardanoEras StandardCrypto))
     (HardForkBlock (CardanoEras StandardCrypto))
-> BlockComponent
     (HardForkBlock (CardanoEras StandardCrypto)) BlockInMode
forall a b.
(a -> b)
-> BlockComponent (HardForkBlock (CardanoEras StandardCrypto)) a
-> BlockComponent (HardForkBlock (CardanoEras StandardCrypto)) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HardForkBlock (CardanoEras StandardCrypto) -> BlockInMode
forall block.
(HardForkBlock (CardanoEras StandardCrypto) ~ block) =>
block -> BlockInMode
fromConsensusBlock BlockComponent
  (HardForkBlock (CardanoEras StandardCrypto))
  (HardForkBlock (CardanoEras StandardCrypto))
forall blk. BlockComponent blk blk
Consensus.GetBlock
  IO (Maybe (ByteString, BlockInMode))
-> m (Maybe (ByteString, BlockInMode))
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (ByteString, BlockInMode))
 -> m (Maybe (ByteString, BlockInMode)))
-> IO (Maybe (ByteString, BlockInMode))
-> m (Maybe (ByteString, BlockInMode))
forall a b. (a -> b) -> a -> b
$ ChainDB IO (HardForkBlock (CardanoEras StandardCrypto))
-> forall b.
   BlockComponent (HardForkBlock (CardanoEras StandardCrypto)) b
   -> RealPoint (HardForkBlock (CardanoEras StandardCrypto))
   -> IO (Maybe b)
forall (m :: * -> *) blk.
ChainDB m blk
-> forall b. BlockComponent blk b -> RealPoint blk -> m (Maybe b)
Consensus.getBlockComponent ChainDB IO (HardForkBlock (CardanoEras StandardCrypto))
chainDb BlockComponent
  (HardForkBlock (CardanoEras StandardCrypto))
  (ByteString, BlockInMode)
component RealPoint (HardForkBlock (CardanoEras StandardCrypto))
point

-- | A single instruction produced by a chain follower.
--
-- 'ChainApply' carries the raw CBOR block bytes together with the same block
-- parsed into its era context - exactly the pair 'fetchBlock' returns.
-- Consensus rollbacks are point-only: 'ChainRollBack' never carries the
-- blocks being rolled back, only the point to roll back to.
data ChainChange
  = ChainApply (ByteString, BlockInMode)
  | ChainRollBack ChainPoint

-- | A handle to a running chain follower.
data ChainFollower = ChainFollower
  { ChainFollower -> forall (m :: * -> *). MonadIO m => m ChainChange
nextChange :: forall m. MonadIO m => m ChainChange
  -- ^ Block until the next chain update is available.
  , ChainFollower
-> forall (m :: * -> *).
   MonadIO m =>
   [ChainPoint] -> m (Maybe ChainPoint)
findIntersect :: forall m. MonadIO m => [ChainPoint] -> m (Maybe ChainPoint)
  -- ^ Move the follower to the first of the given points found on the
  -- current chain, returning that point, or 'Nothing' if none of them are
  -- on the chain.
  }

-- | Run an action with a 'ChainFollower' tracking the selected chain.
--
-- The follower and the resource registry backing it are closed on every
-- exit path, including exceptions. The follower itself runs in 'IO',
-- because the ChainDB handle is monomorphic, so the bracket runs there and
-- the action is unlifted into it.
--
-- Creating a follower is cheap: a few in-memory STM operations, nothing
-- proportional to chain length. The costs are steady-state instead. A
-- caught-up follower receives an O(1) notification per adopted block. A
-- follower catching up streams blocks from the ImmutableDB, paying a disk
-- read and a deserialisation per block, with file handles owned by the
-- registry. The node already runs one such follower per connected N2C
-- ChainSync client, so one follower per stream scales the same way.
withFollower
  :: MonadUnliftIO m
  => Type.NodeKernelAccess
  -> (ChainFollower -> m a)
  -> m a
withFollower :: forall (m :: * -> *) a.
MonadUnliftIO m =>
NodeKernelAccess -> (ChainFollower -> m a) -> m a
withFollower Type.NodeKernelAccess{chainDb :: NodeKernelAccess
-> ChainDB IO (HardForkBlock (CardanoEras StandardCrypto))
Type.chainDb = ChainDB IO (HardForkBlock (CardanoEras StandardCrypto))
chainDb} ChainFollower -> m a
action =
  ((forall a. m a -> IO a) -> IO a) -> m a
forall b. ((forall a. m a -> IO a) -> IO b) -> m b
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. m a -> IO a) -> IO a) -> m a)
-> ((forall a. m a -> IO a) -> IO a) -> m a
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
runInIO ->
    (ResourceRegistry IO -> IO a) -> IO a
forall (m :: * -> *) a.
(MonadSTM m, MonadMask m, MonadThread m, HasCallStack) =>
(ResourceRegistry m -> m a) -> m a
Consensus.withRegistry ((ResourceRegistry IO -> IO a) -> IO a)
-> (ResourceRegistry IO -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \ResourceRegistry IO
registry ->
      IO
  (Follower
     IO
     (HardForkBlock (CardanoEras StandardCrypto))
     (ByteString, BlockInMode))
-> (Follower
      IO
      (HardForkBlock (CardanoEras StandardCrypto))
      (ByteString, BlockInMode)
    -> IO ())
-> (Follower
      IO
      (HardForkBlock (CardanoEras StandardCrypto))
      (ByteString, BlockInMode)
    -> IO a)
-> IO a
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket
        (ChainDB IO (HardForkBlock (CardanoEras StandardCrypto))
-> forall b.
   ResourceRegistry IO
   -> ChainType
   -> BlockComponent (HardForkBlock (CardanoEras StandardCrypto)) b
   -> IO (Follower IO (HardForkBlock (CardanoEras StandardCrypto)) b)
forall (m :: * -> *) blk.
ChainDB m blk
-> forall b.
   ResourceRegistry m
   -> ChainType -> BlockComponent blk b -> m (Follower m blk b)
Consensus.newFollower ChainDB IO (HardForkBlock (CardanoEras StandardCrypto))
chainDb ResourceRegistry IO
registry ChainType
Consensus.SelectedChain BlockComponent
  (HardForkBlock (CardanoEras StandardCrypto))
  (ByteString, BlockInMode)
component)
        Follower
  IO
  (HardForkBlock (CardanoEras StandardCrypto))
  (ByteString, BlockInMode)
-> IO ()
forall (m :: * -> *) blk a. Follower m blk a -> m ()
Consensus.followerClose
        (m a -> IO a
forall a. m a -> IO a
runInIO (m a -> IO a)
-> (Follower
      IO
      (HardForkBlock (CardanoEras StandardCrypto))
      (ByteString, BlockInMode)
    -> m a)
-> Follower
     IO
     (HardForkBlock (CardanoEras StandardCrypto))
     (ByteString, BlockInMode)
-> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainFollower -> m a
action (ChainFollower -> m a)
-> (Follower
      IO
      (HardForkBlock (CardanoEras StandardCrypto))
      (ByteString, BlockInMode)
    -> ChainFollower)
-> Follower
     IO
     (HardForkBlock (CardanoEras StandardCrypto))
     (ByteString, BlockInMode)
-> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Follower
  IO
  (HardForkBlock (CardanoEras StandardCrypto))
  (ByteString, BlockInMode)
-> ChainFollower
toChainFollower)
 where
  component
    :: Consensus.BlockComponent
         (Consensus.CardanoBlock Consensus.StandardCrypto)
         (ByteString, BlockInMode)
  component :: BlockComponent
  (HardForkBlock (CardanoEras StandardCrypto))
  (ByteString, BlockInMode)
component =
    (,) (ByteString -> BlockInMode -> (ByteString, BlockInMode))
-> BlockComponent
     (HardForkBlock (CardanoEras StandardCrypto)) ByteString
-> BlockComponent
     (HardForkBlock (CardanoEras StandardCrypto))
     (BlockInMode -> (ByteString, BlockInMode))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ByteString -> ByteString)
-> BlockComponent
     (HardForkBlock (CardanoEras StandardCrypto)) ByteString
-> BlockComponent
     (HardForkBlock (CardanoEras StandardCrypto)) ByteString
forall a b.
(a -> b)
-> BlockComponent (HardForkBlock (CardanoEras StandardCrypto)) a
-> BlockComponent (HardForkBlock (CardanoEras StandardCrypto)) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> ByteString
BSL.toStrict BlockComponent
  (HardForkBlock (CardanoEras StandardCrypto)) ByteString
forall blk. BlockComponent blk ByteString
Consensus.GetRawBlock BlockComponent
  (HardForkBlock (CardanoEras StandardCrypto))
  (BlockInMode -> (ByteString, BlockInMode))
-> BlockComponent
     (HardForkBlock (CardanoEras StandardCrypto)) BlockInMode
-> BlockComponent
     (HardForkBlock (CardanoEras StandardCrypto))
     (ByteString, BlockInMode)
forall a b.
BlockComponent
  (HardForkBlock (CardanoEras StandardCrypto)) (a -> b)
-> BlockComponent (HardForkBlock (CardanoEras StandardCrypto)) a
-> BlockComponent (HardForkBlock (CardanoEras StandardCrypto)) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (HardForkBlock (CardanoEras StandardCrypto) -> BlockInMode)
-> BlockComponent
     (HardForkBlock (CardanoEras StandardCrypto))
     (HardForkBlock (CardanoEras StandardCrypto))
-> BlockComponent
     (HardForkBlock (CardanoEras StandardCrypto)) BlockInMode
forall a b.
(a -> b)
-> BlockComponent (HardForkBlock (CardanoEras StandardCrypto)) a
-> BlockComponent (HardForkBlock (CardanoEras StandardCrypto)) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HardForkBlock (CardanoEras StandardCrypto) -> BlockInMode
forall block.
(HardForkBlock (CardanoEras StandardCrypto) ~ block) =>
block -> BlockInMode
fromConsensusBlock BlockComponent
  (HardForkBlock (CardanoEras StandardCrypto))
  (HardForkBlock (CardanoEras StandardCrypto))
forall blk. BlockComponent blk blk
Consensus.GetBlock

  toChainFollower
    :: Consensus.Follower
         IO
         (Consensus.CardanoBlock Consensus.StandardCrypto)
         (ByteString, BlockInMode)
    -> ChainFollower
  toChainFollower :: Follower
  IO
  (HardForkBlock (CardanoEras StandardCrypto))
  (ByteString, BlockInMode)
-> ChainFollower
toChainFollower Follower
  IO
  (HardForkBlock (CardanoEras StandardCrypto))
  (ByteString, BlockInMode)
follower =
    ChainFollower
      { nextChange :: forall (m :: * -> *). MonadIO m => m ChainChange
nextChange = IO ChainChange -> m ChainChange
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ChainChange -> m ChainChange)
-> IO ChainChange -> m ChainChange
forall a b. (a -> b) -> a -> b
$ ChainUpdate
  (HardForkBlock (CardanoEras StandardCrypto))
  (ByteString, BlockInMode)
-> ChainChange
toChainChange (ChainUpdate
   (HardForkBlock (CardanoEras StandardCrypto))
   (ByteString, BlockInMode)
 -> ChainChange)
-> IO
     (ChainUpdate
        (HardForkBlock (CardanoEras StandardCrypto))
        (ByteString, BlockInMode))
-> IO ChainChange
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Follower
  IO
  (HardForkBlock (CardanoEras StandardCrypto))
  (ByteString, BlockInMode)
-> IO
     (ChainUpdate
        (HardForkBlock (CardanoEras StandardCrypto))
        (ByteString, BlockInMode))
forall (m :: * -> *) blk a.
Follower m blk a -> m (ChainUpdate blk a)
Consensus.followerInstructionBlocking Follower
  IO
  (HardForkBlock (CardanoEras StandardCrypto))
  (ByteString, BlockInMode)
follower
      , findIntersect :: forall (m :: * -> *).
MonadIO m =>
[ChainPoint] -> m (Maybe ChainPoint)
findIntersect = \[ChainPoint]
points ->
          IO (Maybe ChainPoint) -> m (Maybe ChainPoint)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe ChainPoint) -> m (Maybe ChainPoint))
-> IO (Maybe ChainPoint) -> m (Maybe ChainPoint)
forall a b. (a -> b) -> a -> b
$
            (Point (HardForkBlock (CardanoEras StandardCrypto)) -> ChainPoint)
-> Maybe (Point (HardForkBlock (CardanoEras StandardCrypto)))
-> Maybe ChainPoint
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Point (HardForkBlock (CardanoEras StandardCrypto)) -> ChainPoint
forall block (xs :: [*]).
(HeaderHash block ~ OneEraHash xs) =>
Point block -> ChainPoint
fromConsensusPointHF
              (Maybe (Point (HardForkBlock (CardanoEras StandardCrypto)))
 -> Maybe ChainPoint)
-> IO (Maybe (Point (HardForkBlock (CardanoEras StandardCrypto))))
-> IO (Maybe ChainPoint)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Follower
  IO
  (HardForkBlock (CardanoEras StandardCrypto))
  (ByteString, BlockInMode)
-> [Point (HardForkBlock (CardanoEras StandardCrypto))]
-> IO (Maybe (Point (HardForkBlock (CardanoEras StandardCrypto))))
forall (m :: * -> *) blk a.
Follower m blk a -> [Point blk] -> m (Maybe (Point blk))
Consensus.followerForward Follower
  IO
  (HardForkBlock (CardanoEras StandardCrypto))
  (ByteString, BlockInMode)
follower ((ChainPoint -> Point (HardForkBlock (CardanoEras StandardCrypto)))
-> [ChainPoint]
-> [Point (HardForkBlock (CardanoEras StandardCrypto))]
forall a b. (a -> b) -> [a] -> [b]
map ChainPoint -> Point (HardForkBlock (CardanoEras StandardCrypto))
forall block (xs :: [*]).
(HeaderHash block ~ OneEraHash xs) =>
ChainPoint -> Point block
toConsensusPointHF [ChainPoint]
points)
      }

  toChainChange
    :: Consensus.ChainUpdate
         (Consensus.CardanoBlock Consensus.StandardCrypto)
         (ByteString, BlockInMode)
    -> ChainChange
  toChainChange :: ChainUpdate
  (HardForkBlock (CardanoEras StandardCrypto))
  (ByteString, BlockInMode)
-> ChainChange
toChainChange = \case
    Consensus.AddBlock (ByteString, BlockInMode)
rawBlock -> (ByteString, BlockInMode) -> ChainChange
ChainApply (ByteString, BlockInMode)
rawBlock
    Consensus.RollBack Point (HardForkBlock (CardanoEras StandardCrypto))
point -> ChainPoint -> ChainChange
ChainRollBack (Point (HardForkBlock (CardanoEras StandardCrypto)) -> ChainPoint
forall block (xs :: [*]).
(HeaderHash block ~ OneEraHash xs) =>
Point block -> ChainPoint
fromConsensusPointHF Point (HardForkBlock (CardanoEras StandardCrypto))
point)