{-# 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) in a format which is
-- documented in a [JSON-Schema](https://github.com/cardano-scaling/hydra/blob/master/hydra-node/json-schemas/logs.yaml).
module Hydra.Logging (
  -- * Tracer
  Tracer (..),
  natTracer,
  nullTracer,
  traceWith,
  ToObject (..),
  TracingVerbosity (..),

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

import Hydra.Prelude

import Cardano.BM.Tracing (ToObject (..), TracingVerbosity (..))
import Control.Concurrent.Class.MonadSTM (
  flushTBQueue,
  modifyTVar,
  newTBQueueIO,
  newTVarIO,
  readTBQueue,
  readTVarIO,
  writeTBQueue,
 )
import Control.Monad.Class.MonadFork (myThreadId)
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
import Test.QuickCheck.Instances.Text ()
import Test.QuickCheck.Instances.Time ()

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)

instance Arbitrary Verbosity where
  arbitrary :: Gen Verbosity
arbitrary = Gen Verbosity
forall a.
(Generic a, GA UnsizedOpts (Rep a),
 UniformWeight (Weights_ (Rep a))) =>
Gen a
genericArbitrary
  shrink :: Verbosity -> [Verbosity]
shrink = Verbosity -> [Verbosity]
forall a.
(Generic a, RecursivelyShrink (Rep a), GSubterms (Rep a) a) =>
a -> [a]
genericShrink

-- | 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)
  deriving anyclass (Maybe (Envelope a)
Value -> Parser [Envelope a]
Value -> Parser (Envelope a)
(Value -> Parser (Envelope a))
-> (Value -> Parser [Envelope a])
-> Maybe (Envelope a)
-> FromJSON (Envelope a)
forall a. FromJSON a => Maybe (Envelope a)
forall a. FromJSON a => Value -> Parser [Envelope a]
forall a. FromJSON a => Value -> Parser (Envelope a)
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: forall a. FromJSON a => Value -> Parser (Envelope a)
parseJSON :: Value -> Parser (Envelope a)
$cparseJSONList :: forall a. FromJSON a => Value -> Parser [Envelope a]
parseJSONList :: Value -> Parser [Envelope a]
$comittedField :: forall a. FromJSON a => Maybe (Envelope a)
omittedField :: Maybe (Envelope a)
FromJSON)

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
        ]

instance Arbitrary a => Arbitrary (Envelope a) where
  arbitrary :: Gen (Envelope a)
arbitrary = Gen (Envelope a)
forall a.
(Generic a, GA UnsizedOpts (Rep a),
 UniformWeight (Weights_ (Rep a))) =>
Gen a
genericArbitrary
  shrink :: Envelope a -> [Envelope a]
shrink = Envelope a -> [Envelope a]
forall a.
(Generic a, RecursivelyShrink (Rep a), GSubterms (Rep a) a) =>
a -> [a]
genericShrink

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 = ((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) = Handle -> Text -> (Tracer m msg -> IO a) -> IO a
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. MonadSTM m => Natural -> m (TBQueue m a)
newTBQueueIO @_ @(Envelope msg) Natural
defaultQueueSize
  IO Any -> (Async IO Any -> IO a) -> IO a
forall a b. IO a -> (Async IO a -> IO b) -> IO b
forall (m :: * -> *) a b.
MonadAsync m =>
m a -> (Async m a -> m b) -> m b
withAsync (TBQueue (Envelope msg) -> IO Any
writeLogs TBQueue (Envelope msg)
msgQueue) ((Async IO Any -> IO a) -> IO a) -> (Async IO Any -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Async IO Any
_ ->
    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` TBQueue (Envelope msg) -> IO ()
flushLogs TBQueue (Envelope msg)
msgQueue
 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) -> IO Any
writeLogs TBQueue (Envelope msg)
queue =
    IO () -> IO Any
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO Any) -> IO () -> IO Any
forall a b. (a -> b) -> a -> b
$ do
      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 (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
readTBQueue TBQueue (Envelope msg)
TBQueue IO (Envelope msg)
queue) IO (Envelope msg) -> (Envelope msg -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= 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
      Handle -> IO ()
forall (m :: * -> *). MonadIO m => Handle -> m ()
hFlush Handle
hdl

  flushLogs :: TBQueue (Envelope msg) -> IO ()
flushLogs TBQueue (Envelope msg)
queue = 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
    [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
$ 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
    [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)
    Handle -> IO ()
forall (m :: * -> *). MonadIO m => Handle -> m ()
hFlush Handle
hdl

  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 ::
  (MonadSTM m, MonadCatch m, MonadFork m, MonadTime m, MonadSay m, ToJSON msg) =>
  Text ->
  (Tracer m msg -> m a) ->
  m a
showLogsOnFailure :: forall (m :: * -> *) msg a.
(MonadSTM 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 <- [Envelope msg] -> m (TVar m [Envelope msg])
forall a. a -> m (TVar m a)
forall (m :: * -> *) a. MonadSTM m => a -> m (TVar m a)
newTVarIO []
  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