{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}

{-# OPTIONS_GHC -Wno-orphans #-}

module Cardano.Tracing.OrphanInstances.Common
  (
    -- * ToObject and helpers
    ToObject(..)
  , TracingVerbosity(..)
  , mkObject
  , emptyObject
  , ToJSON
  , Value (..)
  , toJSON
  , (.=)

    -- * Transformable and helpers
  , Transformable(..)
  , trStructured
  , trStructuredText
  , HasTextFormatter(..)

    -- * Severity and Privacy
  , HasSeverityAnnotation(..)
  , Severity(..)
  , HasPrivacyAnnotation(..)
  , PrivacyAnnotation(..)

    -- * Tracer and related
  , Tracer
  , LogObject(..)
  , LOContent(..)
  , mkLOMeta
  ) where

import           Cardano.Prelude
import qualified Prelude

import           Data.Aeson
import qualified Data.ByteString.Base16 as B16
import qualified Data.ByteString.Short as SBS
import           Data.Scientific (coefficient)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import           Network.Socket (PortNumber)

import           Cardano.BM.Data.LogItem (LOContent (..), LogObject (..), PrivacyAnnotation (..),
                     mkLOMeta)
import           Cardano.BM.Data.Tracer (HasTextFormatter (..), emptyObject, mkObject, trStructured,
                     trStructuredText)
import           Cardano.BM.Tracing (HasPrivacyAnnotation (..), HasSeverityAnnotation (..),
                     Severity (..), ToObject (..), Tracer (..), TracingVerbosity (..),
                     Transformable (..))
import qualified Cardano.Chain.Update as Update
import           Cardano.Slotting.Block (BlockNo (..))
import           Ouroboros.Consensus.Byron.Ledger.Block (ByronHash (..))
import           Ouroboros.Consensus.HardFork.Combinator (OneEraHash (..))
import           Ouroboros.Network.Block (HeaderHash, Tip (..))


-- | 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 ToObject Void where
  toObject :: TracingVerbosity -> Void -> Object
toObject TracingVerbosity
_verb Void
x = case Void
x of {}

deriving instance Show TracingVerbosity

instance FromJSON TracingVerbosity where
  parseJSON :: Value -> Parser TracingVerbosity
parseJSON (String Text
str) = case Text
str of
    Text
"MinimalVerbosity" -> TracingVerbosity -> Parser TracingVerbosity
forall (f :: * -> *) a. Applicative f => a -> f a
pure TracingVerbosity
MinimalVerbosity
    Text
"MaximalVerbosity" -> TracingVerbosity -> Parser TracingVerbosity
forall (f :: * -> *) a. Applicative f => a -> f a
pure TracingVerbosity
MaximalVerbosity
    Text
"NormalVerbosity" -> TracingVerbosity -> Parser TracingVerbosity
forall (f :: * -> *) a. Applicative f => a -> f a
pure TracingVerbosity
NormalVerbosity
    Text
err -> Text -> Parser TracingVerbosity
forall a. HasCallStack => Text -> a
panic (Text -> Parser TracingVerbosity)
-> Text -> Parser TracingVerbosity
forall a b. (a -> b) -> a -> b
$ Text
"Parsing of TracingVerbosity failed, "
                 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
err Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" is not a valid TracingVerbosity"
  parseJSON Value
invalid  = Text -> Parser TracingVerbosity
forall a. HasCallStack => Text -> a
panic (Text -> Parser TracingVerbosity)
-> Text -> Parser TracingVerbosity
forall a b. (a -> b) -> a -> b
$ Text
"Parsing of TracingVerbosity failed due to type mismatch. "
                             Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"Encountered: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (Value -> String
forall a. Show a => a -> String
Prelude.show Value
invalid)

instance FromJSON PortNumber where
  parseJSON :: Value -> Parser PortNumber
parseJSON (Number Scientific
portNum) = case String -> Maybe PortNumber
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe PortNumber)
-> (Integer -> String) -> Integer -> Maybe PortNumber
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Integer -> String
forall a b. (Show a, ConvertText String b) => a -> b
show (Integer -> Maybe PortNumber) -> Integer -> Maybe PortNumber
forall a b. (a -> b) -> a -> b
$ Scientific -> Integer
coefficient Scientific
portNum of
    Just PortNumber
port -> PortNumber -> Parser PortNumber
forall (f :: * -> *) a. Applicative f => a -> f a
pure PortNumber
port
    Maybe PortNumber
Nothing -> Text -> Parser PortNumber
forall a. HasCallStack => Text -> a
panic (Text -> Parser PortNumber) -> Text -> Parser PortNumber
forall a b. (a -> b) -> a -> b
$ Scientific -> Text
forall a b. (Show a, ConvertText String b) => a -> b
show Scientific
portNum Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" is not a valid port number."
  parseJSON Value
invalid  = Text -> Parser PortNumber
forall a. HasCallStack => Text -> a
panic (Text -> Parser PortNumber) -> Text -> Parser PortNumber
forall a b. (a -> b) -> a -> b
$ Text
"Parsing of port number failed due to type mismatch. "
                             Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"Encountered: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (Value -> String
forall a. Show a => a -> String
Prelude.show Value
invalid)

instance FromJSON Update.ApplicationName where
  parseJSON :: Value -> Parser ApplicationName
parseJSON (String Text
x) = ApplicationName -> Parser ApplicationName
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ApplicationName -> Parser ApplicationName)
-> ApplicationName -> Parser ApplicationName
forall a b. (a -> b) -> a -> b
$ Text -> ApplicationName
Update.ApplicationName Text
x
  parseJSON Value
invalid  =
    Text -> Parser ApplicationName
forall a. HasCallStack => Text -> a
panic (Text -> Parser ApplicationName) -> Text -> Parser ApplicationName
forall a b. (a -> b) -> a -> b
$ Text
"Parsing of application name failed due to type mismatch. "
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"Encountered: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (Value -> String
forall a. Show a => a -> String
Prelude.show Value
invalid)

instance ToJSON (HeaderHash blk) => ToJSON (Tip blk) where
  toJSON :: Tip blk -> Value
toJSON Tip blk
TipGenesis = [Pair] -> Value
object [ Text
"genesis" Text -> Bool -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Bool
True ]
  toJSON (Tip SlotNo
slotNo HeaderHash blk
headerHash BlockNo
blockNo) =
    [Pair] -> Value
object
      [ Text
"slotNo"     Text -> SlotNo -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= SlotNo
slotNo
      , Text
"headerHash" Text -> HeaderHash blk -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= HeaderHash blk
headerHash
      , Text
"blockNo"    Text -> BlockNo -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= BlockNo
blockNo
      ]

instance ToJSON (OneEraHash xs) where
  toJSON :: OneEraHash xs -> Value
toJSON (OneEraHash ShortByteString
bs) =
    Text -> Value
forall a. ToJSON a => a -> Value
toJSON (Text -> Value)
-> (ShortByteString -> Text) -> ShortByteString -> Value
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ByteString -> Text
Text.decodeLatin1 (ByteString -> Text)
-> (ShortByteString -> ByteString) -> ShortByteString -> Text
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ByteString -> ByteString
B16.encode (ByteString -> ByteString)
-> (ShortByteString -> ByteString) -> ShortByteString -> ByteString
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ShortByteString -> ByteString
SBS.fromShort (ShortByteString -> Value) -> ShortByteString -> Value
forall a b. (a -> b) -> a -> b
$ ShortByteString
bs

deriving newtype instance ToJSON ByronHash
deriving newtype instance ToJSON BlockNo