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

{-# OPTIONS_GHC -Wno-orphans #-}

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

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

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

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

import           Bcc.Prelude
import           Prelude (fail)

import           Data.Aeson hiding (Value)
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           Bcc.BM.Data.LogItem (LOContent (..), LogObject (..), PrivacyAnnotation (..),
                   mkLOMeta)
import           Bcc.BM.Data.Tracer (HasTextFormatter (..), emptyObject, mkObject, trStructured,
                   trStructuredText)
import           Bcc.BM.Stats
import           Bcc.BM.Tracing (HasPrivacyAnnotation (..), HasSeverityAnnotation (..),
                   Severity (..), ToObject (..), Tracer (..), TracingVerbosity (..),
                   Transformable (..))
import qualified Bcc.Chain.Update as Update
import           Bcc.Slotting.Block (BlockNo (..))
import           Shardagnostic.Consensus.Cole.Ledger.Block (ColeHash (..))
import           Shardagnostic.Consensus.HardFork.Combinator (OneEraHash (..))
import           Shardagnostic.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
invalid -> String -> Parser TracingVerbosity
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser TracingVerbosity)
-> String -> Parser TracingVerbosity
forall a b. (a -> b) -> a -> b
$ String
"Parsing of TracingVerbosity failed, "
                    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
Text.unpack Text
invalid String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" is not a valid TracingVerbosity"
  parseJSON Value
invalid  = String -> Parser TracingVerbosity
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser TracingVerbosity)
-> String -> Parser TracingVerbosity
forall a b. (a -> b) -> a -> b
$ String
"Parsing of TracingVerbosity failed due to type mismatch. "
                            String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"Encountered: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Value -> String
forall a b. (Show a, ConvertText String b) => a -> b
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 -> String -> Parser PortNumber
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser PortNumber) -> String -> Parser PortNumber
forall a b. (a -> b) -> a -> b
$ Scientific -> String
forall a b. (Show a, ConvertText String b) => a -> b
show Scientific
portNum String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" is not a valid port number."
  parseJSON Value
invalid  = String -> Parser PortNumber
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser PortNumber) -> String -> Parser PortNumber
forall a b. (a -> b) -> a -> b
$ String
"Parsing of port number failed due to type mismatch. "
                            String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"Encountered: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Value -> String
forall a b. (Show a, ConvertText String b) => a -> b
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  =
    String -> Parser ApplicationName
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser ApplicationName)
-> String -> Parser ApplicationName
forall a b. (a -> b) -> a -> b
$ String
"Parsing of application name failed due to type mismatch. "
    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"Encountered: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Value -> String
forall a b. (Show a, ConvertText String b) => a -> b
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 ColeHash
deriving newtype instance ToJSON BlockNo

instance HasPrivacyAnnotation  ResourceStats
instance HasSeverityAnnotation ResourceStats where
  getSeverityAnnotation :: ResourceStats -> Severity
getSeverityAnnotation ResourceStats
_ = Severity
Info
instance Transformable Text IO ResourceStats where
  trTransformer :: TracingVerbosity -> Trace IO Text -> Tracer IO ResourceStats
trTransformer = TracingVerbosity -> Trace IO Text -> Tracer IO ResourceStats
forall b (m :: * -> *) a.
(ToObject b, MonadIO m, HasPrivacyAnnotation b,
 HasSeverityAnnotation b) =>
TracingVerbosity -> Trace m a -> Tracer m b
trStructured

instance ToObject ResourceStats where
  toObject :: TracingVerbosity -> ResourceStats -> Object
toObject TracingVerbosity
_verb ResourceStats
stats =
    case ResourceStats -> Value
forall a. ToJSON a => a -> Value
toJSON ResourceStats
stats of
      Object Object
x -> Object
x
      Value
_ -> Object
forall a. Monoid a => a
mempty