{-# LANGUAGE UndecidableInstances #-}

-- | Structured JSON logging over the
-- [contra-tracer](https://hackage.haskell.org/package/contra-tracer) generic
-- logging framework. A 'Tracer' acquired here wraps each message in an
-- 'Envelope' carrying a timestamp, thread id and namespace, and writes it as
-- one JSON object per line.
module Control.Tracer.JSON (
  -- * Tracer
  Tracer (..),
  natTracer,
  nullTracer,
  traceWith,
  contramap,

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

import Control.Concurrent.Class.Labelled (newLabelledTBQueueIO, newLabelledTVarIO, withAsyncLabelled)
import Control.Concurrent.Class.MonadSTM (
  MonadLabelledSTM,
  MonadSTM,
  TVar,
  atomically,
  flushTBQueue,
  modifyTVar,
  readTVar,
  readTVarIO,
  retry,
  writeTBQueue,
  writeTVar,
 )
import Control.Exception (AsyncException (HeapOverflow, StackOverflow), IOException, SomeAsyncException, SomeException, displayException, evaluate, fromException, throwIO)
import Control.Monad (forM_, unless, void, when, (>=>))
import Control.Monad.Class.MonadAsync (waitCatch)
import Control.Monad.Class.MonadFork (MonadFork, myThreadId)
import Control.Monad.Class.MonadSay (MonadSay, say)
import Control.Monad.Class.MonadThrow (MonadCatch, catch, finally, onException)
import Control.Monad.Class.MonadTime.SI (MonadTime, getCurrentTime)
import Control.Monad.Class.MonadTimer.SI (timeout)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Tracer (Tracer (..), natTracer, nullTracer, traceWith)
import Data.Aeson (FromJSON, ToJSON (..), pairs, (.=))
import Data.Aeson qualified as Aeson
import Data.ByteString.Lazy qualified as LBS
import Data.Functor.Contravariant (contramap)
import Data.Maybe (fromMaybe, isJust)
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Text.Encoding (decodeUtf8)
import Data.Time.Clock (DiffTime, UTCTime)
import GHC.Generics (Generic)
import Numeric.Natural (Natural)
import System.IO (BufferMode (BlockBuffering), Handle, hFlush, hSetBuffering, stdout)
import Text.Read (readMaybe)

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] -> Encoding
[Verbosity] -> Value
Verbosity -> Bool
Verbosity -> Encoding
Verbosity -> Value
(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
timestamp :: forall a. Envelope a -> UTCTime
timestamp :: UTCTime
timestamp, Int
threadId :: forall a. Envelope a -> Int
threadId :: Int
threadId, Text
namespace :: forall a. Envelope a -> Text
namespace :: Text
namespace, a
message :: 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 ()
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 IO (Envelope msg) -> TVar IO Bool -> IO ()
forall {m :: * -> *}.
(MonadSTM m, MonadIO m) =>
TBQueue m (Envelope msg) -> TVar m Bool -> m ()
writeLogs TBQueue (Envelope msg)
TBQueue IO (Envelope msg)
msgQueue TVar Bool
TVar IO 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
forall {m :: * -> *} {a}.
(MonadFork m, MonadTime m, MonadIO m) =>
TBQueue (Envelope a) -> Tracer m a
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 ()
forall {m :: * -> *} {a}. MonadIO m => TVar Bool -> Async a -> m ()
drainLogs TVar Bool
closed Async IO ()
Async ()
writer
 where
  tracer :: TBQueue (Envelope a) -> Tracer m a
tracer TBQueue (Envelope a)
queue =
    (a -> m ()) -> Tracer m a
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer ((a -> m ()) -> Tracer m a) -> (a -> m ()) -> Tracer m a
forall a b. (a -> b) -> a -> b
$
      Text -> a -> m (Envelope a)
forall (m :: * -> *) msg.
(MonadFork m, MonadTime m) =>
Text -> msg -> m (Envelope msg)
mkEnvelope Text
namespace (a -> m (Envelope a)) -> (Envelope a -> m ()) -> a -> 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 a -> IO ()) -> Envelope a -> 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 a -> STM ()) -> Envelope a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TBQueue IO (Envelope a) -> Envelope a -> STM IO ()
forall a. TBQueue IO a -> a -> STM IO ()
forall (m :: * -> *) a. MonadSTM m => TBQueue m a -> a -> STM m ()
writeTBQueue TBQueue (Envelope a)
TBQueue IO (Envelope a)
queue

  writeLogs :: TBQueue m (Envelope msg) -> TVar m Bool -> m ()
writeLogs TBQueue m (Envelope msg)
queue TVar m Bool
closed = do
    [Envelope msg]
entries <- STM m [Envelope msg] -> m [Envelope msg]
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m [Envelope msg] -> m [Envelope msg])
-> STM m [Envelope msg] -> m [Envelope msg]
forall a b. (a -> b) -> a -> b
$ do
      [Envelope msg]
