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

-- | In-process access to the node kernel. The RPC server reads chain
-- state, genesis and mempool straight from the running node, with no
-- Node-to-Client round trip.
module Cardano.Rpc.Server.NodeKernelAccess
  ( -- * Access handle
    Type.NodeKernelAccess
  , mkNodeKernelAccess
  , grabNodeKernelAccess

    -- * Values fixed at startup
  , nodeKernelSystemStart
  , securityParam
  , genesisConfig
  , GenesisBundle (..)

    -- * Era history
  , readHardForkSummary
  , readEraHistory

    -- * Chain reads
  , readChainTipHeader
  , fetchBlock

    -- * Mempool
  , readMempoolTxs
  , MempoolWatchSnapshot (..)
  , watchMempoolSnapshot
  , nextMempoolWatchSnapshot

    -- * Chain follower
  , 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 Ouroboros.Consensus.Ledger.SupportsMempool qualified as Consensus (txForgetValidated)
import Ouroboros.Consensus.Mempool.API qualified as Consensus
  ( MempoolSnapshot (snapshotSlotNo, snapshotTxs, snapshotTxsAfter)
  , TicketNo
  , getSnapshot
  )

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

import Control.Monad.STM (check)
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 (CardanoBlock StandardCrypto)
-> m GenesisBundle
forall (m :: * -> *).
MonadIO m =>
GenesisHashShelley
-> ShelleyGenesisFile 'In
-> TopLevelConfig (CardanoBlock StandardCrypto)
-> m GenesisBundle
readGenesisBundle GenesisHashShelley
shelleyGenesisHash ShelleyGenesisFile 'In
shelleyGenesisFile TopLevelConfig blk
TopLevelConfig (CardanoBlock StandardCrypto)
topLevelConfig
    pure $
      Just
        Type.NodeKernelAccess
          { Type.chainDb = chainDb
          , Type.mempool = Consensus.getMempool kernel
          , 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 (ByronBlock : CardanoShelleyEras StandardCrypto))
readHardForkSummary' = do
      extLedger <- STM (ExtLedgerState (CardanoBlock StandardCrypto) EmptyMK)
-> n (ExtLedgerState (CardanoBlock StandardCrypto) EmptyMK)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (ExtLedgerState (CardanoBlock StandardCrypto) EmptyMK)
 -> n (ExtLedgerState (CardanoBlock StandardCrypto) EmptyMK))
