{-# LANGUAGE DataKinds          #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts   #-}
{-# LANGUAGE GADTs              #-}
{-# LANGUAGE LambdaCase         #-}
{-# LANGUAGE NamedFieldPuns     #-}
{-# LANGUAGE OverloadedStrings  #-}
{-# LANGUAGE RankNTypes         #-}
{-# LANGUAGE TypeApplications   #-}
{-# LANGUAGE TypeOperators      #-}

module Plutus.Monitoring.Util (
      handleLogMsgTrace
    , handleLogMsgTraceMap
    , handleObserveTrace
    , runLogEffects
    , convertLog
    , toSeverity
    , PrettyObject(..)
    ) where

import Cardano.BM.Configuration.Model qualified as CM
import Cardano.BM.Data.Counter
import Cardano.BM.Data.LogItem
import Cardano.BM.Data.Severity
import Cardano.BM.Data.SubTrace
import Cardano.BM.Data.Trace
import Cardano.BM.Data.Tracer (ToObject (..))
import Cardano.BM.Observer.Monadic
import Cardano.BM.Trace
import Control.Monad (void)
import Control.Monad.Catch (MonadCatch)
import Control.Monad.Freer
import Control.Monad.Freer.Extras.Log (LogMsg (..), LogObserve (..), Observation (..))
import Control.Monad.Freer.Extras.Log qualified as L
import Control.Monad.IO.Class (MonadIO (..))
import Data.Aeson (FromJSON, ToJSON (..))
import Data.Aeson.Key qualified as Aeson
import Data.Aeson.KeyMap qualified as Aeson
import Data.Bifunctor (Bifunctor (..))
import Data.Foldable (for_)
import Data.Functor.Contravariant (Contravariant (..))
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import Data.Text.Class (ToText (..))
import Data.Text.Lazy qualified as Text
import Prettyprinter (Pretty (..), defaultLayoutOptions, layoutPretty)
import Prettyprinter.Render.Text qualified as Render

toSeverity :: L.LogLevel -> Severity
toSeverity :: LogLevel -> Severity
toSeverity = \case
  LogLevel
L.Debug     -> Severity
Debug
  LogLevel
L.Info      -> Severity
Info
  LogLevel
L.Notice    -> Severity
Notice
  LogLevel
L.Warning   -> Severity
Warning
  LogLevel
L.Error     -> Severity
Error
  LogLevel
L.Critical  -> Severity
Critical
  LogLevel
L.Alert     -> Severity
Alert
  LogLevel
L.Emergency -> Severity
Emergency


-- | Handle the 'LogMsg' effect by logging messages to a 'Trace'
handleLogMsgTrace :: forall a m effs.
  ( LastMember m effs
  , MonadIO m
  )
  => Trace m a
  -> LogMsg a
  ~> Eff effs
handleLogMsgTrace :: Trace m a -> LogMsg a ~> Eff effs
handleLogMsgTrace Trace m a
trace = \case
  LMessage L.LogMessage{LogLevel
_logLevel :: forall a. LogMessage a -> LogLevel
_logLevel :: LogLevel
L._logLevel, a
_logMessageContent :: forall a. LogMessage a -> a
_logMessageContent :: a
L._logMessageContent} ->
    let defaultPrivacy :: PrivacyAnnotation
defaultPrivacy = PrivacyAnnotation
Public -- TODO: Configurable / add to 'L.LogMessage'?
    in m () -> Eff effs ()
forall (m :: * -> *) (effs :: [* -> *]) a.
(Monad m, LastMember m effs) =>
m a -> Eff effs a
sendM (m () -> Eff effs ()) -> m () -> Eff effs ()
forall a b. (a -> b) -> a -> b
$ Trace m a -> PrivacyAnnotation -> Severity -> a -> m ()
forall (m :: * -> *) a.
MonadIO m =>
Trace m a -> PrivacyAnnotation -> Severity -> a -> m ()
traceNamedItem Trace m a
trace PrivacyAnnotation
defaultPrivacy (LogLevel -> Severity
toSeverity LogLevel
_logLevel) a
_logMessageContent

-- | Handle the 'LogMsg' effect by logging messages to a mapped 'Trace'
handleLogMsgTraceMap :: forall b a m effs.
  ( LastMember m effs
  , MonadIO m
  )
  => (b -> a)
  -> Trace m a
  -> LogMsg b
  ~> Eff effs
handleLogMsgTraceMap :: (b -> a) -> Trace m a -> LogMsg b ~> Eff effs
handleLogMsgTraceMap b -> a
f Trace m a
t = Trace m b -> LogMsg b ~> Eff effs
forall a (m :: * -> *) (effs :: [* -> *]).
(LastMember m effs, MonadIO m) =>
Trace m a -> LogMsg a ~> Eff effs
handleLogMsgTrace (((LoggerName, LogObject b) -> (LoggerName, LogObject a))
-> Trace m a -> Trace m b
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap ((LogObject b -> LogObject a)
-> (LoggerName, LogObject b) -> (LoggerName, LogObject a)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ((b -> a) -> LogObject b -> LogObject a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> a
f)) Trace m a
t)

runLogEffects ::
    forall m l.
    MonadIO m
    => Trace m l
    -> Eff '[LogMsg l, m]
    ~> m
runLogEffects :: Trace m l -> Eff '[LogMsg l, m] ~> m
runLogEffects Trace m l
trace = Eff '[m] x -> m x
forall (m :: * -> *) a. Monad m => Eff '[m] a -> m a
runM (Eff '[m] x -> m x)
-> (Eff '[LogMsg l, m] x -> Eff '[m] x)
-> Eff '[LogMsg l, m] x
-> m x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LogMsg l ~> Eff '[m]) -> Eff '[LogMsg l, m] ~> Eff '[m]
forall (eff :: * -> *) (effs :: [* -> *]).
(eff ~> Eff effs) -> Eff (eff : effs) ~> Eff effs
interpret (Trace m l -> LogMsg l ~> Eff '[m]
forall a (m :: * -> *) (effs :: [* -> *]).
(LastMember m effs, MonadIO m) =>
Trace m a -> LogMsg a ~> Eff effs
handleLogMsgTrace Trace m l
trace)

-- | Convert tracer structured log data
convertLog :: (a -> b) -> Trace m b -> Trace m a
convertLog :: (a -> b) -> Trace m b -> Trace m a
convertLog a -> b
f = ((LoggerName, LogObject a) -> (LoggerName, LogObject b))
-> Trace m b -> Trace m a
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap ((LogObject a -> LogObject b)
-> (LoggerName, LogObject a) -> (LoggerName, LogObject b)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ((a -> b) -> LogObject a -> LogObject b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f))

-- | Handle the 'LogObserve' effect using the 'Cardano.BM.Observer.Monadic'
--   observer functions
handleObserveTrace ::
  forall effs m a.
  ( LastMember m effs
  , MonadIO m
  , MonadCatch m
  )
  => CM.Configuration
  -> Trace m a
  -> Eff (LogObserve (L.LogMessage Text) ': effs)
  ~> Eff effs
handleObserveTrace :: Configuration
-> Trace m a
-> Eff (LogObserve (LogMessage LoggerName) : effs) ~> Eff effs
handleObserveTrace Configuration
config Trace m a
t =

  -- We need to call 'observeOpen' and 'observeClose' with the appropriate
  -- arguments.
  --
  -- 'observeBefore' makes the call to 'observeOpen' and 'observeAfter'
  -- makes the call to 'observeClose.'

  let observeBefore :: L.LogMessage Text -> Eff effs (Maybe (SubTrace, CounterState))
      observeBefore :: LogMessage LoggerName -> Eff effs (Maybe (SubTrace, CounterState))
observeBefore L.LogMessage{LogLevel
_logLevel :: LogLevel
_logLevel :: forall a. LogMessage a -> LogLevel
L._logLevel, LoggerName
_logMessageContent :: LoggerName
_logMessageContent :: forall a. LogMessage a -> a
L._logMessageContent} = do

        -- find the correct subtrace using the logging config and the content
        -- of the message.
        SubTrace
subtrace <- SubTrace -> Maybe SubTrace -> SubTrace
forall a. a -> Maybe a -> a
fromMaybe SubTrace
Neutral (Maybe SubTrace -> SubTrace)
-> Eff effs (Maybe SubTrace) -> Eff effs SubTrace
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Maybe SubTrace) -> Eff effs (Maybe SubTrace)
forall (m :: * -> *) (effs :: [* -> *]) a.
(Monad m, LastMember m effs) =>
m a -> Eff effs a
sendM @_ @effs (IO (Maybe SubTrace) -> m (Maybe SubTrace)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe SubTrace) -> m (Maybe SubTrace))
-> IO (Maybe SubTrace) -> m (Maybe SubTrace)
forall a b. (a -> b) -> a -> b
$ Configuration -> LoggerName -> IO (Maybe SubTrace)
CM.findSubTrace Configuration
config LoggerName
_logMessageContent)

        -- 'observeOpen' produces the state of the counters at the beginning of
        -- the action. We return 'counterState' and 'subtrace' so that
        -- they are available in 'observeAfter'.
        Either SomeException CounterState
mCountersid <- m (Either SomeException CounterState)
-> Eff effs (Either SomeException CounterState)
forall (m :: * -> *) (effs :: [* -> *]) a.
(Monad m, LastMember m effs) =>
m a -> Eff effs a
sendM (m (Either SomeException CounterState)
 -> Eff effs (Either SomeException CounterState))
-> m (Either SomeException CounterState)
-> Eff effs (Either SomeException CounterState)
forall a b. (a -> b) -> a -> b
$ SubTrace
-> Severity -> Trace m a -> m (Either SomeException CounterState)
forall (m :: * -> *) a.
(MonadCatch m, MonadIO m) =>
SubTrace
-> Severity -> Trace m a -> m (Either SomeException CounterState)
observeOpen SubTrace
subtrace (LogLevel -> Severity
toSeverity LogLevel
_logLevel) Trace m a
t
        case Either SomeException CounterState
mCountersid of
          Left SomeException
_             -> Maybe (SubTrace, CounterState)
-> Eff effs (Maybe (SubTrace, CounterState))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (SubTrace, CounterState)
forall a. Maybe a
Nothing
          Right CounterState
counterState -> Maybe (SubTrace, CounterState)
-> Eff effs (Maybe (SubTrace, CounterState))
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((SubTrace, CounterState) -> Maybe (SubTrace, CounterState)
forall a. a -> Maybe a
Just (SubTrace
subtrace, CounterState
counterState))

      observeAfter :: Observation (L.LogMessage Text) (Maybe (SubTrace, CounterState)) -> Eff effs ()
      observeAfter :: Observation
  (LogMessage LoggerName) (Maybe (SubTrace, CounterState))
-> Eff effs ()
observeAfter Observation{Maybe (SubTrace, CounterState)
obsStart :: forall v s. Observation v s -> s
obsStart :: Maybe (SubTrace, CounterState)
obsStart} =
        Maybe (SubTrace, CounterState)
-> ((SubTrace, CounterState) -> Eff effs ()) -> Eff effs ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe (SubTrace, CounterState)
obsStart (((SubTrace, CounterState) -> Eff effs ()) -> Eff effs ())
-> ((SubTrace, CounterState) -> Eff effs ()) -> Eff effs ()
forall a b. (a -> b) -> a -> b
$ \(SubTrace
subtrace, CounterState
counterState) ->
          Eff effs (Either SomeException ()) -> Eff effs ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Eff effs (Either SomeException ()) -> Eff effs ())
-> Eff effs (Either SomeException ()) -> Eff effs ()
forall a b. (a -> b) -> a -> b
$ m (Either SomeException ()) -> Eff effs (Either SomeException ())
forall (m :: * -> *) (effs :: [* -> *]) a.
(Monad m, LastMember m effs) =>
m a -> Eff effs a
sendM (m (Either SomeException ()) -> Eff effs (Either SomeException ()))
-> m (Either SomeException ())
-> Eff effs (Either SomeException ())
forall a b. (a -> b) -> a -> b
$ SubTrace
-> Severity
-> Trace m a
-> CounterState
-> [(LOMeta, LOContent a)]
-> m (Either SomeException ())
forall (m :: * -> *) a.
(MonadCatch m, MonadIO m) =>
SubTrace
-> Severity
-> Trace m a
-> CounterState
-> [(LOMeta, LOContent a)]
-> m (Either SomeException ())
observeClose SubTrace
subtrace Severity
Info Trace m a
t CounterState
counterState []

  in (LogMessage LoggerName
 -> Eff effs (Maybe (SubTrace, CounterState)))
-> (Observation
      (LogMessage LoggerName) (Maybe (SubTrace, CounterState))
    -> Eff effs ())
-> Eff (LogObserve (LogMessage LoggerName) : effs) ~> Eff effs
forall v s (effs :: [* -> *]).
(v -> Eff effs s)
-> (Observation v s -> Eff effs ())
-> Eff (LogObserve v : effs) ~> Eff effs
L.handleObserve
      LogMessage LoggerName -> Eff effs (Maybe (SubTrace, CounterState))
observeBefore
      Observation
  (LogMessage LoggerName) (Maybe (SubTrace, CounterState))
-> Eff effs ()
observeAfter

-- | A 'ToObject' instance that uses 'Pretty' as its 'textTransformer'
newtype PrettyObject t = PrettyObject { PrettyObject t -> t
unPrettyObject :: t }
    deriving newtype ([PrettyObject t] -> Encoding
[PrettyObject t] -> Value
PrettyObject t -> Encoding
PrettyObject t -> Value
(PrettyObject t -> Value)
-> (PrettyObject t -> Encoding)
-> ([PrettyObject t] -> Value)
-> ([PrettyObject t] -> Encoding)
-> ToJSON (PrettyObject t)
forall t. ToJSON t => [PrettyObject t] -> Encoding
forall t. ToJSON t => [PrettyObject t] -> Value
forall t. ToJSON t => PrettyObject t -> Encoding
forall t. ToJSON t => PrettyObject t -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [PrettyObject t] -> Encoding
$ctoEncodingList :: forall t. ToJSON t => [PrettyObject t] -> Encoding
toJSONList :: [PrettyObject t] -> Value
$ctoJSONList :: forall t. ToJSON t => [PrettyObject t] -> Value
toEncoding :: PrettyObject t -> Encoding
$ctoEncoding :: forall t. ToJSON t => PrettyObject t -> Encoding
toJSON :: PrettyObject t -> Value
$ctoJSON :: forall t. ToJSON t => PrettyObject t -> Value
ToJSON, Value -> Parser [PrettyObject t]
Value -> Parser (PrettyObject t)
(Value -> Parser (PrettyObject t))
-> (Value -> Parser [PrettyObject t]) -> FromJSON (PrettyObject t)
forall t. FromJSON t => Value -> Parser [PrettyObject t]
forall t. FromJSON t => Value -> Parser (PrettyObject t)
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [PrettyObject t]
$cparseJSONList :: forall t. FromJSON t => Value -> Parser [PrettyObject t]
parseJSON :: Value -> Parser (PrettyObject t)
$cparseJSON :: forall t. FromJSON t => Value -> Parser (PrettyObject t)
FromJSON)

instance (Pretty t) => ToObject (PrettyObject t) where
    toObject :: TracingVerbosity -> PrettyObject t -> Object
toObject TracingVerbosity
_ PrettyObject t
o =
        let str :: LoggerName
str = PrettyObject t -> LoggerName
forall a. ToText a => a -> LoggerName
toText PrettyObject t
o
        in Key -> Value -> Object
forall v. Key -> v -> KeyMap v
Aeson.singleton (LoggerName -> Key
Aeson.fromText LoggerName
"string") (LoggerName -> Value
forall a. ToJSON a => a -> Value
toJSON LoggerName
str)
    textTransformer :: PrettyObject t -> Object -> LoggerName
textTransformer PrettyObject t
o Object
_ = PrettyObject t -> LoggerName
forall a. ToText a => a -> LoggerName
toText PrettyObject t
o

instance (Pretty t) => ToText (PrettyObject t) where
    toText :: PrettyObject t -> LoggerName
toText (PrettyObject t
t) = Text -> LoggerName
Text.toStrict (Text -> LoggerName) -> (Doc Any -> Text) -> Doc Any -> LoggerName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleDocStream Any -> Text
forall ann. SimpleDocStream ann -> Text
Render.renderLazy (SimpleDocStream Any -> Text)
-> (Doc Any -> SimpleDocStream Any) -> Doc Any -> 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 -> LoggerName) -> Doc Any -> LoggerName
forall a b. (a -> b) -> a -> b
$ t -> Doc Any
forall a ann. Pretty a => a -> Doc ann
pretty t
t