es <- TBQueue m (Envelope msg) -> STM m [Envelope msg]
forall a. TBQueue m a -> STM m [a]
forall (m :: * -> *) a. MonadSTM m => TBQueue m a -> STM m [a]
flushTBQueue TBQueue m (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 m () -> STM m ()
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 m () -> STM m ()) -> STM m () -> STM m ()
forall a b. (a -> b) -> a -> b
$ do
        Bool
isClosed <- TVar m Bool -> STM m Bool
forall a. TVar m a -> STM m a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m Bool
closed
        Bool -> STM m () -> STM m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
isClosed STM m ()
forall a. STM m a
forall (m :: * -> *) a. MonadSTM m => STM m a
retry
      [Envelope msg] -> STM m [Envelope msg]
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Envelope msg]
es
    Bool -> m () -> m ()
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) (m () -> m ()) -> m () -> m ()
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 () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
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 (Envelope msg -> IO ByteString
encodeEntry (Envelope msg -> IO ByteString)
-> (ByteString -> IO ()) -> Envelope msg -> IO ()
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> ByteString -> IO ()
write) 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 ()
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 m (Envelope msg) -> TVar m Bool -> m ()
writeLogs TBQueue m (Envelope msg)
queue TVar m 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 a -> m ()
drainLogs TVar Bool
closed Async a
writer = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
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 a)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe (Either SomeException a)) -> IO ())
-> IO (Maybe (Either SomeException a)) -> IO ()
forall a b. (a -> b) -> a -> b
$ DiffTime
-> IO (Either SomeException a)
-> IO (Maybe (Either SomeException a))
forall a. DiffTime -> IO a -> IO (Maybe a)
forall (m :: * -> *) a.
MonadTimer m =>
DiffTime -> m a -> m (Maybe a)
timeout DiffTime
drainGraceSeconds (Async IO a -> IO (Either SomeException a)
forall a. Async IO a -> IO (Either SomeException a)
forall (m :: * -> *) a.
MonadAsync m =>
Async m a -> m (Either SomeException a)
waitCatch Async IO a
Async a
writer)
    Handle -> IO ()
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")

  -- Encode and force, so a failure surfaces to the caller's handler rather than
  -- later, wherever the lazy result happens to be consumed.
  forceEncoded :: ToJSON entry => entry -> IO LBS.ByteString
  forceEncoded :: forall entry. ToJSON entry => entry -> IO ByteString
forceEncoded entry
x = let bytes :: ByteString
bytes = entry -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode entry
x in ByteString
bytes ByteString -> IO Int64 -> IO ByteString
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Int64 -> IO Int64
forall a. a -> IO a
evaluate (ByteString -> Int64
LBS.length ByteString
bytes)

  -- Run the substitute on any synchronous failure; cancellation still
  -- propagates.
  orSubstitute :: IO r -> (SomeException -> IO r) -> IO r
  orSubstitute :: forall r. IO r -> (SomeException -> IO r) -> IO r
orSubstitute IO r
attempt SomeException -> IO r
substitute =
    IO r
