{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-} -- For the MonadReader instance.

-- | This module is useful mostly for tracing backend implementors. If you are only interested in
-- adding tracing to an application, start at "Monitor.Tracing".
module Control.Monad.Trace (
  -- * Tracers
  Tracer, newTracer,
  runTraceT, TraceT,

  -- * Collected data
  -- | Tracers currently expose two pieces of data: completed spans and pending span count. Note
  -- that only sampled spans are eligible: spans which are 'Control.Monad.Trace.Class.neverSampled'
  -- appear in neither.

  -- ** Completed spans
  spanSamples, Sample(..), Tags, Logs,

  -- ** Pending spans
  pendingSpanCount,
) where

import Prelude hiding (span)

import Control.Monad.Trace.Class
import Control.Monad.Trace.Internal

import Control.Applicative ((<|>))
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Reader (ReaderT(ReaderT), ask, asks, local, runReaderT)
import Control.Monad.Reader.Class (MonadReader)
import Control.Monad.Trans.Class (MonadTrans, lift)
import qualified Data.Aeson as JSON
import Data.Foldable (for_)
import Data.List (sortOn)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe (fromMaybe)
import Data.Time.Clock (NominalDiffTime)
import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime)
import UnliftIO (MonadUnliftIO, withRunInIO)
import UnliftIO.Exception (finally)
import UnliftIO.STM (TChan, TVar, atomically, modifyTVar', newTChanIO, newTVarIO, readTVar, writeTChan, writeTVar)

-- | A collection of span tags.
type Tags = Map Key JSON.Value

-- | A collection of span logs.
type Logs = [(POSIXTime, Key, JSON.Value)]

-- | A sampled span and its associated metadata.
data Sample = Sample
  { Sample -> Span
sampleSpan :: !Span
  -- ^ The sampled span.
  , Sample -> Tags
sampleTags :: !Tags
  -- ^ Tags collected during this span.
  , Sample -> Logs
sampleLogs :: !Logs
  -- ^ Logs collected during this span, sorted in chronological order.
  , Sample -> POSIXTime
sampleStart :: !POSIXTime
  -- ^ The time the span started at.
  , Sample -> POSIXTime
sampleDuration :: !NominalDiffTime
  -- ^ The span's duration.
  }

-- | A tracer is a producer of spans.
--
-- More specifically, a tracer:
--
-- * runs 'MonadTrace' actions via 'runTraceT',
-- * transparently collects their generated spans,
-- * and outputs them to a channel (available via 'spanSamples').
--
-- These samples can then be consumed independently, decoupling downstream span processing from
-- their production.
data Tracer = Tracer
  { Tracer -> TChan Sample
tracerChannel :: TChan Sample
  , Tracer -> TVar Int
tracerPendingCount :: TVar Int
  }

-- | Creates a new 'Tracer'.
newTracer :: MonadIO m => m Tracer
newTracer :: m Tracer
newTracer = IO Tracer -> m Tracer
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Tracer -> m Tracer) -> IO Tracer -> m Tracer
forall a b. (a -> b) -> a -> b
$ TChan Sample -> TVar Int -> Tracer
Tracer (TChan Sample -> TVar Int -> Tracer)
-> IO (TChan Sample) -> IO (TVar Int -> Tracer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (TChan Sample)
forall (m :: * -> *) a. MonadIO m => m (TChan a)
newTChanIO IO (TVar Int -> Tracer) -> IO (TVar Int) -> IO Tracer
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> IO (TVar Int)
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO Int
0

-- | Returns the number of spans currently in flight (started but not yet completed).
pendingSpanCount :: Tracer -> TVar Int
pendingSpanCount :: Tracer -> TVar Int
pendingSpanCount = Tracer -> TVar Int
tracerPendingCount

-- | Returns all newly completed spans' samples. The samples become available in the same order they
-- are completed.
spanSamples :: Tracer -> TChan Sample
spanSamples :: Tracer -> TChan Sample
spanSamples = Tracer -> TChan Sample
tracerChannel

data Scope = Scope
  { Scope -> Tracer
scopeTracer :: !Tracer
  , Scope -> Maybe Span
scopeSpan :: !(Maybe Span)
  , Scope -> Maybe (TVar Tags)
scopeTags :: !(Maybe (TVar Tags))
  , Scope -> Maybe (TVar Logs)
scopeLogs :: !(Maybe (TVar Logs))
  }

-- | A span generation monad.
newtype TraceT m a = TraceT { TraceT m a -> ReaderT Scope m a
traceTReader :: ReaderT Scope m a }
  deriving (a -> TraceT m b -> TraceT m a
(a -> b) -> TraceT m a -> TraceT m b
(forall a b. (a -> b) -> TraceT m a -> TraceT m b)
-> (forall a b. a -> TraceT m b -> TraceT m a)
-> Functor (TraceT m)
forall a b. a -> TraceT m b -> TraceT m a
forall a b. (a -> b) -> TraceT m a -> TraceT m b
forall (m :: * -> *) a b.
Functor m =>
a -> TraceT m b -> TraceT m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> TraceT m a -> TraceT m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> TraceT m b -> TraceT m a
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> TraceT m b -> TraceT m a
fmap :: (a -> b) -> TraceT m a -> TraceT m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> TraceT m a -> TraceT m b
Functor, Functor (TraceT m)
a -> TraceT m a
Functor (TraceT m)
-> (forall a. a -> TraceT m a)
-> (forall a b. TraceT m (a -> b) -> TraceT m a -> TraceT m b)
-> (forall a b c.
    (a -> b -> c) -> TraceT m a -> TraceT m b -> TraceT m c)
-> (forall a b. TraceT m a -> TraceT m b -> TraceT m b)
-> (forall a b. TraceT m a -> TraceT m b -> TraceT m a)
-> Applicative (TraceT m)
TraceT m a -> TraceT m b -> TraceT m b
TraceT m a -> TraceT m b -> TraceT m a
TraceT m (a -> b) -> TraceT m a -> TraceT m b
(a -> b -> c) -> TraceT m a -> TraceT m b -> TraceT m c
forall a. a -> TraceT m a
forall a b. TraceT m a -> TraceT m b -> TraceT m a
forall a b. TraceT m a -> TraceT m b -> TraceT m b
forall a b. TraceT m (a -> b) -> TraceT m a -> TraceT m b
forall a b c.
(a -> b -> c) -> TraceT m a -> TraceT m b -> TraceT m c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
forall (m :: * -> *). Applicative m => Functor (TraceT m)
forall (m :: * -> *) a. Applicative m => a -> TraceT m a
forall (m :: * -> *) a b.
Applicative m =>
TraceT m a -> TraceT m b -> TraceT m a
forall (m :: * -> *) a b.
Applicative m =>
TraceT m a -> TraceT m b -> TraceT m b
forall (m :: * -> *) a b.
Applicative m =>
TraceT m (a -> b) -> TraceT m a -> TraceT m b
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> TraceT m a -> TraceT m b -> TraceT m c
<* :: TraceT m a -> TraceT m b -> TraceT m a
$c<* :: forall (m :: * -> *) a b.
Applicative m =>
TraceT m a -> TraceT m b -> TraceT m a
*> :: TraceT m a -> TraceT m b -> TraceT m b
$c*> :: forall (m :: * -> *) a b.
Applicative m =>
TraceT m a -> TraceT m b -> TraceT m b
liftA2 :: (a -> b -> c) -> TraceT m a -> TraceT m b -> TraceT m c
$cliftA2 :: forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> TraceT m a -> TraceT m b -> TraceT m c
<*> :: TraceT m (a -> b) -> TraceT m a -> TraceT m b
$c<*> :: forall (m :: * -> *) a b.
Applicative m =>
TraceT m (a -> b) -> TraceT m a -> TraceT m b
pure :: a -> TraceT m a
$cpure :: forall (m :: * -> *) a. Applicative m => a -> TraceT m a
$cp1Applicative :: forall (m :: * -> *). Applicative m => Functor (TraceT m)
Applicative, Applicative (TraceT m)
a -> TraceT m a
Applicative (TraceT m)
-> (forall a b. TraceT m a -> (a -> TraceT m b) -> TraceT m b)
-> (forall a b. TraceT m a -> TraceT m b -> TraceT m b)
-> (forall a. a -> TraceT m a)
-> Monad (TraceT m)
TraceT m a -> (a -> TraceT m b) -> TraceT m b
TraceT m a -> TraceT m b -> TraceT m b
forall a. a -> TraceT m a
forall a b. TraceT m a -> TraceT m b -> TraceT m b
forall a b. TraceT m a -> (a -> TraceT m b) -> TraceT m b
forall (m :: * -> *). Monad m => Applicative (TraceT m)
forall (m :: * -> *) a. Monad m => a -> TraceT m a
forall (m :: * -> *) a b.
Monad m =>
TraceT m a -> TraceT m b -> TraceT m b
forall (m :: * -> *) a b.
Monad m =>
TraceT m a -> (a -> TraceT m b) -> TraceT m b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> TraceT m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> TraceT m a
>> :: TraceT m a -> TraceT m b -> TraceT m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
TraceT m a -> TraceT m b -> TraceT m b
>>= :: TraceT m a -> (a -> TraceT m b) -> TraceT m b
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
TraceT m a -> (a -> TraceT m b) -> TraceT m b
$cp1Monad :: forall (m :: * -> *). Monad m => Applicative (TraceT m)
Monad, Monad (TraceT m)
Monad (TraceT m)
-> (forall a. IO a -> TraceT m a) -> MonadIO (TraceT m)
IO a -> TraceT m a
forall a. IO a -> TraceT m a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
forall (m :: * -> *). MonadIO m => Monad (TraceT m)
forall (m :: * -> *) a. MonadIO m => IO a -> TraceT m a
liftIO :: IO a -> TraceT m a
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> TraceT m a
$cp1MonadIO :: forall (m :: * -> *). MonadIO m => Monad (TraceT m)
MonadIO, m a -> TraceT m a
(forall (m :: * -> *) a. Monad m => m a -> TraceT m a)
-> MonadTrans TraceT
forall (m :: * -> *) a. Monad m => m a -> TraceT m a
forall (t :: (* -> *) -> * -> *).
(forall (m :: * -> *) a. Monad m => m a -> t m a) -> MonadTrans t
lift :: m a -> TraceT m a
$clift :: forall (m :: * -> *) a. Monad m => m a -> TraceT m a
MonadTrans)

instance MonadReader r m => MonadReader r (TraceT m) where
  ask :: TraceT m r
ask = m r -> TraceT m r
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m r
forall r (m :: * -> *). MonadReader r m => m r
ask
  local :: (r -> r) -> TraceT m a -> TraceT m a
local r -> r
f (TraceT (ReaderT Scope -> m a
g)) = ReaderT Scope m a -> TraceT m a
forall (m :: * -> *) a. ReaderT Scope m a -> TraceT m a
TraceT (ReaderT Scope m a -> TraceT m a)
-> ReaderT Scope m a -> TraceT m a
forall a b. (a -> b) -> a -> b
$ (Scope -> m a) -> ReaderT Scope m a
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((Scope -> m a) -> ReaderT Scope m a)
-> (Scope -> m a) -> ReaderT Scope m a
forall a b. (a -> b) -> a -> b
$ \Scope
r -> (r -> r) -> m a -> m a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local r -> r
f (m a -> m a) -> m a -> m a
forall a b. (a -> b) -> a -> b
$ Scope -> m a
g Scope
r

instance MonadUnliftIO m => MonadTrace (TraceT m) where
  trace :: Builder -> TraceT m a -> TraceT m a
trace Builder
bldr (TraceT ReaderT Scope m a
reader) = ReaderT Scope m a -> TraceT m a
forall (m :: * -> *) a. ReaderT Scope m a -> TraceT m a
TraceT (ReaderT Scope m a -> TraceT m a)
-> ReaderT Scope m a -> TraceT m a
forall a b. (a -> b) -> a -> b
$ do
    Scope
parentScope <- ReaderT Scope m Scope
forall r (m :: * -> *). MonadReader r m => m r
ask
    let
      mbParentSpn :: Maybe Span
mbParentSpn = Scope -> Maybe Span
scopeSpan Scope
parentScope
      mbParentCtx :: Maybe Context
mbParentCtx = Span -> Context
spanContext (Span -> Context) -> Maybe Span -> Maybe Context
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Span
mbParentSpn
      mbTraceID :: Maybe TraceID
mbTraceID = Context -> TraceID
contextTraceID (Context -> TraceID) -> Maybe Context -> Maybe TraceID
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Context
mbParentCtx
    SpanID
spanID <- ReaderT Scope m SpanID
-> (SpanID -> ReaderT Scope m SpanID)
-> Maybe SpanID
-> ReaderT Scope m SpanID
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (IO SpanID -> ReaderT Scope m SpanID
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO SpanID
randomSpanID) SpanID -> ReaderT Scope m SpanID
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe SpanID -> ReaderT Scope m SpanID)
-> Maybe SpanID -> ReaderT Scope m SpanID
forall a b. (a -> b) -> a -> b
$ Builder -> Maybe SpanID
builderSpanID Builder
bldr
    TraceID
