{-# LANGUAGE DeriveAnyClass       #-}
{-# LANGUAGE DeriveGeneric        #-}
{-# LANGUAGE NamedFieldPuns       #-}
{-# LANGUAGE OverloadedStrings    #-}
{-# LANGUAGE RankNTypes           #-}
{-# LANGUAGE ScopedTypeVariables  #-}
{-# LANGUAGE TypeApplications     #-}
{-# LANGUAGE UndecidableInstances #-}

-- thank you hydra
-- | Adapter module to the actual logging framework.
-- All Hydra node components implements /Structured logging/ via [contra-tracer](https://hackage.haskell.org/package/contra-tracer)
-- generic logging framework. All logs are output in [JSON](https://www.json.org/json-en.html) in a format which is
-- documented in a [JSON-Schema](https://github.com/input-output-hk/hydra/blob/master/hydra-node/json-schemas/logs.yaml).
module Convex.Devnet.Logging (
  -- * Tracer
  Tracer (..),
  natTracer,
  nullTracer,
  traceWith,
  ToObject (..),
  TracingVerbosity (..),

  -- * Using it
  Verbosity (..),
  Envelope (..),
  withTracer,
  withTracerOutputTo,
  showLogsOnFailure,
  traceInTVar,
  contramap,
) where

import           Cardano.BM.Tracing             (ToObject (..),
                                                 TracingVerbosity (..))
import           Control.Concurrent.STM.TBQueue (flushTBQueue, newTBQueueIO,
                                                 readTBQueue, writeTBQueue)
import           Control.Concurrent.STM.TVar    (TVar, modifyTVar, newTVarIO,
                                                 readTVarIO)
import           Control.Monad                  (forM_, forever, (>=>))
import           Control.Monad.Class.MonadAsync (withAsync)
import           Control.Monad.Class.MonadFork  (MonadFork, myThreadId)
import           Control.Monad.Class.MonadSay   (MonadSay, say)
import           Control.Monad.Class.MonadSTM   (MonadSTM, atomically)
import           Control.Monad.Class.MonadThrow (MonadCatch, finally,
                                                 onException)
import           Control.Monad.Class.MonadTime  (MonadTime, getCurrentTime)
import           Control.Monad.IO.Class         (MonadIO (..))
import           Control.Tracer                 (Tracer (..), contramap,
                                                 natTracer, nullTracer,
                                                 traceWith)
import           Data.Aeson                     (FromJSON, ToJSON, pairs, (.=))
import qualified Data.Aeson                     as Aeson
import qualified Data.ByteString.Lazy           as LBS
import           Data.Maybe                     (fromMaybe)
import           Data.Text                      (Text)
import qualified Data.Text                      as Text
import qualified Data.Text.Lazy                 as TL
import           Data.Text.Lazy.Encoding        (decodeUtf8)
import           Data.Time                      (UTCTime)
import           GHC.Generics                   (Generic)
import           Numeric.Natural                (Natural)
import           System.IO                      (Handle, hFlush, stdout)
import           Text.Read                      (readMaybe)

import           Prelude

data Verbosity = Quiet | Verbose Text
  deriving (Verbosity -> Verbosity -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Verbosity -> Verbosity -> Bool
$c/= :: Verbosity -> Verbosity -> Bool
== :: Verbosity -> Verbosity -> Bool
$c== :: Verbosity -> Verbosity -> Bool
Eq, Int -> Verbosity -> ShowS
[Verbosity] -> ShowS
Verbosity -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Verbosity] -> ShowS
$cshowList :: [Verbosity] -> ShowS
show :: Verbosity -> String
$cshow :: Verbosity -> String
showsPrec :: Int -> Verbosity -> ShowS
$cshowsPrec :: Int -> Verbosity -> ShowS
Show, forall x. Rep Verbosity x -> Verbosity
forall x. Verbosity -> Rep Verbosity x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Verbosity x -> Verbosity
$cfrom :: forall x. Verbosity -> Rep Verbosity x
Generic, [Verbosity] -> Encoding
[Verbosity] -> Value
Verbosity -> Encoding
Verbosity -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [Verbosity] -> Encoding
$ctoEncodingList :: [Verbosity] -> Encoding
toJSONList :: [Verbosity] -> Value
$ctoJSONList :: [Verbosity] -> Value
toEncoding :: Verbosity -> Encoding
$ctoEncoding :: Verbosity -> Encoding
toJSON :: Verbosity -> Value
$ctoJSON :: Verbosity -> Value
ToJSON, Value -> Parser [Verbosity]
Value -> Parser Verbosity
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [Verbosity]
$cparseJSONList :: Value -> Parser [Verbosity]
parseJSON :: Value -> Parser Verbosity
$cparseJSON :: Value -> Parser Verbosity
FromJSON)

-- | Provides logging metadata for entries.
data Envelope a = Envelope
  { forall a. Envelope a -> UTCTime
timestamp :: UTCTime
  , forall a. Envelope a -> Int
threadId  :: Int
  , forall a. Envelope a -> Text
namespace :: Text
  , forall a. Envelope a -> a
message   :: a
  }
  deriving (Envelope a -> Envelope a -> Bool
forall a. Eq a => Envelope a -> Envelope a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Envelope a -> Envelope a -> Bool
$c/= :: forall a. Eq a => Envelope a -> Envelope a -> Bool
== :: Envelope a -> Envelope a -> Bool
$c== :: forall a. Eq a => Envelope a -> Envelope a -> Bool
Eq, Int -> Envelope a -> ShowS
forall a. Show a => Int -> Envelope a -> ShowS
forall a. Show a => [Envelope a] -> ShowS
forall a. Show a => Envelope a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Envelope a] -> ShowS
$cshowList :: forall a. Show a => [Envelope a] -> ShowS
show :: Envelope a -> String
$cshow :: forall a. Show a => Envelope a -> String
showsPrec :: Int -> Envelope a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Envelope a -> ShowS
Show, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (Envelope a) x -> Envelope a
forall a x. Envelope a -> Rep (Envelope a) x
$cto :: forall a x. Rep (Envelope a) x -> Envelope a
$cfrom :: forall a x. Envelope a -> Rep (Envelope a) x
Generic, forall a. FromJSON a => Value -> Parser [Envelope a]
forall a. FromJSON a => Value -> Parser (Envelope a)
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [Envelope a]
$cparseJSONList :: forall a. FromJSON a => Value -> Parser [Envelope a]
parseJSON :: Value -> Parser (Envelope a)
$cparseJSON :: forall a. FromJSON a => Value -> Parser (Envelope a)
FromJSON)

instance ToJSON a => ToJSON (Envelope a) where
  toEncoding :: Envelope a -> Encoding
toEncoding Envelope{UTCTime
timestamp :: UTCTime
timestamp :: forall a. Envelope a -> UTCTime
timestamp, Int
threadId :: Int
threadId :: forall a. Envelope a -> Int
threadId, Text
namespace :: Text
namespace :: forall a. Envelope a -> Text
namespace, a
message :: a
message :: forall a. Envelope a -> a
message} =
    Series -> Encoding
pairs forall a b. (a -> b) -> a -> b
$
      forall a. Monoid a => [a] -> a
mconcat
        [ Key
"timestamp" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= UTCTime
timestamp
        , Key
"threadId" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Int
threadId
        , Key
"namespace" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
namespace
        , Key
"message" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= a
message
        ]

defaultQueueSize :: Natural
defaultQueueSize :: Natural
defaultQueueSize = Natural
500

-- | Start logging thread and acquire a 'Tracer'. This tracer will dump all
-- messsages on @stdout@, one message per line, formatted as JSON. This tracer
-- is wrapping 'msg' into an 'Envelope' with metadata.
withTracer ::
  forall m msg a.
  (MonadIO m, MonadFork m, MonadTime m, ToJSON msg) =>
  Verbosity ->
  (Tracer m msg -> IO a) ->
  IO a
withTracer :: forall (m :: * -> *) msg a.
(MonadIO m, MonadFork m, MonadTime m, ToJSON msg) =>
Verbosity -> (Tracer m msg -> IO a) -> IO a
withTracer Verbosity
Quiet               = (forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer)
withTracer (Verbose Text
namespace) = forall (m :: * -> *) msg a.
(MonadIO m, MonadFork m, MonadTime m, ToJSON msg) =>
Handle -> Text -> (Tracer m msg -> IO a) -> IO a
withTracerOutputTo Handle
stdout Text
namespace

-- | Start logging thread acquiring a 'Tracer', outputting JSON formatted
-- messages to some 'Handle'. This tracer is wrapping 'msg' into an 'Envelope'
-- with metadata.
withTracerOutputTo ::
  forall m msg a.
  (MonadIO m, MonadFork m, MonadTime m, ToJSON msg) =>
  Handle ->
  Text ->
  (Tracer m msg -> IO a) ->
  IO a
withTracerOutputTo :: forall (m :: * -> *) msg a.
(MonadIO m, MonadFork m, MonadTime m, ToJSON msg) =>
Handle -> Text -> (Tracer m msg -> IO a) -> IO a
withTracerOutputTo Handle
hdl Text
namespace Tracer m msg -> IO a
action = do
  TBQueue (Envelope msg)
msgQueue <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall a. Natural -> IO (TBQueue a)
newTBQueueIO @(Envelope msg) Natural
defaultQueueSize)
  forall (m :: * -> *) a b.
MonadAsync m =>
m a -> (Async m a -> m b) -> m b
withAsync (forall {a} {b}. ToJSON a => TBQueue a -> IO b
writeLogs TBQueue (Envelope msg)
msgQueue) forall a b. (a -> b) -> a -> b
$ \Async IO Any
_ ->
    Tracer m msg -> IO a
action (forall {m :: * -> *} {a}.
(MonadFork m, MonadTime m, MonadIO m) =>
TBQueue (Envelope a) -> Tracer m a
tracer TBQueue (Envelope msg)
msgQueue) forall (m :: * -> *) a b. MonadThrow m => m a -> m b -> m a
`finally` forall {m :: * -> *} {a}.
(MonadIO m, ToJSON a) =>
TBQueue a -> m ()
flushLogs TBQueue (Envelope msg)
msgQueue
 where
  tracer :: TBQueue (Envelope a) -> Tracer m a
tracer TBQueue (Envelope a)
queue =
    forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer forall a b. (a -> b) -> a -> b
$
      forall (m :: * -> *) msg.
(MonadFork m, MonadTime m) =>
Text -> msg -> m (Envelope msg)
mkEnvelope Text
namespace forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. TBQueue a -> a -> STM ()
writeTBQueue TBQueue (Envelope a)
queue

  writeLogs :: TBQueue a -> IO b
writeLogs TBQueue a
queue =
    forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ do
      forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (forall a. TBQueue a -> STM a
readTBQueue TBQueue a
queue) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> IO ()
write forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToJSON a => a -> ByteString
Aeson.encode
      Handle -> IO ()
hFlush Handle
hdl

  flushLogs :: TBQueue a -> m ()
flushLogs TBQueue a
queue = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
    [a]
entries <- forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TBQueue a -> STM [a]
flushTBQueue TBQueue a
queue
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [a]
entries (ByteString -> IO ()
write forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToJSON a => a -> ByteString
Aeson.encode)
    Handle -> IO ()
hFlush Handle
hdl

  write :: ByteString -> IO ()
write ByteString
bs = Handle -> ByteString -> IO ()
LBS.hPut Handle
hdl (ByteString
bs forall a. Semigroup a => a -> a -> a
<> ByteString
"\n")

-- | Capture logs and output them to stdout when an exception was raised by the
-- given 'action'. This tracer is wrapping 'msg' into an 'Envelope' with
-- metadata.
showLogsOnFailure ::
  (MonadSTM m, MonadCatch m, MonadIO m, MonadFork m, MonadTime m, MonadSay m, ToJSON msg) =>
  (Tracer m msg -> m a) ->
  m a
showLogsOnFailure :: forall (m :: * -> *) msg a.
(MonadSTM m, MonadCatch m, MonadIO m, MonadFork m, MonadTime m,
 MonadSay m, ToJSON msg) =>
(Tracer m msg -> m a) -> m a
showLogsOnFailure Tracer m msg -> m a
action = do
  TVar [Envelope msg]
tvar <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall a. a -> IO (TVar a)
newTVarIO [])
  Tracer m msg -> m a
action (forall (m :: * -> *) msg.
(MonadIO m, MonadTime m, MonadFork m) =>
TVar [Envelope msg] -> Tracer m msg
traceInTVar TVar [Envelope msg]
tvar)
    forall (m :: * -> *) a b. MonadCatch m => m a -> m b -> m a
`onException` (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall a. TVar a -> IO a
readTVarIO TVar [Envelope msg]
tvar) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall (m :: * -> *). MonadSay m => String -> m ()
say forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
TL.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToJSON a => a -> ByteString
Aeson.encode) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse)

traceInTVar ::
  (MonadIO m, MonadTime m, MonadFork m) =>
  TVar [Envelope msg] ->
  Tracer m msg
traceInTVar :: forall (m :: * -> *) msg.
(MonadIO m, MonadTime m, MonadFork m) =>
TVar [Envelope msg] -> Tracer m msg
traceInTVar TVar [Envelope msg]
tvar = forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer forall a b. (a -> b) -> a -> b
$ \msg
msg -> do
  Envelope msg
envelope <- forall (m :: * -> *) msg.
(MonadFork m, MonadTime m) =>
Text -> msg -> m (Envelope msg)
mkEnvelope Text
"" msg
msg
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar [Envelope msg]
tvar (Envelope msg
envelope forall a. a -> [a] -> [a]
:)
-- * Internal functions

mkEnvelope :: (MonadFork m, MonadTime m) => Text -> msg -> m (Envelope msg)
mkEnvelope :: forall (m :: * -> *) msg.
(MonadFork m, MonadTime m) =>
Text -> msg -> m (Envelope msg)
mkEnvelope Text
namespace msg
message = do
  UTCTime
timestamp <- forall (m :: * -> *). MonadTime m => m UTCTime
getCurrentTime
  Int
threadId <- ThreadId m -> Int
mkThreadId forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadThread m => m (ThreadId m)
myThreadId
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Envelope{Text
namespace :: Text
namespace :: Text
namespace, UTCTime
timestamp :: UTCTime
timestamp :: UTCTime
timestamp, Int
threadId :: Int
threadId :: Int
threadId, msg
message :: msg
message :: msg
message}
 where
  -- NOTE(AB): This is a bit contrived but we want a numeric threadId and we
  -- get some text which we know the structure of
  mkThreadId :: ThreadId m -> Int
mkThreadId = forall a. a -> Maybe a -> a
fromMaybe Int
0 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Read a => String -> Maybe a
readMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Text.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Text -> Text
Text.drop Int
9 forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show