attempt IO r -> (SomeException -> IO r) -> IO r
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` \SomeException
e -> if SomeException -> Bool
isCancellation SomeException
e then SomeException -> IO r
forall e a. Exception e => e -> IO a
throwIO SomeException
e else SomeException -> IO r
substitute SomeException
e

  -- Only what a canceller raises.
  --
  -- 'SomeAsyncException' alone is too broad: 'AsyncException's own 'Exception'
  -- instance wraps itself in it, so 'StackOverflow' and 'HeapOverflow' match as
  -- well -- and those come out of the encoding work rather than from anybody
  -- cancelling us. Rethrowing them would kill the writer on exactly the kind of
  -- entry it is meant to survive, so they are excluded by name. 'ThreadKilled'
  -- and 'UserInterrupt' do mean stop; so does anything else async, such as
  -- 'AsyncCancelled' from the surrounding 'withAsync'.
  isCancellation :: SomeException -> Bool
  isCancellation :: SomeException -> Bool
isCancellation SomeException
e =
    case SomeException -> Maybe AsyncException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e :: Maybe AsyncException of
      Just AsyncException
StackOverflow -> Bool
False
      Just AsyncException
HeapOverflow -> Bool
False
      Just AsyncException
_ -> Bool
True
      Maybe AsyncException
Nothing -> Maybe SomeAsyncException -> Bool
forall a. Maybe a -> Bool
isJust (SomeException -> Maybe SomeAsyncException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e :: Maybe SomeAsyncException)

  -- Last resort, when even the diagnostic entry cannot be encoded. A constant,
  -- so it has nothing left to fail on.
  unencodableFallback :: LBS.ByteString
  unencodableFallback :: ByteString
unencodableFallback = ByteString
"{\"message\":{\"tag\":\"UnencodableLogEntry\"}}"

  -- Encode one entry, forcing it here so that a partial 'ToJSON' cannot take
  -- this thread down.
  --
  -- A 'ToJSON' instance reachable from a traced type can be partial: it may
  -- force a value whose computation calls 'error' (for example a lazily cached
  -- cryptographic commitment that is only computable for inputs below some
  -- size). Left unguarded, that exception surfaces here rather than at the
  -- 'traceWith' call site, and this thread dying is much worse than one lost
  -- log line: it is deliberately not linked to its parent, so nothing notices
  -- until the bounded queue fills, at which point every 'traceWith' in the
  -- process blocks forever on a queue nobody drains. Substitute a diagnostic
  -- entry for the one that cannot be encoded and keep the loop alive.
  --
  -- Cancellation is rethrown: the surrounding 'withAsync' must still be able to
  -- stop this thread.
  encodeEntry :: Envelope msg -> IO LBS.ByteString
  encodeEntry :: Envelope msg -> IO ByteString
encodeEntry Envelope msg
envelope =
    Envelope msg -> IO ByteString
forall entry. ToJSON entry => entry -> IO ByteString
forceEncoded Envelope msg
envelope IO ByteString -> (SomeException -> IO ByteString) -> IO ByteString
forall r. IO r -> (SomeException -> IO r) -> IO r
`orSubstitute` \SomeException
e ->
      -- The substitute is forced here too. Returning it lazily would leave it to
      -- be encoded by 'write', outside this handler, and it can fail in turn:
      -- 'displayException' on an exception whose 'show' is partial throws, which
      -- is precisely the escape this function exists to prevent. If even that
      -- fails, fall back to constant bytes, which cannot.
      Envelope Value -> IO ByteString
forall entry. ToJSON entry => entry -> IO ByteString
forceEncoded (SomeException -> Envelope Value
unencodable SomeException
e) IO ByteString -> (SomeException -> IO ByteString) -> IO ByteString
forall r. IO r -> (SomeException -> IO r) -> IO r
`orSubstitute` \SomeException
_ -> ByteString -> IO ByteString
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
unencodableFallback
   where
    Envelope{UTCTime
timestamp :: forall a. Envelope a -> UTCTime
timestamp :: UTCTime
timestamp, Int
threadId :: forall a. Envelope a -> Int
threadId :: Int
threadId} = Envelope msg
envelope

    unencodable :: SomeException -> Envelope Aeson.Value
    unencodable :: SomeException -> Envelope Value
unencodable SomeException
e =
      Envelope
        { UTCTime
timestamp :: UTCTime
timestamp :: UTCTime
timestamp
        , Int
threadId :: Int
threadId :: Int
threadId
        , Text
namespace :: Text
namespace :: Text
namespace
        , message :: Value
message =
            [Pair] -> Value
Aeson.object
              [ Key
"tag" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Text
"UnencodableLogEntry" :: Text)
              , Key
"reason" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= String -> Text
Text.pack (SomeException -> String
forall e. Exception e => e -> String
displayException SomeException
e)
              ]
        }

-- | 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
. Text -> String
Text.unpack (Text -> String)
-> (Envelope msg -> Text) -> Envelope msg -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decodeUtf8 (ByteString -> Text)
-> (Envelope msg -> ByteString) -> Envelope msg -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
LBS.toStrict (ByteString -> ByteString)
-> (Envelope msg -> ByteString) -> Envelope msg -> ByteString
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
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 = 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
. Int -> ShowS
forall a. Int -> [a] -> [a]
drop Int
9 ShowS -> (ThreadId m -> String) -> ThreadId m -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ThreadId m -> String
forall a. Show a => a -> String
show