{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -Wno-orphans #-}

-- | How the node's LeiosFetch server's events are logged.
module Ouroboros.Consensus.Tracing.LeiosFetch () where

import Cardano.Crypto.Hash (hashToStringAsHex)
import Cardano.Logging
import Control.Exception (displayException)
import Data.Aeson (Value (String), (.=))
import qualified Data.Text as Text
import Ouroboros.Consensus.Block (SlotNo (..))
import Ouroboros.Consensus.Leios.Types (LeiosPoint (..), prettyLeiosPoint)
import Ouroboros.Consensus.MiniProtocol.LeiosFetch.Server (ExnLeiosInvalidRequest (..))
import Ouroboros.Consensus.MiniProtocol.LeiosFetch.Trace (TraceLeiosFetchServerEvent (..))

-- The exceptions these events carry disconnect only the client, not the whole
-- node, so their fields are rendered for structured logging, rather than left
-- to the network layer's traces of the same exceptions, which 'show' them.
instance LogFormatting TraceLeiosFetchServerEvent where
  forMachine :: DetailLevel -> TraceLeiosFetchServerEvent -> Object
forMachine DetailLevel
_dtal = \case
    TraceLeiosFetchServerBlockRequested LeiosPoint
point ->
      [Object] -> Object
forall a. Monoid a => [a] -> a
mconcat [Key
"kind" Key -> Value -> Object
forall v. ToJSON v => Key -> v -> Object
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String Text
"BlockRequested", LeiosPoint -> Object
forall {a} {e}. (Monoid a, KeyValue e a) => LeiosPoint -> a
pointFields LeiosPoint
point]
    TraceLeiosFetchServerBlockServed LeiosPoint
point Int
txCount ->
      [Object] -> Object
forall a. Monoid a => [a] -> a
mconcat [Key
"kind" Key -> Value -> Object
forall v. ToJSON v => Key -> v -> Object
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String Text
"BlockServed", LeiosPoint -> Object
forall {a} {e}. (Monoid a, KeyValue e a) => LeiosPoint -> a
pointFields LeiosPoint
point, Key
"txCount" Key -> Int -> Object
forall v. ToJSON v => Key -> v -> Object
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Int
txCount]
    TraceLeiosFetchServerTxsRequested LeiosPoint
point Int
txCount ->
      [Object] -> Object
forall a. Monoid a => [a] -> a
mconcat [Key
"kind" Key -> Value -> Object
forall v. ToJSON v => Key -> v -> Object
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String Text
"TxsRequested", LeiosPoint -> Object
forall {a} {e}. (Monoid a, KeyValue e a) => LeiosPoint -> a
pointFields LeiosPoint
point, Key
"txCount" Key -> Int -> Object
forall v. ToJSON v => Key -> v -> Object
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Int
txCount]
    TraceLeiosFetchServerTxsServed LeiosPoint
point Int
txCount Int
bytes ->
      [Object] -> Object
forall a. Monoid a => [a] -> a
mconcat
        [Key
"kind" Key -> Value -> Object
forall v. ToJSON v => Key -> v -> Object
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String Text
"TxsServed", LeiosPoint -> Object
forall {a} {e}. (Monoid a, KeyValue e a) => LeiosPoint -> a
pointFields LeiosPoint
point, Key
"txCount" Key -> Int -> Object
forall v. ToJSON v => Key -> v -> Object
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Int
txCount, Key
"bytes" Key -> Int -> Object
forall v. ToJSON v => Key -> v -> Object
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Int
bytes]
    TraceLeiosFetchServerInvalidRequest ExnLeiosInvalidRequest
exn -> case ExnLeiosInvalidRequest
exn of
      ExnLeiosUnknownBlockRequested LeiosPoint
point ->
        [Object] -> Object
forall a. Monoid a => [a] -> a
mconcat [Key
"kind" Key -> Value -> Object
forall v. ToJSON v => Key -> v -> Object
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String Text
"UnknownBlock", LeiosPoint -> Object
forall {a} {e}. (Monoid a, KeyValue e a) => LeiosPoint -> a
pointFields LeiosPoint
point]
      ExnLeiosUnknownTxsRequested LeiosPoint
point [Int]
offsets ->
        [Object] -> Object
forall a. Monoid a => [a] -> a
mconcat [Key
"kind" Key -> Value -> Object
forall v. ToJSON v => Key -> v -> Object
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String Text
"UnknownTxs", LeiosPoint -> Object
forall {a} {e}. (Monoid a, KeyValue e a) => LeiosPoint -> a
pointFields LeiosPoint
point, Key
"offsets" Key -> [Int] -> Object
forall v. ToJSON v => Key -> v -> Object
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Int]
offsets]
    TraceLeiosFetchServerBlockDbFailure LeiosPoint
