{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}

-- | Provides datatypes used in tracing
module Cardano.Rpc.Server.Internal.Tracing where

import Cardano.Api (SlotNo)
import Cardano.Api.Consensus (TxValidationErrorInCardanoMode)
import Cardano.Api.Era (Inject (..))
import Cardano.Api.Error
import Cardano.Api.Pretty
import Cardano.Api.Serialise.Cbor (DecoderError)
import Cardano.Api.Serialise.Raw (SerialiseAsRawBytesError)
import Cardano.Api.Serialise.SerialiseUsing

import Control.Exception
import Data.Word (Word64)

-- | A sum type representing all possible traces
data TraceRpc
  = TraceRpcQuery TraceRpcQuery
  | TraceRpcSubmit TraceRpcSubmit
  | TraceRpcSync TraceRpcSync
  | TraceRpcError SomeException
  | TraceRpcFatalError SomeException

-- | Traces used in Query service
data TraceRpcQuery
  = -- | Span trace marking ReadParams query
    TraceRpcQueryParamsSpan TraceSpanEvent
  | -- | Span trace marking ReadUtxos query
    TraceRpcQueryReadUtxosSpan TraceSpanEvent
  | -- | Span trace marking SearchUtxos query
    TraceRpcQuerySearchUtxosSpan TraceSpanEvent
  deriving Int -> TraceRpcQuery -> ShowS
[TraceRpcQuery] -> ShowS
TraceRpcQuery -> String
(Int -> TraceRpcQuery -> ShowS)
-> (TraceRpcQuery -> String)
-> ([TraceRpcQuery] -> ShowS)
-> Show TraceRpcQuery
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TraceRpcQuery -> ShowS
showsPrec :: Int -> TraceRpcQuery -> ShowS
$cshow :: TraceRpcQuery -> String
show :: TraceRpcQuery -> String
$cshowList :: [TraceRpcQuery] -> ShowS
showList :: [TraceRpcQuery] -> ShowS
Show

instance Pretty TraceRpc where
  pretty :: forall ann. TraceRpc -> Doc ann
pretty = \case
    TraceRpcQuery TraceRpcQuery
t -> TraceRpcQuery -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. TraceRpcQuery -> Doc ann
pretty TraceRpcQuery
t
    TraceRpcSubmit TraceRpcSubmit
t -> TraceRpcSubmit -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. TraceRpcSubmit -> Doc ann
pretty TraceRpcSubmit
t
    TraceRpcSync TraceRpcSync
t -> TraceRpcSync -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. TraceRpcSync -> Doc ann
pretty TraceRpcSync
t
    TraceRpcError SomeException
e -> Doc ann
"Exception when processing RPC request:\n" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> SomeException -> Doc ann
forall a ann. Exception a => a -> Doc ann
prettyException SomeException
e
    TraceRpcFatalError SomeException
e -> Doc ann
"RPC server fatal error: " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> SomeException -> Doc ann
forall a ann. Exception a => a -> Doc ann
prettyException SomeException
e

-- | Span type
data TraceSpanEvent
  = -- | Opening span trace
    SpanBegin SpanId
  | -- | Ending span trace
    SpanEnd SpanId
  deriving Int -> TraceSpanEvent -> ShowS
[TraceSpanEvent] -> ShowS
TraceSpanEvent -> String
(Int -> TraceSpanEvent -> ShowS)
-> (TraceSpanEvent -> String)
-> ([TraceSpanEvent] -> ShowS)
-> Show TraceSpanEvent
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TraceSpanEvent -> ShowS
showsPrec :: Int -> TraceSpanEvent -> ShowS
$cshow :: TraceSpanEvent -> String
show :: TraceSpanEvent -> String
$cshowList :: [TraceSpanEvent] -> ShowS
showList :: [TraceSpanEvent] -> ShowS
Show

-- | 8-byte span ID, serialised in hex.
type SpanId = UsingRawBytesHex Word64

instance Pretty TraceRpcQuery where
  pretty :: forall ann. TraceRpcQuery -> Doc ann
pretty = \case
    TraceRpcQueryParamsSpan (SpanBegin UsingRawBytesHex Word64
_) -> Doc ann
"Started query params method"
    TraceRpcQueryParamsSpan (SpanEnd UsingRawBytesHex Word64
_) -> Doc ann
"Finished query params method"
    TraceRpcQueryReadUtxosSpan (SpanBegin UsingRawBytesHex Word64
_) -> Doc ann
"Started query read UTXO method"
    TraceRpcQueryReadUtxosSpan (SpanEnd UsingRawBytesHex Word64
_) -> Doc ann
"Finished query read UTXO method"
    TraceRpcQuerySearchUtxosSpan (SpanBegin UsingRawBytesHex Word64
_) -> Doc ann
"Started query search UTXO method"
    TraceRpcQuerySearchUtxosSpan (SpanEnd UsingRawBytesHex Word64
_) -> Doc ann
"Finished query search UTXO method"

instance Error TraceRpcQuery where
  prettyError :: forall ann. TraceRpcQuery -> Doc ann
prettyError = TraceRpcQuery -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. TraceRpcQuery -> Doc ann
pretty

-- | Traces used in SubmitTx service
data TraceRpcSubmit
  = -- | Node-to-client connection error during submission
    TraceRpcSubmitN2cConnectionError SomeException
  | -- | Transaction deserialisation error
    TraceRpcSubmitTxDecodingError DecoderError
  | -- | Transaction submission error
    TraceRpcSubmitTxValidationError TxValidationErrorInCardanoMode
  | -- | Transaction submission span
    TraceRpcSubmitSpan TraceSpanEvent
  | -- | Transaction evaluation deserialisation error
    TraceRpcEvalTxDecodingError SerialiseAsRawBytesError
  | -- | Transaction evaluation span
    TraceRpcEvalTxSpan TraceSpanEvent
  deriving Int -> TraceRpcSubmit -> ShowS
