@@ -16,7 +16,7 @@ import Cardano.Api.Consensus qualified as Consensus
1616import Cardano.Rpc.Server.Internal.Monad (MonadRpc , grab )
1717import Cardano.Rpc.Server.NodeKernelAccess.Type
1818
19- import RIO (throwIO )
19+ import RIO (atomically , throwIO )
2020
2121import Control.Tracer (Tracer , traceWith )
2222import Data.ByteString (ByteString )
@@ -28,36 +28,38 @@ import Network.GRPC.Spec
2828-- | Construct 'NodeKernelAccess' from a consensus 'Consensus.NodeKernel'.
2929-- Returns 'Nothing' and traces the block type for non-Cardano block types.
3030mkNodeKernelAccess
31- :: Tracer IO Text
31+ :: Monad m
32+ => Tracer m Text
3233 -- ^ Tracer for unsupported block type warnings
3334 -> Consensus. BlockTypeblk
3435 -- ^ Block type witness
36+ -> Consensus. TopLevelConfigblk
37+ -- ^ Top-level consensus config (for system start and era history)
3538 -> Consensus. NodeKernelIO addrNTN addrNTC blk
3639 -- ^ Consensus node kernel
37- -> IO Maybe NodeKernelAccess )
38- mkNodeKernelAccess tracer blockType kernel = case blockType of
40+ -> m (Maybe NodeKernelAccess )
41+ mkNodeKernelAccess tracer blockType topLevelConfig kernel = case blockType of
3942 Consensus. CardanoBlockType->
40- pure $ Just NodeKernelAccess {nkaChainDB = Consensus. getChainDB kernel}
43+ pure $ Just NodeKernelAccess {chainDb, systemStart, readEraHistory}
44+ where
45+ chainDb = Consensus. getChainDB kernel
46+ ledgerConfig = Consensus. configLedger topLevelConfig
47+ systemStart = Consensus. nodeSystemStart topLevelConfig
48+ -- Read the current ledger state (cheap STM TVar read) and recompute
49+ -- the era summary on every call - O(number_of_eras).
50+ -- This is the same approach consensus uses for GetInterpreter queries
51+ -- (interpretQueryHardFork); neither path caches the summary.
52+ -- RunWithCachedSummary exists but is private to the blockchain time thread.
53+ readEraHistory :: MonadIO n => n EraHistory
54+ readEraHistory = liftIO $ do
55+ extLedger <- atomically $ Consensus. getCurrentLedger chainDb
56+ pure . EraHistory . Consensus. mkInterpreter $
57+ Consensus. hardForkSummary ledgerConfig (Consensus. ledgerState extLedger)
4158 _ -> do
59+ -- unsupported block type
4260 traceWith tracer $ pack (show blockType)
4361 pure Nothing
4462
45- -- | Fetch a raw block and its block number from ChainDB by slot and header hash.
46- fetchBlock
47- :: MonadIO m
48- => NodeKernelAccess
49- -- ^ Node kernel access handle
50- -> SlotNo
51- -- ^ Block slot number
52- -> Hash BlockHeader
53- -- ^ Block header hash
54- -> m (Maybe ByteString , BlockNo ))
55- -- ^ Raw CBOR bytes and block number, or 'Nothing' if not found
56- fetchBlock NodeKernelAccess {nkaChainDB} slot (HeaderHash shortHash) = do
57- let point = Consensus. RealPointConsensus. OneEraHash
58- component = (,) <$> fmap BSL. toStrict Consensus. GetRawBlock<*> fmap Consensus. blockNo Consensus. GetBlock
59- liftIO $ Consensus. getBlockComponent nkaChainDB component point
60-
6163-- | Grab the current 'NodeKernelAccess' from the environment, or throw
6264-- gRPC UNAVAILABLE if the node kernel has not yet initialised.
6365grabNodeKernelAccess
@@ -75,3 +77,19 @@ grabNodeKernelAccess =
7577 }
7678 Just nodeKernelAccess ->
7779 pure nodeKernelAccess
80+
81+ -- | Fetch a raw block and its block number from ChainDB by slot and header hash.
82+ fetchBlock
83+ :: MonadIO m
84+ => NodeKernelAccess
85+ -- ^ Node kernel access handle
86+ -> SlotNo
87+ -- ^ Block slot number
88+ -> Hash BlockHeader
89+ -- ^ Block header hash
90+ -> m (Maybe ByteString , BlockNo ))
91+ -- ^ Raw CBOR bytes and block number, or 'Nothing' if not found
92+ fetchBlock NodeKernelAccess {chainDb} slot (HeaderHash shortHash) = do
93+ let point = Consensus. RealPointConsensus. OneEraHash
94+ component = (,) <$> fmap BSL. toStrict Consensus. GetRawBlock<*> fmap Consensus. blockNo Consensus. GetBlock
95+ liftIO $ Consensus. getBlockComponent chainDb component point
0 commit comments