point LeiosDbException
err ->
      [Object] -> Object
forall a. Monoid a => [a] -> a
mconcat [Key
"kind" Key -> Value -> Object
forall v. ToJSON v => Key -> v -> Object
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String Text
"BlockDbFailure", LeiosPoint -> Object
forall {a} {e}. (Monoid a, KeyValue e a) => LeiosPoint -> a
pointFields LeiosPoint
point, Key
"exception" Key -> LeiosDbException -> Object
forall v. ToJSON v => Key -> v -> Object
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= LeiosDbException
err]
    TraceLeiosFetchServerTxsDbFailure LeiosPoint
point [(Word16, Word64)]
bitmaps LeiosDbException
err ->
      [Object] -> Object
forall a. Monoid a => [a] -> a
mconcat
        [ Key
"kind" Key -> Value -> Object
forall v. ToJSON v => Key -> v -> Object
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String Text
"TxsDbFailure"
        , LeiosPoint -> Object
forall {a} {e}. (Monoid a, KeyValue e a) => LeiosPoint -> a
pointFields LeiosPoint
point
        , Key
"bitmaps" Key -> [(Word16, Word64)] -> Object
forall v. ToJSON v => Key -> v -> Object
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [(Word16, Word64)]
bitmaps
        , Key
"exception" Key -> LeiosDbException -> Object
forall v. ToJSON v => Key -> v -> Object
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= LeiosDbException
err
        ]
    TraceLeiosFetchServerOpenReaderDbFailure LeiosDbException
err ->
      [Object] -> Object
forall a. Monoid a => [a] -> a
mconcat [Key
"kind" Key -> Value -> Object
forall v. ToJSON v => Key -> v -> Object
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String Text
"OpenReaderDbFailure", Key
"exception" Key -> LeiosDbException -> Object
forall v. ToJSON v => Key -> v -> Object
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= LeiosDbException
err]
   where
    pointFields :: LeiosPoint -> a
pointFields (MkLeiosPoint (SlotNo Word64
slot) EndorserBlockHash
ebHash) =
      [a] -> a
forall a. Monoid a => [a] -> a
mconcat [Key
"slot" Key -> Word64 -> a
forall v. ToJSON v => Key -> v -> a
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Word64
slot, Key
"ebHash" Key -> Value -> a
forall v. ToJSON v => Key -> v -> a
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String (String -> Text
Text.pack (EndorserBlockHash -> String
forall h a. Hash h a -> String
hashToStringAsHex EndorserBlockHash
ebHash))]

  forHuman :: TraceLeiosFetchServerEvent -> Text
forHuman = \case
    TraceLeiosFetchServerBlockRequested LeiosPoint
point ->
      Text
"Requested endorser block " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> LeiosPoint -> Text
pretty LeiosPoint
point
    TraceLeiosFetchServerBlockServed LeiosPoint
point Int
txCount ->
      Text
"Served endorser block " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> LeiosPoint -> Text
pretty LeiosPoint
point Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", referencing " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
showT Int
txCount Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" transactions"
    TraceLeiosFetchServerTxsRequested LeiosPoint
point Int
txCount ->
      Text
"Requested " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
showT Int
txCount Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" transactions of endorser block " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> LeiosPoint -> Text
pretty LeiosPoint
point
    TraceLeiosFetchServerTxsServed LeiosPoint
point Int
txCount Int
bytes ->
      Text
"Served "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
showT Int
txCount
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" transactions of endorser block "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> LeiosPoint -> Text
pretty LeiosPoint
point
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
showT Int
bytes
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" bytes"
    TraceLeiosFetchServerInvalidRequest ExnLeiosInvalidRequest
exn -> case ExnLeiosInvalidRequest
exn of
      ExnLeiosUnknownBlockRequested LeiosPoint
point ->
        Text
"Disconnecting a client that requested endorser block " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> LeiosPoint -> Text
pretty LeiosPoint
point Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", which is not held"
      ExnLeiosUnknownTxsRequested LeiosPoint
point [Int]
offsets ->
        Text
"Disconnecting a client that requested transactions of endorser block "
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> LeiosPoint -> Text
pretty LeiosPoint
point
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" at offsets "
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Int] -> Text
forall a. Show a => a -> Text
showT [Int]
offsets
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", which are not held"
    TraceLeiosFetchServerBlockDbFailure LeiosPoint
point LeiosDbException
err ->
      Text
"Disconnecting a client, since reading its requested endorser block "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> LeiosPoint -> Text
pretty LeiosPoint
point
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" from the LeiosDB failed: "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (LeiosDbException -> String
forall e. Exception e => e -> String
displayException LeiosDbException
err)
    TraceLeiosFetchServerTxsDbFailure LeiosPoint
point [(Word16, Word64)]
_bitmaps LeiosDbException
err ->
      Text
