{-# LANGUAGE DataKinds            #-}
{-# LANGUAGE DerivingVia          #-}
{-# LANGUAGE FlexibleContexts     #-}
{-# LANGUAGE FlexibleInstances    #-}
{-# LANGUAGE GADTs                #-}
{-# LANGUAGE KindSignatures       #-}
{-# LANGUAGE NamedFieldPuns       #-}
{-# LANGUAGE OverloadedStrings    #-}
{-# LANGUAGE TypeApplications     #-}
{-# LANGUAGE UndecidableInstances #-}
module Cardano.BM.Data.Tracer.Extras(
    mkObjectStr
    , PrettyToObject(..)
    , StructuredLog(..)
    , Tagged(Tagged)
    ) where

import Cardano.BM.Data.Tracer (ToObject (..))
import Data.Aeson (ToJSON (..), Value (String))
import Data.HashMap.Strict (HashMap)
import Data.HashMap.Strict qualified as HM
import Data.Proxy (Proxy (..))
import Data.Tagged (Tagged (Tagged))
import Data.Text (Text)
import Data.Text qualified as Text
import Data.UUID (UUID)
import GHC.TypeLits (KnownSymbol, symbolVal)
import Ledger.Tx (Tx)
import Ledger.Value qualified as V
import Plutus.Contract.Checkpoint (CheckpointLogMsg)
import Plutus.Contract.Resumable (Response (..))
import Plutus.Contract.State (ContractRequest)
import Plutus.PAB.Events.Contract (ContractInstanceId, IterationID)
import Plutus.PAB.Events.ContractInstanceState (PartiallyDecodedResponse (..))
import Prettyprinter (Pretty (..), defaultLayoutOptions, layoutPretty)
import Prettyprinter.Render.Text qualified as Render
import Wallet.Emulator.LogMessages (RequestHandlerLogMsg, TxBalanceMsg)
import Wallet.Types (EndpointDescription)

-- | Deriving 'ToObject' from 'Pretty'
newtype PrettyToObject a = PrettyToObject { PrettyToObject a -> a
unPrettyToObject :: a }

instance Pretty a => ToObject (PrettyToObject a) where
    toObject :: TracingVerbosity -> PrettyToObject a -> Object
toObject TracingVerbosity
_ = Text -> Value -> Object
forall k v. Hashable k => k -> v -> HashMap k v
HM.singleton Text
"string" (Value -> Object)
-> (PrettyToObject a -> Value) -> PrettyToObject a -> Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Value
String (Text -> Value)
-> (PrettyToObject a -> Text) -> PrettyToObject a -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleDocStream Any -> Text
forall ann. SimpleDocStream ann -> Text
Render.renderStrict (SimpleDocStream Any -> Text)
-> (PrettyToObject a -> SimpleDocStream Any)
-> PrettyToObject a
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LayoutOptions -> Doc Any -> SimpleDocStream Any
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
layoutPretty LayoutOptions
defaultLayoutOptions (Doc Any -> SimpleDocStream Any)
-> (PrettyToObject a -> Doc Any)
-> PrettyToObject a
-> SimpleDocStream Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Doc Any
forall a ann. Pretty a => a -> Doc ann
pretty (a -> Doc Any)
-> (PrettyToObject a -> a) -> PrettyToObject a -> Doc Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrettyToObject a -> a
forall a. PrettyToObject a -> a
unPrettyToObject

toStructuredLog' :: forall s a. (KnownSymbol s, ToJSON a) => Tagged s a -> HashMap Text Value
toStructuredLog' :: Tagged s a -> Object
toStructuredLog' (Tagged a
a) =
    let k :: Text
k = String -> Text
Text.pack (Proxy s -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy s
forall k (t :: k). Proxy t
Proxy @s))
        v :: Value
v = a -> Value
forall a. ToJSON a => a -> Value
toJSON a
a
    in Text -> Value -> Object
forall k v. Hashable k => k -> v -> HashMap k v
HM.singleton Text
k Value
v

-- | Types that can be turned into structured log messages
class StructuredLog a where
    toStructuredLog :: a -> HashMap Text Value

instance StructuredLog () where
    toStructuredLog :: () -> Object
toStructuredLog ()
_ = Object
forall k v. HashMap k v
HM.empty

instance (StructuredLog a, StructuredLog b) =>
    StructuredLog (a, b) where
        toStructuredLog :: (a, b) -> Object
toStructuredLog (a
a, b
b) = Object -> Object -> Object
forall k v.
(Eq k, Hashable k) =>
HashMap k v -> HashMap k v -> HashMap k v
HM.union (a -> Object
forall a. StructuredLog a => a -> Object
toStructuredLog a
a) (b -> Object
forall a. StructuredLog a => a -> Object
toStructuredLog b
b)

instance (StructuredLog a, StructuredLog b, StructuredLog c) =>
    StructuredLog (a, b, c) where
        toStructuredLog :: (a, b, c) -> Object
toStructuredLog (a
a, b
b, c
c) = Object -> Object -> Object
forall k v.
(Eq k, Hashable k) =>
HashMap k v -> HashMap k v -> HashMap k v
HM.union (a -> Object
forall a. StructuredLog a => a -> Object
toStructuredLog a
a) ((b, c) -> Object
forall a. StructuredLog a => a -> Object
toStructuredLog (b
b, c
c))

instance (StructuredLog a, StructuredLog b, StructuredLog c, StructuredLog d) =>
    StructuredLog (a, b, c, d) where
        toStructuredLog :: (a, b, c, d) -> Object
toStructuredLog (a
a, b
b, c
c, d
d) = Object -> Object -> Object
forall k v.
(Eq k, Hashable k) =>
HashMap k v -> HashMap k v -> HashMap k v
HM.union (a -> Object
forall a. StructuredLog a => a -> Object
toStructuredLog a
a) ((b, c, d) -> Object
forall a. StructuredLog a => a -> Object
toStructuredLog (b
b, c
c, d
d))

instance (StructuredLog a, StructuredLog b) =>
    StructuredLog (Either a b) where
        toStructuredLog :: Either a b -> Object
toStructuredLog = (a -> Object) -> (b -> Object) -> Either a b -> Object
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either a -> Object
forall a. StructuredLog a => a -> Object
toStructuredLog b -> Object
forall a. StructuredLog a => a -> Object
toStructuredLog

instance StructuredLog a => StructuredLog (Maybe a) where
    toStructuredLog :: Maybe a -> Object
toStructuredLog = Object -> (a -> Object) -> Maybe a -> Object
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Object
forall a. Monoid a => a
mempty a -> Object
forall a. StructuredLog a => a -> Object
toStructuredLog

deriving via (Tagged "contract_instance" ContractInstanceId) instance StructuredLog ContractInstanceId
deriving via (Tagged "contract_instance_iteration" IterationID) instance StructuredLog IterationID
deriving via (Tagged "message" CheckpointLogMsg) instance StructuredLog CheckpointLogMsg
deriving via (Tagged "message" RequestHandlerLogMsg) instance StructuredLog RequestHandlerLogMsg
deriving via (Tagged "message" TxBalanceMsg) instance StructuredLog TxBalanceMsg
deriving via (Tagged "tx" Tx) instance StructuredLog Tx
deriving via (Tagged "uuid" UUID) instance StructuredLog UUID
deriving via (Tagged "request" (ContractRequest w v)) instance (ToJSON w, ToJSON v) => StructuredLog (ContractRequest w v)
deriving via (Tagged "value" V.Value) instance StructuredLog V.Value
deriving via (Tagged "endpoint" EndpointDescription) instance StructuredLog EndpointDescription
instance ToJSON v => StructuredLog (PartiallyDecodedResponse v) where
    toStructuredLog :: PartiallyDecodedResponse v -> Object
toStructuredLog PartiallyDecodedResponse{[Request v]
hooks :: forall v. PartiallyDecodedResponse v -> [Request v]
hooks :: [Request v]
hooks, Value
observableState :: forall v. PartiallyDecodedResponse v -> Value
observableState :: Value
observableState} =
        [(Text, Value)] -> Object
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList [(Text
"hooks", [Request v] -> Value
forall a. ToJSON a => a -> Value
toJSON [Request v]
hooks), (Text
"state", Value -> Value
forall a. ToJSON a => a -> Value
toJSON Value
observableState)]
instance ToJSON v => StructuredLog (Response v) where
    toStructuredLog :: Response v -> Object
toStructuredLog Response{RequestID
rspRqID :: forall i. Response i -> RequestID
rspRqID :: RequestID
rspRqID, IterationID
rspItID :: forall i. Response i -> IterationID
rspItID :: IterationID
rspItID, v
rspResponse :: forall i. Response i -> i
rspResponse :: v
rspResponse} =
        [(Text, Value)] -> Object
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList
            [ (Text
"requestID", RequestID -> Value
forall a. ToJSON a => a -> Value
toJSON RequestID
rspRqID)
            , (Text
"iterationID", IterationID -> Value
forall a. ToJSON a => a -> Value
toJSON IterationID
rspItID)
            , (Text
"response", v -> Value
forall a. ToJSON a => a -> Value
toJSON v
rspResponse)
            ]

instance (KnownSymbol s, ToJSON a) => StructuredLog (Tagged s a) where
    toStructuredLog :: Tagged s a -> Object
toStructuredLog = Tagged s a -> Object
forall (s :: Symbol) a.
(KnownSymbol s, ToJSON a) =>
Tagged s a -> Object
toStructuredLog'

-- | A structured log object with a textual description and additional fields.
mkObjectStr :: StructuredLog k => Text -> k -> HashMap Text Value
mkObjectStr :: Text -> k -> Object
mkObjectStr Text
str k
rest =
    Text -> Value -> Object -> Object
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert Text
"string" (Text -> Value
String Text
str) (k -> Object
forall a. StructuredLog a => a -> Object
toStructuredLog k
rest)