{-# LANGUAGE UndecidableInstances #-}

-- | 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).
module Hydra.Logging (
  -- * Tracer
  Tracer (..),
  natTracer,
  nullTracer,
  traceWith,
  ToObject (..),
  TracingVerbosity (..),

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

import Hydra.Prelude

import Cardano.BM.Tracing (ToObject (..), TracingVerbosity (..))
import Control.Concurrent.Class.MonadSTM (
  flushTBQueue,
  modifyTVar,
  readTVarIO,
  retry,
  writeTBQueue,
  writeTVar,
 )
import Control.Exception (IOException)
import Control.Monad.Class.MonadAsync (waitCatch)
import Control.Monad.Class.MonadSay (MonadSay, say)
import Control.Tracer (
  Tracer (..),
  natTracer,
  nullTracer,
  traceWith,
 )
import Data.Aeson (pairs, (.=))
import Data.Aeson qualified as Aeson
import Data.ByteString.Lazy qualified as LBS
import Data.Text qualified as Text

data Verbosity = Quiet | Verbose Text
  deriving stock (Verbosity -> Verbosity -> Bool
(Verbosity -> Verbosity -> Bool)
-> (Verbosity -> Verbosity -> Bool) -> Eq Verbosity
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Verbosity -> Verbosity -> Bool
== :: Verbosity -> Verbosity -> Bool
$c/= :: Verbosity -> Verbosity -> Bool
/= :: Verbosity -> Verbosity -> Bool
Eq, Int -> Verbosity -> ShowS
[Verbosity] -> ShowS
Verbosity -> String
(Int -> Verbosity -> ShowS)
-> (Verbosity -> String)
-> ([Verbosity] -> ShowS)
-> Show Verbosity
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Verbosity -> ShowS
showsPrec :: Int -> Verbosity -> ShowS
$cshow :: Verbosity -> String
show :: Verbosity -> String
$cshowList :: [Verbosity] -> ShowS
showList :: [Verbosity] -> ShowS
Show, (forall x. Verbosity -> Rep Verbosity x)
-> (forall x. Rep Verbosity x -> Verbosity) -> Generic Verbosity
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
$cfrom :: forall x. Verbosity -> Rep Verbosity x
from :: forall x. Verbosity -> Rep Verbosity x
$cto :: forall x. Rep Verbosity x -> Verbosity
to :: forall x. Rep Verbosity x -> Verbosity
Generic)
  deriving anyclass ([Verbosity] -> Value
[Verbosity] -> Encoding
Verbosity -> Bool
Verbosity -> Value
Verbosity -> Encoding
(Verbosity -> Value)
-> (Verbosity -> Encoding)
-> ([Verbosity] -> Value)
-> ([Verbosity] -> Encoding)
-> (Verbosity -> Bool)
-> ToJSON Verbosity
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: Verbosity -> Value
toJSON :: Verbosity -> Value
$ctoEncoding :: Verbosity -> Encoding
toEncoding :: Verbosity -> Encoding
$ctoJSONList :: [Verbosity] -> Value
toJSONList :: [Verbosity] -> Value
$ctoEncodingList :: [Verbosity] -> Encoding
toEncodingList :: [Verbosity] -> Encoding
$comitField :: Verbosity -> Bool
omitField :: Verbosity -> Bool
ToJSON, Maybe Verbosity
Value -> Parser [Verbosity]
Value -> Parser Verbosity
(Value -> Parser Verbosity)
-> (Value -> Parser [Verbosity])
-> Maybe Verbosity
-> FromJSON Verbosity
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser Verbosity
parseJSON :: Value -> Parser Verbosity
$cparseJSONList :: Value -> Parser [Verbosity]
parseJSONList :: Value -> Parser [Verbosity]
$comittedField :: Maybe Verbosity
omittedField :: Maybe 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 stock (Envelope a -> Envelope a -> Bool
(Envelope a -> Envelope a -> Bool)
-> (Envelope a -> Envelope a -> Bool) -> Eq (Envelope a)
forall a. Eq a => Envelope a -> Envelope a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$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
/= :: Envelope a -> Envelope a -> Bool
Eq, Int -> Envelope a -> ShowS
[Envelope a] -> ShowS
Envelope a -> String
(Int -> Envelope a -> ShowS)
-> (Envelope a -> String)
-> ([Envelope a] -> ShowS)
-> Show (Envelope a)
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
$cshowsPrec :: forall a. Show a => Int -> Envelope a -> ShowS
showsPrec :: Int -> Envelope a -> ShowS
$cshow :: forall a. Show a => Envelope a -> String
show :: Envelope a -> String
$cshowList :: forall a. Show a => [Envelope a] -> ShowS
showList :: [Envelope a] -> ShowS
Show, (forall x. Envelope a -> Rep (Envelope a) x)
-> (forall x. Rep (Envelope a) x -> Envelope a)
-> Generic (Envelope a)
forall x. Rep (Envelope a) x -> Envelope a
forall x. Envelope a -> Rep (Envelope a) x
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
$cfrom :: forall a x. Envelope a -> Rep (Envelope a) x
from :: forall x. Envelope a -> Rep (Envelope a) x
$cto :: forall a x. Rep (Envelope a) x -> Envelope a
to :: forall x. Rep (Envelope a) x -> Envelope a
Generic)

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

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

-- | Buffering used for log output. The writer batches whatever the queue holds
-- and flushes each batch, so this bounds the syscalls rather than the latency.
defaultLogBuffering :: BufferMode
defaultLogBuffering :: BufferMode
defaultLogBuffering = Maybe Int -> BufferMode
BlockBuffering (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
64000)

-- | Start logging thread and acquire a 'Tracer'. This tracer will dump all
-- messages 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 = ((Tracer m msg -> IO a) -> Tracer m msg -> IO a
forall a b. (a -> b) -> a -> b
$ Tracer m msg
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer)
withTracer (Verbose Text
namespace) = BufferMode -> Handle -> Text -> (Tracer m msg -> IO a) -> IO a
forall (m :: * -> *) msg a.
(MonadIO m, MonadFork m, MonadTime m, ToJSON msg) =>
BufferMode -> Handle -> Text -> (Tracer m msg -> IO a) -> IO a
withTracerOutputTo BufferMode
defaultLogBuffering 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) =>
  BufferMode ->
  Handle ->
  Text ->
  (Tracer m msg -> IO a) ->
  IO a
withTracerOutputTo :: forall (m :: * -> *) msg a.
(MonadIO m, MonadFork m, MonadTime m, ToJSON msg) =>
BufferMode -> Handle -> Text -> (Tracer m msg -> IO a) -> IO a
withTracerOutputTo BufferMode
bufferingMode Handle
hdl Text
namespace Tracer m msg -> IO a
action = do
  Handle -> BufferMode -> IO ()
forall (m :: * -> *). MonadIO m => Handle -> BufferMode -> m ()
hSetBuffering Handle
hdl BufferMode
bufferingMode
  TBQueue (Envelope msg)
msgQueue <- forall (m :: * -> *) a.
MonadLabelledSTM m =>
String -> Natural -> m (TBQueue m a)
newLabelledTBQueueIO @_ @(Envelope msg) String
"logging-msg-queue" Natural
defaultQueueSize
  TVar Bool
closed <- String -> Bool -> IO (TVar IO Bool)
forall (m :: * -> *) a.
MonadLabelledSTM m =>
String -> a -> m (TVar m a)
newLabelledTVarIO String
"logging-closed" Bool
False
  (String, IO ()) -> (Async IO () -> IO a) -> IO a
forall (m :: * -> *) a b.
MonadAsync m =>
(String, m a) -> (Async m a -> m b) -> m b
withAsyncLabelled (String
"logging-writeLogs", TBQueue (Envelope msg) -> TVar Bool -> IO ()
writeLogs TBQueue (Envelope msg)
msgQueue TVar Bool
closed) ((Async IO () -> IO a) -> IO a) -> (Async IO () -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Async IO ()
writer ->
    Tracer m msg -> IO a
action (TBQueue (Envelope msg) -> Tracer m msg
tracer TBQueue (Envelope msg)
msgQueue) IO a -> IO () -> IO a
forall a b. IO a -> IO b -> IO a
forall (m :: * -> *) a b. MonadThrow m => m a -> m b -> m a
`finally` TVar Bool -> Async () -> IO ()
drainLogs TVar Bool
closed Async IO ()
Async ()
writer
 where
  tracer :: TBQueue (Envelope msg) -> Tracer m msg
tracer TBQueue (Envelope msg)
queue =
    (msg -> m ()) -> Tracer m msg
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer ((msg -> m ()) -> Tracer m msg) -> (msg -> m ()) -> Tracer m msg
forall a b. (a -> b) -> a -> b
$
      Text -> msg -> m (Envelope msg)
forall (m :: * -> *) msg.
(MonadFork m, MonadTime m) =>
Text -> msg -> m (Envelope msg)
mkEnvelope Text
namespace (msg -> m (Envelope msg)) -> (Envelope msg -> m ()) -> msg -> m ()
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (Envelope msg -> IO ()) -> Envelope msg -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM () -> IO ()
STM IO () -> IO ()
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM () -> IO ())
-> (Envelope msg -> STM ()) -> Envelope msg -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TBQueue IO (Envelope msg) -> Envelope msg -> STM IO ()
forall a. TBQueue IO a -> a -> STM IO ()
forall (m :: * -> *) a. MonadSTM m => TBQueue m a -> a -> STM m ()
writeTBQueue TBQueue (Envelope msg)
TBQueue IO (Envelope msg)
queue

  writeLogs :: TBQueue (Envelope msg) -> TVar Bool -> IO ()
writeLogs TBQueue (Envelope msg)
queue TVar Bool
closed = do
    [Envelope msg]
entries <- STM IO [Envelope msg] -> IO [Envelope msg]
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM IO [Envelope msg] -> IO [Envelope msg])
-> STM IO [Envelope msg] -> IO [Envelope msg]
forall a b. (a -> b) -> a -> b
$ do
      [Envelope msg]
