{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Ouroboros.Consensus.Tracing.Formatting
  (
  ) where

import Cardano.Logging (LogFormatting (..))
import Data.Aeson (Value (String), toJSON, (.=))
import Data.Proxy (Proxy (..))
import Data.Void (Void)
import Ouroboros.Consensus.Block
  ( ConvertRawHash (..)
  , Header
  , RealPoint
  , realPointHash
  , realPointSlot
  )
import Ouroboros.Consensus.Tracing.Render
import qualified Ouroboros.Network.AnchoredFragment as AF
import Ouroboros.Network.Block

-- | Derives ConvertRawHash for Header blk from ConvertRawHash blk.
-- Safe because HeaderHash (Header blk) = HeaderHash blk.
instance ConvertRawHash blk => ConvertRawHash (Header blk) where
  type HashSize (Header blk) = HashSize blk
  toShortRawHash :: forall (proxy :: * -> *).
proxy (Header blk) -> HeaderHash (Header blk) -> ShortByteString
toShortRawHash proxy (Header blk)
_ = Proxy blk -> HeaderHash blk -> ShortByteString
forall blk (proxy :: * -> *).
ConvertRawHash blk =>
proxy blk -> HeaderHash blk -> ShortByteString
forall (proxy :: * -> *).
proxy blk -> HeaderHash blk -> ShortByteString
toShortRawHash (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @blk)
  unsafeFromShortRawHash :: forall (proxy :: * -> *).
proxy (Header blk) -> ShortByteString -> HeaderHash (Header blk)
unsafeFromShortRawHash proxy (Header blk)
_ = Proxy blk -> ShortByteString -> HeaderHash blk
forall blk (proxy :: * -> *).
ConvertRawHash blk =>
proxy blk -> ShortByteString -> HeaderHash blk
forall (proxy :: * -> *).
proxy blk -> ShortByteString -> HeaderHash blk
unsafeFromShortRawHash (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @blk)

-- | A bit of a weird one, but needed because some of the very general
-- consensus interfaces are sometimes instantiated to 'Void', when there are
-- no cases needed.
instance LogFormatting Void where
  forMachine :: DetailLevel -> Void -> Object
forMachine DetailLevel
_dtal Void
_x = Object
forall a. Monoid a => a
mempty

instance LogFormatting () where
  forMachine :: DetailLevel -> () -> Object
forMachine DetailLevel
_dtal ()
_x = Object
forall a. Monoid a => a
mempty

instance LogFormatting SlotNo where
  forMachine :: DetailLevel -> SlotNo -> Object
forMachine DetailLevel
_dtal SlotNo
slot =
    [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
"SlotNo"
      , Key
"slot" Key -> Value -> Object
forall v. ToJSON v => Key -> v -> Object
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Word64 -> Value
forall a. ToJSON a => a -> Value
toJSON (SlotNo -> Word64
unSlotNo SlotNo
slot)
      ]

instance
  forall blk.
  ConvertRawHash blk =>
  LogFormatting (Point blk)
  where
  forHuman :: Point blk -> Text
forHuman = Point blk -> Text
forall blk. ConvertRawHash blk => Point blk -> Text
renderPointAsPhrase

  forMachine :: DetailLevel -> Point blk -> Object
forMachine DetailLevel
_dtal Point blk
GenesisPoint =
    [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
"GenesisPoint"]
  forMachine DetailLevel
dtal (BlockPoint SlotNo
slot HeaderHash blk
h) =
    [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
"BlockPoint"
      , Key
"slot" Key -> Value -> Object
forall v. ToJSON v => Key -> v -> Object
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Word64 -> Value
forall a. ToJSON a => a -> Value
toJSON (SlotNo -> Word64
unSlotNo SlotNo
slot)
      , Key
"headerHash" Key -> Text -> Object
forall v. ToJSON v => Key -> v -> Object
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Proxy blk -> DetailLevel -> HeaderHash blk -> Text
forall blk (proxy :: * -> *).
ConvertRawHash blk =>
proxy blk -> DetailLevel -> HeaderHash blk -> Text
renderHeaderHashForDetails (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @blk) DetailLevel
dtal HeaderHash blk
h
      ]

instance
  ConvertRawHash blk =>
  LogFormatting (RealPoint blk)
  where
  forHuman :: RealPoint blk -> Text
forHuman = RealPoint blk -> Text
forall blk. ConvertRawHash blk => RealPoint blk -> Text
renderRealPointAsPhrase

  forMachine :: DetailLevel -> RealPoint blk -> Object
forMachine DetailLevel
dtal RealPoint blk
p =
    [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
"Point"
      , Key
"slot" Key -> Word64 -> Object
forall v. ToJSON v => Key -> v -> Object
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= SlotNo -> Word64
unSlotNo (RealPoint blk -> SlotNo
forall blk. RealPoint blk -> SlotNo
realPointSlot RealPoint blk
p)
      , Key
"hash" Key -> Text -> Object
forall v. ToJSON v => Key -> v -> Object
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Proxy blk -> DetailLevel -> HeaderHash blk -> Text
forall blk (proxy :: * -> *).
ConvertRawHash blk =>
proxy blk -> DetailLevel -> HeaderHash blk -> Text
renderHeaderHashForDetails (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @blk) DetailLevel
dtal (RealPoint blk -> HeaderHash blk
forall blk. RealPoint blk -> HeaderHash blk
realPointHash RealPoint blk
p)
      ]

instance ConvertRawHash blk => LogFormatting (AF.Anchor blk) where
  forMachine :: DetailLevel -> Anchor blk -> Object
forMachine DetailLevel
dtal = \case
    Anchor blk
AF.AnchorGenesis ->
      [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
"AnchorGenesis"]
    AF.Anchor SlotNo
slot HeaderHash blk
hash BlockNo
bno ->
      [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
"Anchor"
        , Key
"slot" Key -> Value -> Object
forall v. ToJSON v => Key -> v -> Object
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Word64 -> Value
forall a. ToJSON a => a -> Value
toJSON (SlotNo -> Word64
unSlotNo SlotNo
slot)
        , Key
"headerHash" Key -> Text -> Object
forall v. ToJSON v => Key -> v -> Object
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Proxy blk -> DetailLevel -> HeaderHash blk -> Text
forall blk (proxy :: * -> *).
ConvertRawHash blk =>
proxy blk -> DetailLevel -> HeaderHash blk -> Text
renderHeaderHashForDetails (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @blk) DetailLevel
dtal HeaderHash blk
hash
        , Key
"blockNo" Key -> Value -> Object
forall v. ToJSON v => Key -> v -> Object
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Word64 -> Value
forall a. ToJSON a => a -> Value
toJSON (BlockNo -> Word64
unBlockNo BlockNo
bno)
        ]

instance (ConvertRawHash blk, HasHeader blk) => LogFormatting (AF.AnchoredFragment blk) where
  forMachine :: DetailLevel -> AnchoredFragment blk -> Object
forMachine DetailLevel
dtal AnchoredFragment blk
frag =
    [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
"AnchoredFragment"
      , Key
"anchor" Key -> Object -> Object
forall v. ToJSON v => Key -> v -> Object
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= DetailLevel -> Anchor blk -> Object
forall a. LogFormatting a => DetailLevel -> a -> Object
forMachine DetailLevel
dtal (AnchoredFragment blk -> Anchor blk
forall v a b. AnchoredSeq v a b -> a
AF.anchor AnchoredFragment blk
frag)
      , Key
"headPoint" Key -> Object -> Object
forall v. ToJSON v => Key -> v -> Object
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= DetailLevel -> Point blk -> Object
forall a. LogFormatting a => DetailLevel -> a -> Object
forMachine DetailLevel
dtal (AnchoredFragment blk -> Point blk
forall block.
HasHeader block =>
AnchoredFragment block -> Point block
AF.headPoint AnchoredFragment blk
frag)
      , Key
"length" Key -> Value -> Object
forall v. ToJSON v => Key -> v -> Object
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Int -> Value
forall a. ToJSON a => a -> Value
toJSON (AnchoredFragment blk -> Int
forall v a b. Anchorable v a b => AnchoredSeq v a b -> Int
AF.length AnchoredFragment blk
frag)
      ]