{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}

module Cardano.Rpc.Server.NodeKernelAccess
  ( NodeKernelAccess (..)
  , mkNodeKernelAccess
  , fetchBlock
  , grabNodeKernelAccess
  )
where

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

import RIO (throwIO)

import Control.Tracer (Tracer, traceWith)
import Data.ByteString (ByteString)
import Data.ByteString.Lazy qualified as BSL
import Data.IORef
import Data.Text (pack)
import Network.GRPC.Spec

-- | Construct 'NodeKernelAccess' from a consensus 'Consensus.NodeKernel'.
-- Returns 'Nothing' and traces the block type for non-Cardano block types.
mkNodeKernelAccess
  :: Tracer IO Text
  -- ^ Tracer for unsupported block type warnings
  -> Consensus.BlockType blk
  -- ^ Block type witness
  -> Consensus.NodeKernel IO addrNTN addrNTC blk
  -- ^ Consensus node kernel
  -> IO (Maybe NodeKernelAccess)
mkNodeKernelAccess :: forall blk addrNTN addrNTC.
Tracer IO Text
-> BlockType blk
-> NodeKernel IO addrNTN addrNTC blk
-> IO (Maybe NodeKernelAccess)
mkNodeKernelAccess Tracer IO Text
tracer BlockType blk
blockType NodeKernel IO addrNTN addrNTC blk
kernel = case BlockType blk
blockType of
  BlockType blk
Consensus.CardanoBlockType ->
    Maybe NodeKernelAccess -> IO (Maybe NodeKernelAccess)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe NodeKernelAccess -> IO (Maybe NodeKernelAccess))
-> Maybe NodeKernelAccess -> IO (Maybe NodeKernelAccess)
forall a b. (a -> b) -> a -> b
$ NodeKernelAccess -> Maybe NodeKernelAccess
forall a. a -> Maybe a
Just NodeKernelAccess{nkaChainDB :: ChainDB IO (HardForkBlock (CardanoEras StandardCrypto))
nkaChainDB = NodeKernel
  IO addrNTN addrNTC (HardForkBlock (CardanoEras StandardCrypto))
-> ChainDB IO (HardForkBlock (CardanoEras StandardCrypto))
forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernel m addrNTN addrNTC blk -> ChainDB m blk
Consensus.getChainDB NodeKernel IO addrNTN addrNTC blk
NodeKernel
  IO addrNTN addrNTC (HardForkBlock (CardanoEras StandardCrypto))
kernel}
  BlockType blk
_ -> do
    Tracer IO Text -> Text -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO Text
tracer (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Text
pack (BlockType blk -> String
forall a. Show a => a -> String
show BlockType blk
blockType)
    Maybe NodeKernelAccess -> IO (Maybe NodeKernelAccess)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe NodeKernelAccess
forall a. Maybe a
Nothing

-- | Fetch a raw block and its block number from ChainDB by slot and header hash.
fetchBlock
  :: MonadIO m
  => NodeKernelAccess
  -- ^ Node kernel access handle
  -> SlotNo
  -- ^ Block slot number
  -> Hash BlockHeader
  -- ^ Block header hash
  -> m (Maybe (ByteString, BlockNo))
  -- ^ Raw CBOR bytes and block number, or 'Nothing' if not found
fetchBlock :: forall (m :: * -> *).
MonadIO m =>
NodeKernelAccess
-> SlotNo -> Hash BlockHeader -> m (Maybe (ByteString, BlockNo))
fetchBlock NodeKernelAccess{ChainDB IO (HardForkBlock (CardanoEras StandardCrypto))
nkaChainDB :: NodeKernelAccess
-> ChainDB IO (HardForkBlock (CardanoEras StandardCrypto))
nkaChainDB :: ChainDB IO (HardForkBlock (CardanoEras StandardCrypto))
nkaChainDB} 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, BlockNo)
component = (,) (ByteString -> BlockNo -> (ByteString, BlockNo))
-> BlockComponent
     (HardForkBlock (CardanoEras StandardCrypto)) ByteString
-> BlockComponent
     (HardForkBlock (CardanoEras StandardCrypto))
     (BlockNo -> (ByteString, BlockNo))
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))
  (BlockNo -> (ByteString, BlockNo))
-> BlockComponent
     (HardForkBlock (CardanoEras StandardCrypto)) BlockNo
-> BlockComponent
     (HardForkBlock (CardanoEras StandardCrypto)) (ByteString, BlockNo)
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) -> BlockNo)
-> BlockComponent
     (HardForkBlock (CardanoEras StandardCrypto))
     (HardForkBlock (CardanoEras StandardCrypto))
-> BlockComponent
     (HardForkBlock (CardanoEras StandardCrypto)) BlockNo
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) -> BlockNo
forall b. HasHeader b => b -> BlockNo
Consensus.blockNo BlockComponent
  (HardForkBlock (CardanoEras StandardCrypto))
  (HardForkBlock (CardanoEras StandardCrypto))
forall blk. BlockComponent blk blk
Consensus.GetBlock
  IO (Maybe (ByteString, BlockNo)) -> m (Maybe (ByteString, BlockNo))
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (ByteString, BlockNo))
 -> m (Maybe (ByteString, BlockNo)))
-> IO (Maybe (ByteString, BlockNo))
-> m (Maybe (ByteString, BlockNo))
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))
nkaChainDB BlockComponent
  (HardForkBlock (CardanoEras StandardCrypto)) (ByteString, BlockNo)
component RealPoint (HardForkBlock (CardanoEras StandardCrypto))
point

-- | Grab the current 'NodeKernelAccess' from the environment, or throw
-- gRPC UNAVAILABLE if the node kernel has not yet initialised.
grabNodeKernelAccess
  :: MonadRpc e m
  => m 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