[TraceRpcSubmit] -> ShowS
TraceRpcSubmit -> String
(Int -> TraceRpcSubmit -> ShowS)
-> (TraceRpcSubmit -> String)
-> ([TraceRpcSubmit] -> ShowS)
-> Show TraceRpcSubmit
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TraceRpcSubmit -> ShowS
showsPrec :: Int -> TraceRpcSubmit -> ShowS
$cshow :: TraceRpcSubmit -> String
show :: TraceRpcSubmit -> String
$cshowList :: [TraceRpcSubmit] -> ShowS
showList :: [TraceRpcSubmit] -> ShowS
Show

instance Pretty TraceRpcSubmit where
  pretty :: forall ann. TraceRpcSubmit -> Doc ann
pretty = \case
    TraceRpcSubmitSpan (SpanBegin UsingRawBytesHex Word64
_) -> Doc ann
"Started submit method"
    TraceRpcSubmitSpan (SpanEnd UsingRawBytesHex Word64
_) -> Doc ann
"Finished submit method"
    TraceRpcEvalTxSpan (SpanBegin UsingRawBytesHex Word64
_) -> Doc ann
"Started eval tx method"
    TraceRpcEvalTxSpan (SpanEnd UsingRawBytesHex Word64
_) -> Doc ann
"Finished eval tx method"
    TraceRpcEvalTxDecodingError SerialiseAsRawBytesError
e -> Doc ann
"Failed to decode transaction for evaluation: " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> SerialiseAsRawBytesError -> Doc ann
forall a ann. Show a => a -> Doc ann
pshow SerialiseAsRawBytesError
e
    TraceRpcSubmitN2cConnectionError SomeException
e -> Doc ann
"N2C connection error while trying to submit a transaction: " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> SomeException -> Doc ann
forall a ann. Exception a => a -> Doc ann
prettyException SomeException
e
    TraceRpcSubmitTxDecodingError DecoderError
e -> Doc ann
"Failed to decode transaction: " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> DecoderError -> Doc ann
forall a ann. Show a => a -> Doc ann
pshow DecoderError
e
    TraceRpcSubmitTxValidationError TxValidationErrorInCardanoMode
e -> Doc ann
"Failed to submit transaction: " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> TxValidationErrorInCardanoMode -> Doc ann
forall a ann. Show a => a -> Doc ann
pshow TxValidationErrorInCardanoMode
e

instance Error TraceRpcSubmit where
  prettyError :: forall ann. TraceRpcSubmit -> Doc ann
prettyError = TraceRpcSubmit -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. TraceRpcSubmit -> Doc ann
pretty

-- | Traces used in SyncService (FetchBlock, FollowTip)
data TraceRpcSync
  = -- | FetchBlock span
    TraceRpcFetchBlockSpan TraceSpanEvent
  | -- | Requested block was not found
    TraceRpcFetchBlockNotFound SlotNo
  | -- | Node kernel access is not yet available
    TraceRpcNodeKernelAccessUnavailable
  | -- | Ledger forker error
    TraceRpcForkerError String
  deriving Int -> TraceRpcSync -> ShowS
[TraceRpcSync] -> ShowS
TraceRpcSync -> String
(Int -> TraceRpcSync -> ShowS)
-> (TraceRpcSync -> String)
-> ([TraceRpcSync] -> ShowS)
-> Show TraceRpcSync
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TraceRpcSync -> ShowS
showsPrec :: Int -> TraceRpcSync -> ShowS
$cshow :: TraceRpcSync -> String
show :: TraceRpcSync -> String
$cshowList :: [TraceRpcSync] -> ShowS
showList :: [TraceRpcSync] -> ShowS
Show

instance Pretty TraceRpcSync where
  pretty :: forall ann. TraceRpcSync -> Doc ann
pretty = \case
    TraceRpcFetchBlockSpan (SpanBegin UsingRawBytesHex Word64
_) -> Doc ann
"Started FetchBlock method"
    TraceRpcFetchBlockSpan (SpanEnd UsingRawBytesHex Word64
_) -> Doc ann
"Finished FetchBlock method"
    TraceRpcFetchBlockNotFound SlotNo
slot -> Doc ann
"Block not found at slot " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> SlotNo -> Doc ann
forall a ann. Show a => a -> Doc ann
pshow SlotNo
slot
    TraceRpcSync
TraceRpcNodeKernelAccessUnavailable -> Doc ann
"Node kernel access not yet initialised"
    TraceRpcForkerError String
e -> Doc ann
"Ledger forker error: " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
e

instance Error TraceRpcSync where
  prettyError :: forall ann. TraceRpcSync -> Doc ann
prettyError = TraceRpcSync -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. TraceRpcSync -> Doc ann
pretty

instance Inject TraceRpcSubmit TraceRpc where
  inject :: TraceRpcSubmit -> TraceRpc
inject = TraceRpcSubmit -> TraceRpc
TraceRpcSubmit

instance Inject TraceRpcQuery TraceRpc where
  inject :: TraceRpcQuery -> TraceRpc
inject = TraceRpcQuery -> TraceRpc
TraceRpcQuery

instance Inject TraceRpcSync TraceRpc where
  inject :: TraceRpcSync -> TraceRpc
inject = TraceRpcSync -> TraceRpc
TraceRpcSync