es <- TBQueue IO (Envelope msg) -> STM IO [Envelope msg]
forall a. TBQueue IO a -> STM IO [a]
forall (m :: * -> *) a. MonadSTM m => TBQueue m a -> STM m [a]
flushTBQueue TBQueue (Envelope msg)
TBQueue IO (Envelope msg)
queue
      -- Block until there is something to write, or exit the loop below by
      -- returning the empty batch once the tracer scope has closed.
      Bool -> STM () -> STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Envelope msg] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Envelope msg]
es) (STM () -> STM ()) -> STM () -> STM ()
forall a b. (a -> b) -> a -> b
$ do
        Bool
isClosed <- TVar IO Bool -> STM IO Bool
forall a. TVar IO a -> STM IO a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar Bool
TVar IO Bool
closed
        Bool -> STM () -> STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
isClosed STM ()
STM IO ()
forall a. STM IO a
forall (m :: * -> *) a. MonadSTM m => STM m a
retry
      [Envelope msg] -> STM [Envelope msg]
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Envelope msg]
es
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Envelope msg] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Envelope msg]
entries) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      -- Flush once per drained batch, so the block buffer does not hold the
      -- first entries back until 64KB has accumulated.
      --
      -- Losing the batch must not take the node with it: GHC ignores SIGPIPE,
      -- so a reader that goes away turns the next write into an IOException,
      -- and this thread is not linked to its parent. Dying here would go
      -- unnoticed until the queue filled, at which point every 'traceWith' in
      -- the node blocks forever on a queue nobody drains.
      IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        ([Envelope msg] -> (Envelope msg -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Envelope msg]
entries (ByteString -> IO ()
write (ByteString -> IO ())
-> (Envelope msg -> ByteString) -> Envelope msg -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Envelope msg -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode) IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
forall (m :: * -> *). MonadIO m => Handle -> m ()
hFlush Handle
hdl)
          IO () -> (IOException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \(IOException
_ :: IOException) -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      TBQueue (Envelope msg) -> TVar Bool -> IO ()
writeLogs TBQueue (Envelope msg)
queue TVar Bool
closed

  -- The writer thread claims queued entries before writing them, so shutdown
  -- must hand over to the writer rather than inspect the queue itself: signal
  -- it to stop, wait for it to finish draining, then flush. The wait is
  -- bounded, and the surrounding 'withAsync' cancels a writer that overran it,
  -- but the final flush below is not bounded: a handle whose reader has
  -- stalled can still hold up shutdown until an external signal arrives.
  --
  -- 'waitCatch' rather than 'wait': a writer that died would otherwise rethrow
  -- here, inside a 'finally', and replace whatever actually terminated the
  -- node.
  drainLogs :: TVar Bool -> Async () -> IO ()
drainLogs TVar Bool
closed Async ()
writer = IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    STM IO () -> IO ()
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM IO () -> IO ()) -> STM IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar IO Bool -> Bool -> STM IO ()
forall a. TVar IO a -> a -> STM IO ()
forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar Bool
TVar IO Bool
closed Bool
True
    IO (Maybe (Either SomeException ())) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe (Either SomeException ())) -> IO ())
