{-# LANGUAGE DeriveAnyClass    #-}
{-# LANGUAGE DeriveGeneric     #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RecordWildCards   #-}

{-# OPTIONS_GHC -Wno-orphans #-}

module Cardano.Logging.Types.TraceMessage
  ( TraceMessage (..)
  ) where

import           Cardano.Logging.Types (SeverityS)

import           Codec.CBOR.JSON
import           Codec.Serialise       (Serialise (..))
import           Control.DeepSeq       (NFData)
import           Data.Aeson            as AE hiding (decode, encode)
import           Data.Text             (Text)
import           Data.Time.Clock       (UTCTime)
import           GHC.Generics          (Generic)


-- | base for a machine readable trace message (JSON or CBOR), with metadata, and enclosed payload data from the trace itself.
data TraceMessage = TraceMessage
  { TraceMessage -> UTCTime
tmsgAt     :: !UTCTime
  , TraceMessage -> Text
tmsgNS     :: !Text
  , TraceMessage -> Object
tmsgData   :: !AE.Object
  , TraceMessage -> SeverityS
tmsgSev    :: !SeverityS
  , TraceMessage -> Text
tmsgThread :: !Text
  , TraceMessage -> Text
tmsgHost   :: !Text
  }
  deriving (Int -> TraceMessage -> ShowS
[TraceMessage] -> ShowS
TraceMessage -> String
(Int -> TraceMessage -> ShowS)
-> (TraceMessage -> String)
-> ([TraceMessage] -> ShowS)
-> Show TraceMessage
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TraceMessage -> ShowS
showsPrec :: Int -> TraceMessage -> ShowS
$cshow :: TraceMessage -> String
show :: TraceMessage -> String
$cshowList :: [TraceMessage] -> ShowS
showList :: [TraceMessage] -> ShowS
Show, TraceMessage -> TraceMessage -> Bool
(TraceMessage -> TraceMessage -> Bool)
-> (TraceMessage -> TraceMessage -> Bool) -> Eq TraceMessage
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TraceMessage -> TraceMessage -> Bool
== :: TraceMessage -> TraceMessage -> Bool
$c/= :: TraceMessage -> TraceMessage -> Bool
/= :: TraceMessage -> TraceMessage -> Bool
Eq, Eq TraceMessage
Eq TraceMessage =>
(TraceMessage -> TraceMessage -> Ordering)
-> (TraceMessage -> TraceMessage -> Bool)
-> (TraceMessage -> TraceMessage -> Bool)
-> (TraceMessage -> TraceMessage -> Bool)
-> (TraceMessage -> TraceMessage -> Bool)
-> (TraceMessage -> TraceMessage -> TraceMessage)
-> (TraceMessage -> TraceMessage -> TraceMessage)
-> Ord TraceMessage
TraceMessage -> TraceMessage -> Bool
TraceMessage -> TraceMessage -> Ordering
TraceMessage -> TraceMessage -> TraceMessage
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: TraceMessage -> TraceMessage -> Ordering
compare :: TraceMessage -> TraceMessage -> Ordering
$c< :: TraceMessage -> TraceMessage -> Bool
< :: TraceMessage -> TraceMessage -> Bool
$c<= :: TraceMessage -> TraceMessage -> Bool
<= :: TraceMessage -> TraceMessage -> Bool
$c> :: TraceMessage -> TraceMessage -> Bool
> :: TraceMessage -> TraceMessage -> Bool
$c>= :: TraceMessage -> TraceMessage -> Bool
>= :: TraceMessage -> TraceMessage -> Bool
$cmax :: TraceMessage -> TraceMessage -> TraceMessage
max :: TraceMessage -> TraceMessage -> TraceMessage
$cmin :: TraceMessage -> TraceMessage -> TraceMessage
min :: TraceMessage -> TraceMessage -> TraceMessage
Ord, (forall x. TraceMessage -> Rep TraceMessage x)
-> (forall x. Rep TraceMessage x -> TraceMessage)
-> Generic TraceMessage
forall x. Rep TraceMessage x -> TraceMessage
forall x. TraceMessage -> Rep TraceMessage x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. TraceMessage -> Rep TraceMessage x
from :: forall x. TraceMessage -> Rep TraceMessage x
$cto :: forall x. Rep TraceMessage x -> TraceMessage
to :: forall x. Rep TraceMessage x -> TraceMessage
Generic, TraceMessage -> ()
(TraceMessage -> ()) -> NFData TraceMessage
forall a. (a -> ()) -> NFData a
$crnf :: TraceMessage -> ()
rnf :: TraceMessage -> ()
NFData)

instance Serialise AE.Object where
  encode :: Object -> Encoding
encode = Value -> Encoding
encodeValue (Value -> Encoding) -> (Object -> Value) -> Object -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Object -> Value
Object
  decode :: forall s. Decoder s Object
decode = Bool -> Decoder s Value
forall s. Bool -> Decoder s Value
decodeValue Bool
True Decoder s Value -> (Value -> Decoder s Object) -> Decoder s Object
forall a b. Decoder s a -> (a -> Decoder s b) -> Decoder s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Object Object
o -> Object -> Decoder s Object
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Object
o
    Value
x        -> String -> Decoder s Object
forall a. String -> Decoder s a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Decoder s Object) -> String -> Decoder s Object
forall a b. (a -> b) -> a -> b
$ String
"decode(TraceMessage): expected JSON object, got: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Value -> String
forall a. Show a => a -> String
show Value
x


-- Serialisations are hand-rolled for higher degree of stability, and making them transparent.
instance Serialise TraceMessage where
  encode :: TraceMessage -> Encoding
encode TraceMessage{Text
UTCTime
Object
SeverityS
tmsgAt :: TraceMessage -> UTCTime
tmsgNS :: TraceMessage -> Text
tmsgData :: TraceMessage -> Object
tmsgSev :: TraceMessage -> SeverityS
tmsgThread :: TraceMessage -> Text
tmsgHost :: TraceMessage -> Text
tmsgAt :: UTCTime
tmsgNS :: Text
tmsgData :: Object
tmsgSev :: SeverityS
tmsgThread :: Text
tmsgHost :: Text
..} =
        UTCTime -> Encoding
forall a. Serialise a => a -> Encoding
encode UTCTime
tmsgAt
    Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<>  Text -> Encoding
forall a. Serialise a => a -> Encoding
encode Text
tmsgNS
    Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<>  SeverityS -> Encoding
forall a. Serialise a => a -> Encoding
encode SeverityS
tmsgSev
    Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<>  Object -> Encoding
forall a. Serialise a => a -> Encoding
encode Object
tmsgData
    Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<>  Text -> Encoding
forall a. Serialise a => a -> Encoding
encode Text
tmsgThread
    Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<>  Text -> Encoding
forall a. Serialise a => a -> Encoding
encode Text
tmsgHost

  decode :: forall s. Decoder s TraceMessage
decode = do
    UTCTime
tmsgAt      <- Decoder s UTCTime
forall s. Decoder s UTCTime
forall a s. Serialise a => Decoder s a
decode
    Text
tmsgNS      <- Decoder s Text
forall s. Decoder s Text
forall a s. Serialise a => Decoder s a
decode
    SeverityS
tmsgSev     <- Decoder s SeverityS
forall s. Decoder s SeverityS
forall a s. Serialise a => Decoder s a
decode
    Object
tmsgData    <- Decoder s Object
forall s. Decoder s Object
forall a s. Serialise a => Decoder s a
decode
    Text
tmsgThread  <- Decoder s Text
forall s. Decoder s Text
forall a s. Serialise a => Decoder s a
decode
    Text
tmsgHost    <- Decoder s Text
forall s. Decoder s Text
forall a s. Serialise a => Decoder s a
decode
    TraceMessage -> Decoder s TraceMessage
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TraceMessage{Text
UTCTime
Object
SeverityS
tmsgAt :: UTCTime
tmsgNS :: Text
tmsgData :: Object
tmsgSev :: SeverityS
tmsgThread :: Text
tmsgHost :: Text
tmsgAt :: UTCTime
tmsgNS :: Text
tmsgSev :: SeverityS
tmsgData :: Object
tmsgThread :: Text
tmsgHost :: Text
..}


instance ToJSON TraceMessage where
  toJSON :: TraceMessage -> Value
toJSON TraceMessage{Text
UTCTime
Object
SeverityS
tmsgAt :: TraceMessage -> UTCTime
tmsgNS :: TraceMessage -> Text
tmsgData :: TraceMessage -> Object
tmsgSev :: TraceMessage -> SeverityS
tmsgThread :: TraceMessage -> Text
tmsgHost :: TraceMessage -> Text
tmsgAt :: UTCTime
tmsgNS :: Text
tmsgData :: Object
tmsgSev :: SeverityS
tmsgThread :: Text
tmsgHost :: Text
..} = [Pair] -> Value
AE.object
    [ Key
"at"      Key -> UTCTime -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= UTCTime
tmsgAt
    , Key
"ns"      Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
tmsgNS
    , Key
"data"    Key -> Object -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Object
tmsgData
    , Key
"sev"     Key -> SeverityS -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= SeverityS
tmsgSev
    , Key
"thread"  Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
tmsgThread
    , Key
"host"    Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
tmsgHost
    ]
  toEncoding :: TraceMessage -> Encoding
toEncoding TraceMessage{Text
UTCTime
Object
SeverityS
tmsgAt :: TraceMessage -> UTCTime
tmsgNS :: TraceMessage -> Text
tmsgData :: TraceMessage -> Object
tmsgSev :: TraceMessage -> SeverityS
tmsgThread :: TraceMessage -> Text
tmsgHost :: TraceMessage -> Text
tmsgAt :: UTCTime
tmsgNS :: Text
tmsgData :: Object
tmsgSev :: SeverityS
tmsgThread :: Text
tmsgHost :: Text
..} = Series -> Encoding
AE.pairs (Series -> Encoding) -> Series -> Encoding
forall a b. (a -> b) -> a -> b
$
       Key
"at"     Key -> UTCTime -> Series
forall v. ToJSON v => Key -> v -> Series
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= UTCTime
tmsgAt
    Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<> Key
"ns"     Key -> Text -> Series
forall v. ToJSON v => Key -> v -> Series
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
tmsgNS
    Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<> Key
"data"   Key -> Object -> Series
forall v. ToJSON v => Key -> v -> Series
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Object
tmsgData
    Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<> Key
"sev"    Key -> SeverityS -> Series
forall v. ToJSON v => Key -> v -> Series
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= SeverityS
tmsgSev
    Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<> Key
"thread" Key -> Text -> Series
forall v. ToJSON v => Key -> v -> Series
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
tmsgThread
    Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<> Key
"host"   Key -> Text -> Series
forall v. ToJSON v => Key -> v -> Series
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
tmsgHost

instance FromJSON TraceMessage where
  parseJSON :: Value -> Parser TraceMessage
parseJSON = String
-> (Object -> Parser TraceMessage) -> Value -> Parser TraceMessage
forall a. String -> (Object -> Parser a) -> Value -> Parser a
AE.withObject String
"TraceMessage" ((Object -> Parser TraceMessage) -> Value -> Parser TraceMessage)
-> (Object -> Parser TraceMessage) -> Value -> Parser TraceMessage
forall a b. (a -> b) -> a -> b
$ \Object
v -> do
    UTCTime
tmsgAt      <- Object
v Object -> Key -> Parser UTCTime
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"at"
    Text
tmsgNS      <- Object
v Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"ns"
    Object
tmsgData    <- Object
v Object -> Key -> Parser Object
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"data"
    SeverityS
tmsgSev     <- Object
v Object -> Key -> Parser SeverityS
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"sev"
    Text
tmsgThread  <- Object
v Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"thread"
    Text
tmsgHost    <- Object
v Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"host"
    TraceMessage -> Parser TraceMessage
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TraceMessage{Text
UTCTime
Object
SeverityS
tmsgAt :: UTCTime
tmsgNS :: Text
tmsgData :: Object
tmsgSev :: SeverityS
tmsgThread :: Text
tmsgHost :: Text
tmsgAt :: UTCTime
tmsgNS :: Text
tmsgData :: Object
tmsgSev :: SeverityS
tmsgThread :: Text
tmsgHost :: Text
..}