{-# 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.Aeson.Key qualified as Aeson
import Data.Aeson.KeyMap qualified as Aeson
import Data.Proxy (Proxy (..))
import Data.Tagged (Tagged (Tagged))
import Data.Text (Text)
import Data.UUID (UUID)
import GHC.TypeLits (KnownSymbol, symbolVal)
import Ledger.Tx (CardanoTx)
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 Plutus.Script.Utils.Value qualified as V
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
_ = Key -> Value -> Object
forall v. Key -> v -> KeyMap v
Aeson.singleton Key
"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 -> Aeson.KeyMap Value
toStructuredLog' :: Tagged s a -> Object
toStructuredLog' (Tagged a
a) =
    let k :: Key
k = String -> Key
Aeson.fromString (String -> Key) -> String -> Key
forall a b. (a -> b) -> a -> b
$ 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 Key -> Value -> Object
forall v. Key -> v -> KeyMap v
Aeson.singleton Key
k Value
v

-- | Types that can be turned into structured log messages
class StructuredLog a where
    toStructuredLog :: a -> Aeson.KeyMap Value

instance StructuredLog () where
    toStructuredLog :: () -> Object
toStructuredLog ()
_ = Object
forall v. KeyMap v
Aeson.empty

instance (StructuredLog a, StructuredLog b) =>
    StructuredLog (a, b) where
        toStructuredLog :: (a, b) -> Object
toStructuredLog (a
a, b
b) = Object -> Object -> Object
forall v. KeyMap v -> KeyMap v -> KeyMap v
Aeson.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 v. KeyMap v -> KeyMap v -> KeyMap v
Aeson.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 v. KeyMap v -> KeyMap v -> KeyMap v
Aeson.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" CardanoTx) instance StructuredLog CardanoTx
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} =
        [(Key, Value)] -> Object
forall v. [(Key, v)] -> KeyMap v
Aeson.fromList [(Key
"hooks", [Request v] -> Value
forall a. ToJSON a => a -> Value
toJSON [Request v]
hooks), (Key
"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} =
        [(Key, Value)] -> Object
forall v. [(Key, v)] -> KeyMap v
Aeson.fromList
            [ (Key
"requestID", RequestID -> Value
forall a. ToJSON a => a -> Value
toJSON RequestID
rspRqID)
            , (Key
"iterationID", IterationID -> Value
forall a. ToJSON a => a -> Value
toJSON IterationID
rspItID)
            , (Key
"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 -> Aeson.KeyMap Value
mkObjectStr :: Text -> k -> Object
mkObjectStr Text
str k
rest =
    Key -> Value -> Object -> Object
forall v. Key -> v -> KeyMap v -> KeyMap v
Aeson.insert Key
"string" (Text -> Value
String Text
str) (k -> Object
forall a. StructuredLog a => a -> Object
toStructuredLog k
rest)