traceID <- ReaderT Scope m TraceID
-> (TraceID -> ReaderT Scope m TraceID)
-> Maybe TraceID
-> ReaderT Scope m TraceID
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (IO TraceID -> ReaderT Scope m TraceID
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO TraceID
randomTraceID) TraceID -> ReaderT Scope m TraceID
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe TraceID -> ReaderT Scope m TraceID)
-> Maybe TraceID -> ReaderT Scope m TraceID
forall a b. (a -> b) -> a -> b
$ Builder -> Maybe TraceID
builderTraceID Builder
bldr Maybe TraceID -> Maybe TraceID -> Maybe TraceID
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe TraceID
mbTraceID
    SamplingDecision
sampling <- case Builder -> Maybe SamplingPolicy
builderSamplingPolicy Builder
bldr of
      Just SamplingPolicy
policy -> SamplingPolicy -> ReaderT Scope m SamplingDecision
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO SamplingPolicy
policy
      Maybe SamplingPolicy
Nothing -> SamplingDecision -> ReaderT Scope m SamplingDecision
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SamplingDecision -> ReaderT Scope m SamplingDecision)
-> SamplingDecision -> ReaderT Scope m SamplingDecision
forall a b. (a -> b) -> a -> b
$ SamplingDecision -> Maybe SamplingDecision -> SamplingDecision
forall a. a -> Maybe a -> a
fromMaybe SamplingDecision
Never (Span -> SamplingDecision
spanSamplingDecision (Span -> SamplingDecision) -> Maybe Span -> Maybe SamplingDecision
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Span
mbParentSpn)
    let
      baggages :: Map Key ByteString