"Disconnecting a client, since reading its requested transactions of endorser block "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> LeiosPoint -> Text
pretty LeiosPoint
point
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" from the LeiosDB failed: "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (LeiosDbException -> String
forall e. Exception e => e -> String
displayException LeiosDbException
err)
    TraceLeiosFetchServerOpenReaderDbFailure LeiosDbException
err ->
      Text
"Disconnecting a client, since opening its LeiosDB reader failed: "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (LeiosDbException -> String
forall e. Exception e => e -> String
displayException LeiosDbException
err)
   where
    pretty :: LeiosPoint -> Text
pretty = String -> Text
Text.pack (String -> Text) -> (LeiosPoint -> String) -> LeiosPoint -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LeiosPoint -> String
prettyLeiosPoint

instance MetaTrace TraceLeiosFetchServerEvent where
  namespaceFor :: TraceLeiosFetchServerEvent -> Namespace TraceLeiosFetchServerEvent
namespaceFor = \case
    TraceLeiosFetchServerBlockRequested{} -> [Text] -> [Text] -> Namespace TraceLeiosFetchServerEvent
forall a. [Text] -> [Text] -> Namespace a
Namespace [] [Text
"BlockRequested"]
    TraceLeiosFetchServerBlockServed{} -> [Text] -> [Text] -> Namespace TraceLeiosFetchServerEvent
forall a. [Text] -> [Text] -> Namespace a
Namespace [] [Text
"BlockServed"]
    TraceLeiosFetchServerTxsRequested{} -> [Text] -> [Text] -> Namespace TraceLeiosFetchServerEvent
forall a. [Text] -> [Text] -> Namespace a
Namespace [] [Text
"TxsRequested"]
    TraceLeiosFetchServerTxsServed{} -> [Text] -> [Text] -> Namespace TraceLeiosFetchServerEvent
forall a. [Text] -> [Text] -> Namespace a
Namespace [] [Text
"TxsServed"]
    TraceLeiosFetchServerInvalidRequest ExnLeiosUnknownBlockRequested{} -> [Text] -> [Text] -> Namespace TraceLeiosFetchServerEvent
forall a. [Text] -> [Text] -> Namespace a
Namespace [] [Text
"UnknownBlock"]
    TraceLeiosFetchServerInvalidRequest ExnLeiosUnknownTxsRequested{} -> [Text] -> [Text] -> Namespace TraceLeiosFetchServerEvent
forall a. [Text] -> [Text] -> Namespace a
Namespace [] [Text
"UnknownTxs"]
    TraceLeiosFetchServerBlockDbFailure{} -> [Text] -> [Text] -> Namespace TraceLeiosFetchServerEvent
forall a. [Text] -> [Text] -> Namespace a
Namespace [] [Text
"BlockDbFailure"]
    TraceLeiosFetchServerTxsDbFailure{} -> [Text] -> [Text] -> Namespace TraceLeiosFetchServerEvent
forall a. [Text] -> [Text] -> Namespace a
Namespace [] [Text
"TxsDbFailure"]
    TraceLeiosFetchServerOpenReaderDbFailure{} -> [Text] -> [Text] -> Namespace TraceLeiosFetchServerEvent
forall a. [Text] -> [Text] -> Namespace a
Namespace [] [Text
"OpenReaderDbFailure"]

  severityFor :: Namespace TraceLeiosFetchServerEvent
-> Maybe TraceLeiosFetchServerEvent -> Maybe SeverityS
severityFor (Namespace [Text]
_ [Text
"BlockRequested"]) Maybe TraceLeiosFetchServerEvent
_ = SeverityS -> Maybe SeverityS
forall a. a -> Maybe a
Just SeverityS
Debug
  severityFor (Namespace [Text]
_ [Text
"BlockServed"]) Maybe TraceLeiosFetchServerEvent
_ = SeverityS -> Maybe SeverityS
forall a. a -> Maybe a
Just SeverityS
Info
  severityFor (Namespace [Text]
_ [Text
"TxsRequested"]) Maybe TraceLeiosFetchServerEvent
_ = SeverityS -> Maybe SeverityS
forall a. a -> Maybe a
Just SeverityS
Debug
  severityFor (Namespace [Text]
_ [Text
"TxsServed"]) Maybe TraceLeiosFetchServerEvent
_ = SeverityS -> Maybe SeverityS
forall a. a -> Maybe a
Just SeverityS
Info
  severityFor (Namespace [Text]
_ [Text
"UnknownBlock"]) Maybe TraceLeiosFetchServerEvent
_ = SeverityS -> Maybe SeverityS
forall a. a -> Maybe a
Just SeverityS
Notice
  severityFor (Namespace [Text]
_ [Text
"UnknownTxs"]) Maybe TraceLeiosFetchServerEvent
_ = SeverityS -> Maybe SeverityS
forall a. a -> Maybe a
Just SeverityS
Notice
  severityFor (Namespace [Text]
_ [Text
"BlockDbFailure"]) Maybe TraceLeiosFetchServerEvent
_ = SeverityS -> Maybe SeverityS
forall a. a -> Maybe a
Just SeverityS
Error
  severityFor (Namespace [Text]
_ [Text
"TxsDbFailure"]) Maybe TraceLeiosFetchServerEvent
_ = SeverityS -> Maybe SeverityS
forall a. a -> Maybe a
Just SeverityS
Error
  severityFor (Namespace [Text]
_ [Text
"OpenReaderDbFailure"]) Maybe TraceLeiosFetchServerEvent
_ = SeverityS -> Maybe SeverityS
forall a. a -> Maybe a
Just SeverityS
Error
  severityFor Namespace TraceLeiosFetchServerEvent