-> IO (Maybe (Either SomeException ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ DiffTime
-> IO (Either SomeException ())
-> IO (Maybe (Either SomeException ()))
forall a. DiffTime -> IO a -> IO (Maybe a)
forall (m :: * -> *) a.
MonadTimer m =>
DiffTime -> m a -> m (Maybe a)
timeout DiffTime
drainGraceSeconds (Async IO () -> IO (Either SomeException ())
forall a. Async IO a -> IO (Either SomeException a)
forall (m :: * -> *) a.
MonadAsync m =>
Async m a -> m (Either SomeException a)
waitCatch Async IO ()
Async ()
writer)
    Handle -> IO ()
forall (m :: * -> *). MonadIO m => Handle -> m ()
hFlush Handle
hdl IO () -> (IOException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \(IOException
_ :: IOException) -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

  drainGraceSeconds :: DiffTime
  drainGraceSeconds :: DiffTime
drainGraceSeconds = DiffTime
5

  write :: ByteString -> IO ()
write ByteString
bs = Handle -> ByteString -> IO ()
LBS.hPut Handle
hdl (ByteString
bs ByteString -> ByteString -> ByteString
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 ::
  (MonadLabelledSTM m, MonadCatch m, MonadFork m, MonadTime m, MonadSay m, ToJSON msg) =>
  Text ->
  (Tracer m msg -> m a) ->
  m a
showLogsOnFailure :: forall (m :: * -> *) msg a.
(MonadLabelledSTM m, MonadCatch m, MonadFork m, MonadTime m,
 MonadSay m, ToJSON msg) =>
Text -> (Tracer m msg -> m a) -> m a
showLogsOnFailure Text
namespace Tracer m msg -> m a
action = do
  TVar m [Envelope msg]
tvar <- String -> [Envelope msg] -> m (TVar m [Envelope msg])
forall (m :: * -> *) a.
MonadLabelledSTM m =>
String -> a -> m (TVar m a)
newLabelledTVarIO String
"show-logs-on-failure" []
  Tracer m msg -> m a
action (TVar m [Envelope msg] -> Text -> Tracer m msg
forall (m :: * -> *) msg.
(MonadFork m, MonadTime m, MonadSTM m) =>
TVar m [Envelope msg] -> Text -> Tracer m msg
traceInTVar TVar m [Envelope msg]
tvar Text
namespace)
    m a -> m () -> m a
forall a b. m a -> m b -> m a
forall (m :: * -> *) a b. MonadCatch m => m a -> m b -> m a
`onException` (TVar m [Envelope msg] -> m [Envelope msg]
forall a. TVar m a -> m a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> m a
readTVarIO TVar m [Envelope msg]
tvar m [Envelope msg] -> ([Envelope msg] -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Envelope msg -> m ()) -> [Envelope msg] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String -> m ()
forall (m :: * -> *). MonadSay m => String -> m ()
say (String -> m ())
-> (Envelope msg -> String) -> Envelope msg -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 (ByteString -> String)
-> (Envelope msg -> ByteString) -> Envelope msg -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Envelope msg -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode) ([Envelope msg] -> m ())
-> ([Envelope msg] -> [Envelope msg]) -> [Envelope msg] -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Envelope msg] -> [Envelope msg]
forall a. [a] -> [a]
reverse)

traceInTVar ::
  (MonadFork m, MonadTime m, MonadSTM m) =>
  TVar m [Envelope msg] ->
  Text ->
  Tracer m msg
traceInTVar :: forall (m :: * -> *) msg.
(MonadFork m, MonadTime m, MonadSTM m) =>
TVar m [Envelope msg] -> Text -> Tracer m msg
traceInTVar TVar m [Envelope msg]
tvar Text
namespace = (msg -> m ()) -> Tracer m msg
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer ((msg -> m ()) -> Tracer m msg) -> (msg -> m ()) -> Tracer m msg
forall a b. (a -> b) -> a -> b
$ \msg
msg -> do
  Envelope msg
envelope <- Text -> msg -> m (Envelope msg)
forall (m :: * -> *) msg.
(MonadFork m, MonadTime m) =>
Text -> msg -> m (Envelope msg)
mkEnvelope Text
namespace msg
msg
  STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ TVar m [Envelope msg]
-> ([Envelope msg] -> [Envelope msg]) -> STM m ()
forall a. TVar m a -> (a -> a) -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
TVar m a -> (a -> a) -> STM m ()
modifyTVar TVar m [Envelope msg]
tvar (Envelope msg
envelope :)
-- * 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 <- m UTCTime
forall (m :: * -> *). MonadTime m => m UTCTime
getCurrentTime
  Int
threadId <- ThreadId m -> Int
mkThreadId (ThreadId m -> Int) -> m (ThreadId m) -> m Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (ThreadId m)
forall (m :: * -> *). MonadThread m => m (ThreadId m)
myThreadId
  Envelope msg -> m (Envelope msg)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Envelope msg -> m (Envelope msg))
-> Envelope msg -> m (Envelope msg)
forall a b. (a -> b) -> a -> b
$ Envelope{Text
$sel:namespace:Envelope :: Text
namespace :: Text
namespace, UTCTime
$sel:timestamp:Envelope :: UTCTime
timestamp :: UTCTime
timestamp, Int
$sel:threadId:Envelope :: Int
threadId :: Int
threadId, msg
$sel:message:Envelope :: 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 = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0 (Maybe Int -> Int)
-> (ThreadId m -> Maybe Int) -> ThreadId m -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe Int)
-> (ThreadId m -> String) -> ThreadId m -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Text.unpack (Text -> String) -> (ThreadId m -> Text) -> ThreadId m -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Text -> Text
Text.drop Int
9 (Text -> Text) -> (ThreadId m -> Text) -> ThreadId m -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ThreadId m -> Text
forall b a. (Show a, IsString b) => a -> b
show