baggages = Map Key ByteString
-> Maybe (Map Key ByteString) -> Map Key ByteString
forall a. a -> Maybe a -> a
fromMaybe Map Key ByteString
forall k a. Map k a
Map.empty (Maybe (Map Key ByteString) -> Map Key ByteString)
-> Maybe (Map Key ByteString) -> Map Key ByteString
forall a b. (a -> b) -> a -> b
$ Context -> Map Key ByteString
contextBaggages (Context -> Map Key ByteString)
-> Maybe Context -> Maybe (Map Key ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Context
mbParentCtx
      ctx :: Context
ctx = TraceID -> SpanID -> Map Key ByteString -> Context
Context TraceID
traceID SpanID
spanID (Builder -> Map Key ByteString
builderBaggages Builder
bldr Map Key ByteString -> Map Key ByteString -> Map Key ByteString
forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` Map Key ByteString
baggages)
      spn :: Span
spn = Key -> Context -> Set Reference -> SamplingDecision -> Span
Span (Builder -> Key
builderName Builder
bldr) Context
ctx (Builder -> Set Reference
builderReferences Builder
bldr) SamplingDecision
sampling
      tracer :: Tracer
tracer = Scope -> Tracer
scopeTracer Scope
parentScope
    if Span -> Bool
spanIsSampled Span
spn
      then do
        TVar Tags
tagsTV <- Tags -> ReaderT Scope m (TVar Tags)
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO (Tags -> ReaderT Scope m (TVar Tags))
-> Tags -> ReaderT Scope m (TVar Tags)
forall a b. (a -> b) -> a -> b
$ Builder -> Tags
builderTags Builder
bldr
        TVar Logs
logsTV <- Logs -> ReaderT Scope m (TVar Logs)
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO []
        TVar (Maybe POSIXTime)
startTV <- Maybe POSIXTime -> ReaderT Scope m (TVar (Maybe POSIXTime))
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO Maybe POSIXTime
forall a. Maybe a
Nothing -- To detect whether an exception happened during span setup.
        let
          run :: ReaderT Scope m a
run = do
            POSIXTime
start <- IO POSIXTime -> ReaderT Scope m POSIXTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO POSIXTime -> ReaderT Scope m POSIXTime)
-> IO POSIXTime -> ReaderT Scope m POSIXTime
forall a b. (a -> b) -> a -> b
$ IO POSIXTime
getPOSIXTime
            STM () -> ReaderT Scope m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> ReaderT Scope m ()) -> STM () -> ReaderT Scope m ()
forall a b. (a -> b) -> a -> b
$ do
              TVar (Maybe POSIXTime) -> Maybe POSIXTime -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe POSIXTime)
startTV (POSIXTime -> Maybe POSIXTime
forall a. a -> Maybe a
Just POSIXTime
start)
              TVar Int -> (Int -> Int) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' (Tracer -> TVar Int
tracerPendingCount Tracer
tracer) (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
            (Scope -> Scope) -> ReaderT Scope m a -> ReaderT Scope m a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (Scope -> Scope -> Scope
forall a b. a -> b -> a
const (Scope -> Scope -> Scope) -> Scope -> Scope -> Scope
forall a b. (a -> b) -> a -> b
$ Tracer
-> Maybe Span -> Maybe (TVar Tags) -> Maybe (TVar Logs) -> Scope
Scope Tracer
tracer (Span -> Maybe Span
forall a. a -> Maybe a
Just Span
spn) (TVar Tags -> Maybe (TVar Tags)
forall a. a -> Maybe a
Just TVar Tags
tagsTV) (TVar Logs -> Maybe (TVar Logs)
forall a. a -> Maybe a
Just TVar Logs
logsTV)) ReaderT Scope m a
reader
          cleanup :: ReaderT Scope m ()
cleanup = do
            POSIXTime
end <- IO POSIXTime -> ReaderT Scope m POSIXTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO POSIXTime -> ReaderT Scope m POSIXTime)
-> IO POSIXTime -> ReaderT Scope m POSIXTime
forall a b. (a -> b) -> a -> b
$ IO POSIXTime
getPOSIXTime
            STM () -> ReaderT Scope m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> ReaderT Scope m ()) -> STM () -> ReaderT Scope m ()
forall a b. (a -> b) -> a -> b
$ TVar (Maybe POSIXTime) -> STM (Maybe POSIXTime)
forall a. TVar a -> STM a
readTVar TVar (Maybe POSIXTime)
startTV STM (Maybe POSIXTime) -> (Maybe POSIXTime -> STM ()) -> STM ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              Maybe POSIXTime
Nothing -> () -> STM ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure () -- The action was interrupted before the span was pending.
              Just POSIXTime
start -> do
                TVar Int -> (Int -> Int) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' (Tracer -> TVar Int
tracerPendingCount Tracer
tracer) (\Int
n -> Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
                Tags
tags <- TVar Tags -> STM Tags
forall a. TVar a -> STM a
readTVar TVar Tags
tagsTV
                Logs
logs <- ((POSIXTime, Key, Value) -> (POSIXTime, Key)) -> Logs -> Logs
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (\(POSIXTime
t, Key
k, Value
_) -> (POSIXTime
t, Key
k)) (Logs -> Logs) -> STM Logs -> STM Logs
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar Logs -> STM Logs
forall a. TVar a -> STM a
readTVar TVar Logs
logsTV
                TChan Sample -> Sample -> STM ()
forall a. TChan a -> a -> STM ()
writeTChan (Tracer -> TChan Sample
tracerChannel Tracer
tracer) (Span -> Tags -> Logs -> POSIXTime -> POSIXTime -> Sample
Sample Span
spn Tags
tags Logs
logs POSIXTime
start (POSIXTime
end POSIXTime -> POSIXTime -> POSIXTime
forall a. Num a => a -> a -> a
- POSIXTime
start))
        ReaderT Scope m a
run ReaderT Scope m a -> ReaderT Scope m () -> ReaderT Scope m a
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
`finally` ReaderT Scope m ()
cleanup
      else (Scope -> Scope) -> ReaderT Scope m a -> ReaderT Scope m a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (Scope -> Scope -> Scope
forall a b. a -> b -> a
const (Scope -> Scope -> Scope) -> Scope -> Scope -> Scope
forall a b. (a -> b) -> a -> b
$ Tracer
-> Maybe Span -> Maybe (TVar Tags) -> Maybe (TVar Logs) -> Scope
Scope Tracer
tracer (Span -> Maybe Span
forall a. a -> Maybe a
Just Span
spn) Maybe (TVar Tags)
forall a. Maybe a
Nothing Maybe (TVar Logs)
forall a. Maybe a
Nothing) ReaderT Scope m a
reader

  activeSpan :: TraceT m (Maybe Span)
activeSpan = ReaderT Scope m (Maybe Span) -> TraceT m (Maybe Span)
forall (m :: * -> *) a. ReaderT Scope m a -> TraceT m a
TraceT (ReaderT Scope m (Maybe Span) -> TraceT m (Maybe Span))
-> ReaderT Scope m (Maybe Span) -> TraceT m (Maybe Span)
forall a b. (a -> b) -> a -> b
$ (Scope -> Maybe Span) -> ReaderT Scope m (Maybe Span)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Scope -> Maybe Span
scopeSpan

  addSpanEntry :: Key -> Value -> TraceT m ()
addSpanEntry Key
key (TagValue Value
val) = ReaderT Scope m () -> TraceT m ()
forall (m :: * -> *) a. ReaderT Scope m a -> TraceT m a
TraceT (ReaderT Scope m () -> TraceT m ())
-> ReaderT Scope m () -> TraceT m ()
forall a b. (a -> b) -> a -> b
$ do
    Maybe (TVar Tags)
mbTV <- (Scope -> Maybe (TVar Tags)) -> ReaderT Scope m (Maybe (TVar Tags))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Scope -> Maybe (TVar Tags)
scopeTags
    Maybe (TVar Tags)
-> (TVar Tags -> ReaderT Scope m ()) -> ReaderT Scope m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe (TVar Tags)
mbTV ((TVar Tags -> ReaderT Scope m ()) -> ReaderT Scope m ())
-> (TVar Tags -> ReaderT Scope m ()) -> ReaderT Scope m ()
forall a b. (a -> b) -> a -> b
$ \TVar Tags
tv -> STM () -> ReaderT Scope m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> ReaderT Scope m ()) -> STM () -> ReaderT Scope m ()
forall a b. (a -> b) -> a -> b
$ TVar Tags -> (Tags -> Tags) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar Tags
tv ((Tags -> Tags) -> STM ()) -> (Tags -> Tags) -> STM ()
forall a b. (a -> b) -> a -> b
$ Key -> Value -> Tags -> Tags
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Key
key Value
val
  addSpanEntry Key
key (LogValue Value
val Maybe POSIXTime
mbTime)  = ReaderT Scope m () -> TraceT m ()
forall (m :: * -> *) a. ReaderT Scope m a -> TraceT m a
TraceT (ReaderT Scope m () -> TraceT m ())
-> ReaderT Scope m () -> TraceT m ()
forall a b. (a -> b) -> a -> b
$ do
    Maybe (TVar Logs)
mbTV <- (Scope -> Maybe (TVar Logs)) -> ReaderT Scope m (Maybe (TVar Logs))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Scope -> Maybe (TVar Logs)
scopeLogs
    Maybe (TVar Logs)
-> (TVar Logs -> ReaderT Scope m ()) -> ReaderT Scope m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe (TVar Logs)
mbTV ((TVar Logs -> ReaderT Scope m ()) -> ReaderT Scope m ())
-> (TVar Logs -> ReaderT Scope m ()) -> ReaderT Scope m ()
forall a b. (a -> b) -> a -> b
$ \TVar Logs
tv -> do
      POSIXTime
time <- ReaderT Scope m POSIXTime
-> (POSIXTime -> ReaderT Scope m POSIXTime)
-> Maybe POSIXTime
-> ReaderT Scope m POSIXTime
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (IO POSIXTime -> ReaderT Scope m POSIXTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO POSIXTime
getPOSIXTime) POSIXTime -> ReaderT Scope m POSIXTime
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe POSIXTime
mbTime
      STM () -> ReaderT Scope m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> ReaderT Scope m ()) -> STM () -> ReaderT Scope m ()
forall a b. (a -> b) -> a -> b
$ TVar Logs -> (Logs -> Logs) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar Logs
tv ((POSIXTime
time, Key
key, Value
val) (POSIXTime, Key, Value) -> Logs -> Logs
forall a. a -> [a] -> [a]
:)

instance MonadUnliftIO m => MonadUnliftIO (TraceT m) where
  withRunInIO :: ((forall a. TraceT m a -> IO a) -> IO b) -> TraceT m b
withRunInIO (forall a. TraceT m a -> IO a) -> IO b
inner = ReaderT Scope m b -> TraceT m b
forall (m :: * -> *) a. ReaderT Scope m a -> TraceT m a
TraceT (ReaderT Scope m b -> TraceT m b)
-> ReaderT Scope m b -> TraceT m b
forall a b. (a -> b) -> a -> b
$ ((forall a. ReaderT Scope m a -> IO a) -> IO b)
-> ReaderT Scope m b
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. ReaderT Scope m a -> IO a) -> IO b)
 -> ReaderT Scope m b)
-> ((forall a. ReaderT Scope m a -> IO a) -> IO b)
-> ReaderT Scope m b
forall a b. (a -> b) -> a -> b
$ \forall a. ReaderT Scope m a -> IO a
run -> (forall a. TraceT m a -> IO a) -> IO b
inner (ReaderT Scope m a -> IO a
forall a. ReaderT Scope m a -> IO a
run (ReaderT Scope m a -> IO a)
-> (TraceT m a -> ReaderT Scope m a) -> TraceT m a -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TraceT m a -> ReaderT Scope m a
forall (m :: * -> *) a. TraceT m a -> ReaderT Scope m a
traceTReader)

-- | Trace an action, sampling its generated spans. This method is thread-safe and can be used to
-- trace multiple actions concurrently.
--
-- Unless you are implementing a custom span publication backend, you should not need to call this
-- method explicitly. Instead, prefer to use the backend's functionality directly (e.g.
-- 'Monitor.Tracing.Zipkin.run' for Zipkin). To ease debugging in certain cases,
-- 'Monitor.Tracing.Local.collectSpanSamples' is also available.
runTraceT :: TraceT m a -> Tracer -> m a
runTraceT :: TraceT m a -> Tracer -> m a
runTraceT (TraceT ReaderT Scope m a
reader) Tracer
tracer = ReaderT Scope m a -> Scope -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT Scope m a
reader (Tracer
-> Maybe Span -> Maybe (TVar Tags) -> Maybe (TVar Logs) -> Scope
Scope Tracer
tracer Maybe Span
forall a. Maybe a
Nothing Maybe (TVar Tags)
forall a. Maybe a
Nothing Maybe (TVar Logs)
forall a. Maybe a
Nothing)