_ Maybe TraceLeiosFetchServerEvent
_ = Maybe SeverityS
forall a. Maybe a
Nothing

  documentFor :: Namespace TraceLeiosFetchServerEvent -> Maybe Text
documentFor (Namespace [Text]
_ [Text
"BlockRequested"]) =
    Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"A client requested an endorser block."
  documentFor (Namespace [Text]
_ [Text
"BlockServed"]) =
    Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"The server sent a client an endorser block."
  documentFor (Namespace [Text]
_ [Text
"TxsRequested"]) =
    Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"A client requested some of an endorser block's transactions."
  documentFor (Namespace [Text]
_ [Text
"TxsServed"]) =
    Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"The server sent a client some of an endorser block's transactions."
  documentFor (Namespace [Text]
_ [Text
"UnknownBlock"]) =
    Text -> Maybe Text
forall a. a -> Maybe a
Just
      Text
"A client requested an endorser block that the node does not hold, so the server disconnects it."
  documentFor (Namespace [Text]
_ [Text
"UnknownTxs"]) =
    Text -> Maybe Text
forall a. a -> Maybe a
Just
      Text
"A client requested transactions that the node does not hold, so the server disconnects it."
  documentFor (Namespace [Text]
_ [Text
"BlockDbFailure"]) =
    Text -> Maybe Text
forall a. a -> Maybe a
Just
      Text
"Reading a client's requested endorser block from the LeiosDB failed, so the server disconnects the client."
  documentFor (Namespace [Text]
_ [Text
"TxsDbFailure"]) =
    Text -> Maybe Text
forall a. a -> Maybe a
Just
      Text
"Reading a client's requested transactions from the LeiosDB failed, so the server disconnects the client."
  documentFor (Namespace [Text]
_ [Text
"OpenReaderDbFailure"]) =
    Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"Opening the server's LeiosDB reader failed, so the server disconnects the client."
  documentFor Namespace TraceLeiosFetchServerEvent
_ = Maybe Text
forall a. Maybe a
Nothing

  allNamespaces :: [Namespace TraceLeiosFetchServerEvent]
allNamespaces =
    [ [Text] -> [Text] -> Namespace TraceLeiosFetchServerEvent
forall a. [Text] -> [Text] -> Namespace a
Namespace [] [Text
"BlockRequested"]
    , [Text] -> [Text] -> Namespace TraceLeiosFetchServerEvent
forall a. [Text] -> [Text] -> Namespace a
Namespace [] [Text
"BlockServed"]
    , [Text] -> [Text] -> Namespace TraceLeiosFetchServerEvent
forall a. [Text] -> [Text] -> Namespace a
Namespace [] [Text
"TxsRequested"]
    , [Text] -> [Text] -> Namespace TraceLeiosFetchServerEvent
forall a. [Text] -> [Text] -> Namespace a
Namespace [] [Text
"TxsServed"]
    , [Text] -> [Text] -> Namespace TraceLeiosFetchServerEvent
forall a. [Text] -> [Text] -> Namespace a
Namespace [] [Text
"UnknownBlock"]
    , [Text] -> [Text] -> Namespace TraceLeiosFetchServerEvent
forall a. [Text] -> [Text] -> Namespace a
Namespace [] [Text
"UnknownTxs"]
    , [Text] -> [Text] -> Namespace TraceLeiosFetchServerEvent
forall a. [Text] -> [Text] -> Namespace a
Namespace [] [Text
"BlockDbFailure"]
    , [Text] -> [Text] -> Namespace TraceLeiosFetchServerEvent
forall a. [Text] -> [Text] -> Namespace a
Namespace [] [Text
"TxsDbFailure"]
    , [Text] -> [Text] -> Namespace TraceLeiosFetchServerEvent
forall a. [Text] -> [Text] -> Namespace a
Namespace [] [Text
"OpenReaderDbFailure"]
    ]