-> STM (ExtLedgerState (CardanoBlock StandardCrypto) EmptyMK)
-> n (ExtLedgerState (CardanoBlock 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 (CardanoBlock StandardCrypto)
-> m GenesisBundle
readGenesisBundle GenesisHashShelley
shelleyGenesisHash ShelleyGenesisFile 'In
shelleyGenesisFile TopLevelConfig (CardanoBlock StandardCrypto)
topLevelConfig =
  case PerEraLedgerConfig (ByronBlock : CardanoShelleyEras StandardCrypto)
-> NP
     WrapPartialLedgerConfig
     (ByronBlock : CardanoShelleyEras StandardCrypto)
forall (xs :: [*]).
PerEraLedgerConfig xs -> NP WrapPartialLedgerConfig xs
Consensus.getPerEraLedgerConfig PerEraLedgerConfig (ByronBlock : CardanoShelleyEras 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 (ByronBlock : CardanoShelleyEras StandardCrypto)
perEraLedgerConfig = HardForkLedgerConfig
  (ByronBlock : CardanoShelleyEras StandardCrypto)
-> PerEraLedgerConfig
     (ByronBlock : CardanoShelleyEras StandardCrypto)
forall (xs :: [*]).
HardForkLedgerConfig xs -> PerEraLedgerConfig xs
Consensus.hardForkLedgerConfigPerEra (HardForkLedgerConfig
   (ByronBlock : CardanoShelleyEras StandardCrypto)
 -> PerEraLedgerConfig
      (ByronBlock : CardanoShelleyEras StandardCrypto))
-> HardForkLedgerConfig
     (ByronBlock : CardanoShelleyEras StandardCrypto)
-> PerEraLedgerConfig
     (ByronBlock : CardanoShelleyEras StandardCrypto)
forall a b. (a -> b) -> a -> b
$ TopLevelConfig (CardanoBlock StandardCrypto)
-> LedgerConfig (CardanoBlock StandardCrypto)
forall blk. TopLevelConfig blk -> LedgerConfig blk
Consensus.configLedger TopLevelConfig (CardanoBlock 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 (ByronBlock : CardanoShelleyEras StandardCrypto))
readHardForkSummary Type.NodeKernelAccess{readHardForkSummary :: NodeKernelAccess
-> forall (m :: * -> *).
   MonadIO m =>
   m (Summary (ByronBlock : CardanoShelleyEras StandardCrypto))
Type.readHardForkSummary = forall (m :: * -> *).
MonadIO m =>
m (Summary (ByronBlock : CardanoShelleyEras StandardCrypto))
action} = m (Summary (ByronBlock : CardanoShelleyEras StandardCrypto))
forall (m :: * -> *).
MonadIO m =>
m (Summary (ByronBlock : CardanoShelleyEras 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 (ByronBlock : CardanoShelleyEras StandardCrypto)
-> EraHistory
forall (xs :: [*]).
(CardanoBlock StandardCrypto ~ HardForkBlock xs) =>
Interpreter xs -> EraHistory
EraHistory (Interpreter (ByronBlock : CardanoShelleyEras StandardCrypto)
 -> EraHistory)
-> (Summary (ByronBlock : CardanoShelleyEras StandardCrypto)
    -> Interpreter (ByronBlock : CardanoShelleyEras StandardCrypto))
-> Summary (ByronBlock : CardanoShelleyEras StandardCrypto)
-> EraHistory
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Summary (ByronBlock : CardanoShelleyEras StandardCrypto)
-> Interpreter (ByronBlock : CardanoShelleyEras StandardCrypto)
forall (xs :: [*]). Summary xs -> Interpreter xs
Consensus.mkInterpreter (Summary (ByronBlock : CardanoShelleyEras StandardCrypto)
 -> EraHistory)
-> m (Summary (ByronBlock : CardanoShelleyEras StandardCrypto))
-> m EraHistory
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NodeKernelAccess
-> m (Summary (ByronBlock : CardanoShelleyEras StandardCrypto))
forall (m :: * -> *).
MonadIO m =>
NodeKernelAccess
-> m (Summary (ByronBlock : CardanoShelleyEras 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 (CardanoBlock StandardCrypto)))
readChainTipHeader Type.NodeKernelAccess{chainDb :: NodeKernelAccess -> ChainDB IO (CardanoBlock StandardCrypto)
Type.chainDb = ChainDB IO (CardanoBlock StandardCrypto)
chainDb} = IO (Maybe (Header (CardanoBlock StandardCrypto)))
-> m (Maybe (Header (CardanoBlock StandardCrypto)))
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (Header (CardanoBlock StandardCrypto)))
 -> m (Maybe (Header (CardanoBlock StandardCrypto))))
-> IO (Maybe (Header (CardanoBlock StandardCrypto)))
-> m (Maybe (Header (CardanoBlock StandardCrypto)))
forall a b. (a -> b) -> a -> b
$ ChainDB IO (CardanoBlock StandardCrypto)
-> IO (Maybe (Header (CardanoBlock StandardCrypto)))
forall (m :: * -> *) blk. ChainDB m blk -> m (Maybe (Header blk))
Consensus.getTipHeader ChainDB IO (CardanoBlock 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 (CardanoBlock StandardCrypto)
Type.chainDb = ChainDB IO (CardanoBlock StandardCrypto)
chainDb} SlotNo
slot (HeaderHash ShortByteString
shortHash) = do
  let point :: RealPoint (CardanoBlock StandardCrypto)
point = SlotNo
-> HeaderHash (CardanoBlock StandardCrypto)
-> RealPoint (CardanoBlock StandardCrypto)
forall blk. SlotNo -> HeaderHash blk -> RealPoint blk
Consensus.RealPoint SlotNo
slot (ShortByteString
-> OneEraHash (ByronBlock : CardanoShelleyEras StandardCrypto)
forall k (xs :: [k]). ShortByteString -> OneEraHash xs
Consensus.OneEraHash ShortByteString
shortHash)
      component :: BlockComponent
  (CardanoBlock StandardCrypto) (ByteString, BlockInMode)
component = (,) (ByteString -> BlockInMode -> (ByteString, BlockInMode))
-> BlockComponent (CardanoBlock StandardCrypto) ByteString
-> BlockComponent
     (CardanoBlock StandardCrypto)
     (BlockInMode -> (ByteString, BlockInMode))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ByteString -> ByteString)
-> BlockComponent (CardanoBlock StandardCrypto) ByteString
-> BlockComponent (CardanoBlock StandardCrypto) ByteString
forall a b.
(a -> b)
-> BlockComponent (CardanoBlock StandardCrypto) a
-> BlockComponent (CardanoBlock StandardCrypto) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> ByteString
BSL.toStrict BlockComponent (CardanoBlock StandardCrypto) ByteString
forall blk. BlockComponent blk ByteString
Consensus.GetRawBlock BlockComponent
  (CardanoBlock StandardCrypto)
  (BlockInMode -> (ByteString, BlockInMode))
-> BlockComponent (CardanoBlock StandardCrypto) BlockInMode
-> BlockComponent
     (CardanoBlock StandardCrypto) (ByteString, BlockInMode)
forall a b.
BlockComponent (CardanoBlock StandardCrypto) (a -> b)
-> BlockComponent (CardanoBlock StandardCrypto) a
-> BlockComponent (CardanoBlock StandardCrypto) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (CardanoBlock StandardCrypto -> BlockInMode)
-> BlockComponent
     (CardanoBlock StandardCrypto) (CardanoBlock StandardCrypto)
-> BlockComponent (CardanoBlock StandardCrypto) BlockInMode
forall a b.
(a -> b)
-> BlockComponent (CardanoBlock StandardCrypto) a
-> BlockComponent (CardanoBlock StandardCrypto) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CardanoBlock StandardCrypto -> BlockInMode
forall block.
(CardanoBlock StandardCrypto ~ block) =>
block -> BlockInMode
fromConsensusBlock BlockComponent
  (CardanoBlock StandardCrypto) (CardanoBlock 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 (CardanoBlock StandardCrypto)
-> forall b.
   BlockComponent (CardanoBlock StandardCrypto) b
   -> RealPoint (CardanoBlock StandardCrypto) -> IO (Maybe b)
forall (m :: * -> *) blk.
ChainDB m blk
-> forall b. BlockComponent blk b -> RealPoint blk -> m (Maybe b)
Consensus.getBlockComponent ChainDB IO (CardanoBlock StandardCrypto)
chainDb BlockComponent
  (CardanoBlock StandardCrypto) (ByteString, BlockInMode)
component RealPoint (CardanoBlock StandardCrypto)
point

-- | Read the current mempool contents as a point-in-time snapshot:
-- transactions added or removed after the read are not reflected.
-- Ticket numbers and mempool capacity accounting are dropped here, since
-- 'readMempoolTxs' only serves the one-shot @ReadMempool@ method.
readMempoolTxs
  :: MonadIO m
  => Type.NodeKernelAccess
  -> m [Consensus.GenTx (Consensus.CardanoBlock Consensus.StandardCrypto)]
readMempoolTxs :: forall (m :: * -> *).
MonadIO m =>
NodeKernelAccess -> m [GenTx (CardanoBlock StandardCrypto)]
readMempoolTxs Type.NodeKernelAccess{mempool :: NodeKernelAccess -> Mempool IO (CardanoBlock StandardCrypto)
Type.mempool = Mempool IO (CardanoBlock StandardCrypto)
mempool} = do
  snapshot <- STM (MempoolSnapshot (CardanoBlock StandardCrypto))
-> m (MempoolSnapshot (CardanoBlock StandardCrypto))
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (MempoolSnapshot (CardanoBlock StandardCrypto))
 -> m (MempoolSnapshot (CardanoBlock StandardCrypto)))
-> STM (MempoolSnapshot (CardanoBlock StandardCrypto))
-> m (MempoolSnapshot (CardanoBlock StandardCrypto))
forall a b. (a -> b) -> a -> b
$ Mempool IO (CardanoBlock StandardCrypto)
-> STM IO (MempoolSnapshot (CardanoBlock StandardCrypto))
forall (m :: * -> *) blk.
Mempool m blk -> STM m (MempoolSnapshot blk)
Consensus.getSnapshot Mempool IO (CardanoBlock StandardCrypto)
mempool
  pure
    [Consensus.txForgetValidated tx | (tx, _ticketNo, _txMeasure) <- Consensus.snapshotTxs snapshot]

-- | The change-detection key for a mempool snapshot: every current entry's
-- ticket number, oldest to newest, plus the virtual block's slot number.
-- Computed inside 'toMempoolWatchSnapshot', whose stored fields
-- 'nextMempoolWatchSnapshot' compares to decide whether the mempool changed.
mempoolObservationKey
  :: Consensus.MempoolSnapshot (Consensus.CardanoBlock Consensus.StandardCrypto)
  -> ([Consensus.TicketNo], SlotNo)
mempoolObservationKey :: MempoolSnapshot (CardanoBlock StandardCrypto)
-> ([TicketNo], SlotNo)
mempoolObservationKey MempoolSnapshot (CardanoBlock StandardCrypto)
snapshot =
  ( [TicketNo
ticketNo | (Validated (GenTx (CardanoBlock StandardCrypto))
_, TicketNo
ticketNo, TxMeasure (CardanoBlock StandardCrypto)
_) <- MempoolSnapshot (CardanoBlock StandardCrypto)
-> [(Validated (GenTx (CardanoBlock StandardCrypto)), TicketNo,
     TxMeasure (CardanoBlock StandardCrypto))]
forall blk.
MempoolSnapshot blk
-> [(Validated (GenTx blk), TicketNo, TxMeasure blk)]
Consensus.snapshotTxs MempoolSnapshot (CardanoBlock StandardCrypto)
snapshot]
  , MempoolSnapshot (CardanoBlock StandardCrypto) -> SlotNo
forall blk. MempoolSnapshot blk -> SlotNo
Consensus.snapshotSlotNo MempoolSnapshot (CardanoBlock StandardCrypto)
snapshot
  )

-- | A point-in-time view of the mempool for @WatchMempool@: every current
-- entry's ticket number (for change detection), the virtual block's slot
-- number, and a pure projection of entries newer than a given ticket,
-- already unwrapped out of 'Consensus.Validated' into 'TxInMode' - a plain
-- value that test code can construct directly with 'TxInMode' fixtures,
-- with no need to fabricate a genuine 'Consensus.Validated' value or run
-- mempool validation.
data MempoolWatchSnapshot = MempoolWatchSnapshot
  { MempoolWatchSnapshot -> [TicketNo]
mempoolWatchTicketNumbers :: [Consensus.TicketNo]
  -- ^ Every current entry's ticket number, oldest to newest: half of the
  -- change-detection key 'nextMempoolWatchSnapshot' compares (see
  -- 'mempoolObservationKey'). A max-ticket comparison alone would miss
  -- removal-only changes, which is why the full list is kept rather than
  -- just its length or maximum.
  , MempoolWatchSnapshot -> SlotNo
mempoolWatchSlotNo :: SlotNo
  -- ^ The virtual block's slot number: the other half of the
  -- change-detection key.
  , MempoolWatchSnapshot -> TicketNo -> [(TxInMode, TicketNo)]
mempoolWatchTxsAfter :: Consensus.TicketNo -> [(TxInMode, Consensus.TicketNo)]
  -- ^ Entries with a ticket number greater than the given one, oldest to
  -- newest.
  }

-- | Read the current mempool watch snapshot, without blocking.
watchMempoolSnapshot
  :: MonadIO m
  => Type.NodeKernelAccess
  -> m MempoolWatchSnapshot
watchMempoolSnapshot :: forall (m :: * -> *).
MonadIO m =>
NodeKernelAccess -> m MempoolWatchSnapshot
watchMempoolSnapshot Type.NodeKernelAccess{mempool :: NodeKernelAccess -> Mempool IO (CardanoBlock StandardCrypto)
Type.mempool = Mempool IO (CardanoBlock StandardCrypto)
mempool} =
  MempoolSnapshot (CardanoBlock StandardCrypto)
-> MempoolWatchSnapshot
toMempoolWatchSnapshot (MempoolSnapshot (CardanoBlock StandardCrypto)
 -> MempoolWatchSnapshot)
-> m (MempoolSnapshot (CardanoBlock StandardCrypto))
-> m MempoolWatchSnapshot
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM (MempoolSnapshot (CardanoBlock StandardCrypto))
-> m (MempoolSnapshot (CardanoBlock StandardCrypto))
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (Mempool IO (CardanoBlock StandardCrypto)
-> STM IO (MempoolSnapshot (CardanoBlock StandardCrypto))
forall (m :: * -> *) blk.
Mempool m blk -> STM m (MempoolSnapshot blk)
Consensus.getSnapshot Mempool IO (CardanoBlock StandardCrypto)
mempool)

-- | Block until the mempool snapshot's ticket list or slot number differs
-- from the given one, then return the new snapshot.
nextMempoolWatchSnapshot
  :: MonadIO m
  => Type.NodeKernelAccess
  -> MempoolWatchSnapshot
  -> m MempoolWatchSnapshot
nextMempoolWatchSnapshot :: forall (m :: * -> *).
MonadIO m =>
NodeKernelAccess -> MempoolWatchSnapshot -> m MempoolWatchSnapshot
nextMempoolWatchSnapshot
  Type.NodeKernelAccess{mempool :: NodeKernelAccess -> Mempool IO (CardanoBlock StandardCrypto)
Type.mempool = Mempool IO (CardanoBlock StandardCrypto)
mempool}
  MempoolWatchSnapshot
    { mempoolWatchTicketNumbers :: MempoolWatchSnapshot -> [TicketNo]
mempoolWatchTicketNumbers = [TicketNo]
previousTicketNumbers
    , mempoolWatchSlotNo :: MempoolWatchSnapshot -> SlotNo
mempoolWatchSlotNo = SlotNo
previousSlotNo
    } =
    STM MempoolWatchSnapshot -> m MempoolWatchSnapshot
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM MempoolWatchSnapshot -> m MempoolWatchSnapshot)
-> STM MempoolWatchSnapshot -> m MempoolWatchSnapshot
forall a b. (a -> b) -> a -> b
$ do
      candidate <- Mempool IO (CardanoBlock StandardCrypto)
-> STM IO (MempoolSnapshot (CardanoBlock StandardCrypto))
forall (m :: * -> *) blk.
Mempool m blk -> STM m (MempoolSnapshot blk)
Consensus.getSnapshot Mempool IO (CardanoBlock StandardCrypto)
mempool
      let watchSnapshot@MempoolWatchSnapshot
            { mempoolWatchTicketNumbers = ticketNumbers
            , mempoolWatchSlotNo = slotNo
            } = toMempoolWatchSnapshot candidate
      check $ (ticketNumbers, slotNo) /= (previousTicketNumbers, previousSlotNo)
      pure watchSnapshot

toMempoolWatchSnapshot
  :: Consensus.MempoolSnapshot (Consensus.CardanoBlock Consensus.StandardCrypto)
  -> MempoolWatchSnapshot
toMempoolWatchSnapshot :: MempoolSnapshot (CardanoBlock StandardCrypto)
-> MempoolWatchSnapshot
toMempoolWatchSnapshot MempoolSnapshot (CardanoBlock StandardCrypto)
snapshot =
  MempoolWatchSnapshot
    { mempoolWatchTicketNumbers :: [TicketNo]
mempoolWatchTicketNumbers = [TicketNo]
ticketNumbers
    , mempoolWatchSlotNo :: SlotNo
mempoolWatchSlotNo = SlotNo
slotNo
    , mempoolWatchTxsAfter :: TicketNo -> [(TxInMode, TicketNo)]
mempoolWatchTxsAfter = \TicketNo
ticketNo ->
        [ (GenTx (CardanoBlock StandardCrypto) -> TxInMode
forall block.
(CardanoBlock StandardCrypto ~ block) =>
GenTx block -> TxInMode
fromConsensusGenTx (Validated (GenTx (CardanoBlock StandardCrypto))
-> GenTx (CardanoBlock StandardCrypto)
forall blk.
LedgerSupportsMempool blk =>
Validated (GenTx blk) -> GenTx blk
Consensus.txForgetValidated Validated (GenTx (CardanoBlock StandardCrypto))
tx), TicketNo
ticketNo')
        | (Validated (GenTx (CardanoBlock StandardCrypto))
tx, TicketNo
ticketNo', TxMeasure (CardanoBlock StandardCrypto)
_txMeasure) <- MempoolSnapshot (CardanoBlock StandardCrypto)
-> TicketNo
-> [(Validated (GenTx (CardanoBlock StandardCrypto)), TicketNo,
     TxMeasure (CardanoBlock StandardCrypto))]
forall blk.
MempoolSnapshot blk
-> TicketNo -> [(Validated (GenTx blk), TicketNo, TxMeasure blk)]
Consensus.snapshotTxsAfter MempoolSnapshot (CardanoBlock StandardCrypto)
snapshot TicketNo
ticketNo
        ]
    }
 where
  ([TicketNo]
ticketNumbers, SlotNo
slotNo) = MempoolSnapshot (CardanoBlock StandardCrypto)
-> ([TicketNo], SlotNo)
mempoolObservationKey MempoolSnapshot (CardanoBlock StandardCrypto)
snapshot

-- | 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 (CardanoBlock StandardCrypto)
Type.chainDb = ChainDB IO (CardanoBlock 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 (CardanoBlock StandardCrypto) (ByteString, BlockInMode))
-> (Follower
      IO (CardanoBlock StandardCrypto) (ByteString, BlockInMode)
    -> IO ())
-> (Follower
      IO (CardanoBlock 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 (CardanoBlock StandardCrypto)
-> forall b.
   ResourceRegistry IO
   -> ChainType
   -> BlockComponent (CardanoBlock StandardCrypto) b
   -> IO (Follower IO (CardanoBlock 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 (CardanoBlock StandardCrypto)
chainDb ResourceRegistry IO
registry ChainType
Consensus.SelectedChain BlockComponent
  (CardanoBlock StandardCrypto) (ByteString, BlockInMode)
component)
        Follower IO (CardanoBlock 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 (CardanoBlock StandardCrypto) (ByteString, BlockInMode)
    -> m a)
-> Follower
     IO (CardanoBlock StandardCrypto) (ByteString, BlockInMode)
-> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainFollower -> m a
action (ChainFollower -> m a)
-> (Follower
      IO (CardanoBlock StandardCrypto) (ByteString, BlockInMode)
    -> ChainFollower)
-> Follower
     IO (CardanoBlock StandardCrypto) (ByteString, BlockInMode)
-> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Follower IO (CardanoBlock StandardCrypto) (ByteString, BlockInMode)
-> ChainFollower
toChainFollower)
 where
  component
    :: Consensus.BlockComponent
         (Consensus.CardanoBlock Consensus.StandardCrypto)
         (ByteString, BlockInMode)
  component :: BlockComponent
  (CardanoBlock StandardCrypto) (ByteString, BlockInMode)
component =
    (,) (ByteString -> BlockInMode -> (ByteString, BlockInMode))
-> BlockComponent (CardanoBlock StandardCrypto) ByteString
-> BlockComponent
     (CardanoBlock StandardCrypto)
     (BlockInMode -> (ByteString, BlockInMode))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ByteString -> ByteString)
-> BlockComponent (CardanoBlock StandardCrypto) ByteString
-> BlockComponent (CardanoBlock StandardCrypto) ByteString
forall a b.
(a -> b)
-> BlockComponent (CardanoBlock StandardCrypto) a
-> BlockComponent (CardanoBlock StandardCrypto) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> ByteString
BSL.toStrict BlockComponent (CardanoBlock StandardCrypto) ByteString
forall blk. BlockComponent blk ByteString
Consensus.GetRawBlock BlockComponent
  (CardanoBlock StandardCrypto)
  (BlockInMode -> (ByteString, BlockInMode))
-> BlockComponent (CardanoBlock StandardCrypto) BlockInMode
-> BlockComponent
     (CardanoBlock StandardCrypto) (ByteString, BlockInMode)
forall a b.
BlockComponent (CardanoBlock StandardCrypto) (a -> b)
-> BlockComponent (CardanoBlock StandardCrypto) a
-> BlockComponent (CardanoBlock StandardCrypto) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (CardanoBlock StandardCrypto -> BlockInMode)
-> BlockComponent
     (CardanoBlock StandardCrypto) (CardanoBlock StandardCrypto)
-> BlockComponent (CardanoBlock StandardCrypto) BlockInMode
forall a b.
(a -> b)
-> BlockComponent (CardanoBlock StandardCrypto) a
-> BlockComponent (CardanoBlock StandardCrypto) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CardanoBlock StandardCrypto -> BlockInMode
forall block.
(CardanoBlock StandardCrypto ~ block) =>
block -> BlockInMode
fromConsensusBlock BlockComponent
  (CardanoBlock StandardCrypto) (CardanoBlock StandardCrypto)
forall blk. BlockComponent blk blk
Consensus.GetBlock

  toChainFollower
    :: Consensus.Follower
         IO
         (Consensus.CardanoBlock Consensus.StandardCrypto)
         (ByteString, BlockInMode)
    -> ChainFollower
  toChainFollower :: Follower IO (CardanoBlock StandardCrypto) (ByteString, BlockInMode)
-> ChainFollower
toChainFollower Follower IO (CardanoBlock 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 (CardanoBlock StandardCrypto) (ByteString, BlockInMode)
-> ChainChange
toChainChange (ChainUpdate
   (CardanoBlock StandardCrypto) (ByteString, BlockInMode)
 -> ChainChange)
-> IO
     (ChainUpdate
        (CardanoBlock StandardCrypto) (ByteString, BlockInMode))
-> IO ChainChange
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Follower IO (CardanoBlock StandardCrypto) (ByteString, BlockInMode)
-> IO
     (ChainUpdate
        (CardanoBlock StandardCrypto) (ByteString, BlockInMode))
forall (m :: * -> *) blk a.
Follower m blk a -> m (ChainUpdate blk a)
Consensus.followerInstructionBlocking Follower IO (CardanoBlock 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 (CardanoBlock StandardCrypto) -> ChainPoint)
-> Maybe (Point (CardanoBlock 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 (CardanoBlock StandardCrypto) -> ChainPoint
forall block (xs :: [*]).
(HeaderHash block ~ OneEraHash xs) =>
Point block -> ChainPoint
fromConsensusPointHF
              (Maybe (Point (CardanoBlock StandardCrypto)) -> Maybe ChainPoint)
-> IO (Maybe (Point (CardanoBlock StandardCrypto)))
-> IO (Maybe ChainPoint)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Follower IO (CardanoBlock StandardCrypto) (ByteString, BlockInMode)
-> [Point (CardanoBlock StandardCrypto)]
-> IO (Maybe (Point (CardanoBlock StandardCrypto)))
forall (m :: * -> *) blk a.
Follower m blk a -> [Point blk] -> m (Maybe (Point blk))
Consensus.followerForward Follower IO (CardanoBlock StandardCrypto) (ByteString, BlockInMode)
follower ((ChainPoint -> Point (CardanoBlock StandardCrypto))
-> [ChainPoint] -> [Point (CardanoBlock StandardCrypto)]
forall a b. (a -> b) -> [a] -> [b]
map ChainPoint -> Point (CardanoBlock 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 (CardanoBlock StandardCrypto) (ByteString, BlockInMode)
-> ChainChange
toChainChange = \case
    Consensus.AddBlock (ByteString, BlockInMode)
rawBlock -> (ByteString, BlockInMode) -> ChainChange
ChainApply (ByteString, BlockInMode)
rawBlock
    Consensus.RollBack Point (CardanoBlock StandardCrypto)
point -> ChainPoint -> ChainChange
ChainRollBack (Point (CardanoBlock StandardCrypto) -> ChainPoint
forall block (xs :: [*]).
(HeaderHash block ~ OneEraHash xs) =>
Point block -> ChainPoint
fromConsensusPointHF Point (CardanoBlock StandardCrypto)
point)