{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ImpredicativeTypes #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}         -- For the MonadBaseControl instance.
{-# 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, 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.Concurrent.STM.Lifted (TChan, TVar, atomically, modifyTVar', newTChanIO, newTVarIO, readTVar, writeTChan, writeTVar)
import Control.Exception.Lifted (finally)
import Control.Monad.Base (MonadBase, liftBase)
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.Error.Class (MonadError)
import Control.Monad.State.Class (MonadState)
import Control.Monad.Trans.Class (MonadTrans, lift)
import Control.Monad.Trans.Control (MonadBaseControl(..), RunInBase)
import Control.Monad.Writer.Class (MonadWriter)
import qualified Data.Aeson as JSON
import Data.Coerce
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)

-- | 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 (Maybe Scope) m a
traceTReader :: ReaderT (Maybe 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, 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
           , MonadWriter w, MonadState s, MonadError e
           , 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, MonadBase b )

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 Maybe Scope -> m a
g)) = ReaderT (Maybe Scope) m a -> TraceT m a
forall (m :: * -> *) a. ReaderT (Maybe Scope) m a -> TraceT m a
TraceT (ReaderT (Maybe Scope) m a -> TraceT m a)
-> ReaderT (Maybe Scope) m a -> TraceT m a
forall a b. (a -> b) -> a -> b
$ (Maybe Scope -> m a) -> ReaderT (Maybe Scope) m a
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((Maybe Scope -> m a) -> ReaderT (Maybe Scope) m a)
-> (Maybe Scope -> m a) -> ReaderT (Maybe Scope) m a
forall a b. (a -> b) -> a -> b
$ \Maybe 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
$ Maybe Scope -> m a
g Maybe Scope
r

-- Cannot be derived in GHC 8.0 due to type family.
instance MonadBaseControl b m => MonadBaseControl b (TraceT m) where
  type StM (TraceT m) a = StM (ReaderT Scope m) a
  liftBaseWith :: forall a. (RunInBase (TraceT m) b -> b a) -> TraceT m a
  liftBaseWith :: (RunInBase (TraceT m) b -> b a) -> TraceT m a
liftBaseWith
    = ((RunInBase (ReaderT (Maybe Scope) m) b -> b a)
 -> ReaderT (Maybe Scope) m a)
-> (RunInBase (TraceT m) b -> b a) -> TraceT m a
coerce @((RunInBase (ReaderT (Maybe Scope) m) b -> b a) -> ReaderT (Maybe Scope) m a)
             (RunInBase (ReaderT (Maybe Scope) m) b -> b a)
-> ReaderT (Maybe Scope) m a
forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
(RunInBase m b -> b a) -> m a
liftBaseWith
  restoreM :: forall a. StM (TraceT m) a -> TraceT m a
  restoreM :: StM (TraceT m) a -> TraceT m a
restoreM
    = (StM (ReaderT (Maybe Scope) m) a -> ReaderT (Maybe Scope) m a)
-> StM m a -> TraceT m a
coerce @(StM (ReaderT (Maybe Scope) m) a -> ReaderT (Maybe Scope) m a)
             StM (ReaderT (Maybe Scope) m) a -> ReaderT (Maybe Scope) m a
forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
StM m a -> m a
restoreM

instance (MonadIO m, MonadBaseControl IO m) => MonadTrace (TraceT m) where
  trace :: Builder -> TraceT m a -> TraceT m a
trace Builder
bldr (TraceT ReaderT (Maybe Scope) m a
reader) = ReaderT (Maybe Scope) m a -> TraceT m a
forall (m :: * -> *) a. ReaderT (Maybe Scope) m a -> TraceT m a
TraceT (ReaderT (Maybe Scope) m a -> TraceT m a)
-> ReaderT (Maybe Scope) m a -> TraceT m a
forall a b. (a -> b) -> a -> b
$ ReaderT (Maybe Scope) m (Maybe Scope)
forall r (m :: * -> *). MonadReader r m => m r
ask ReaderT (Maybe Scope) m (Maybe Scope)
-> (Maybe Scope -> ReaderT (Maybe Scope) m a)
-> ReaderT (Maybe Scope) m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe Scope
Nothing -> ReaderT (Maybe Scope) m a
reader
    Just Scope
parentScope -> do
      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 (Maybe Scope) m SpanID
-> (SpanID -> ReaderT (Maybe Scope) m SpanID)
-> Maybe SpanID
-> ReaderT (Maybe Scope) m SpanID
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (IO SpanID -> ReaderT (Maybe Scope) m SpanID
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase IO SpanID
randomSpanID) SpanID -> ReaderT (Maybe Scope) m SpanID
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe SpanID -> ReaderT (Maybe Scope) m SpanID)
-> Maybe SpanID -> ReaderT (Maybe Scope) m SpanID
forall a b. (a -> b) -> a -> b
$ Builder -> Maybe SpanID
builderSpanID Builder
bldr
      TraceID
traceID <- ReaderT (Maybe Scope) m TraceID
-> (TraceID -> ReaderT (Maybe Scope) m TraceID)
-> Maybe TraceID
-> ReaderT (Maybe Scope) m TraceID
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (IO TraceID -> ReaderT (Maybe Scope) m TraceID
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase IO TraceID
randomTraceID) TraceID -> ReaderT (Maybe Scope) m TraceID
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe TraceID -> ReaderT (Maybe Scope) m TraceID)
-> Maybe TraceID -> ReaderT (Maybe 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 (Maybe Scope) m SamplingDecision
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO SamplingPolicy
policy
        Maybe SamplingPolicy
Nothing -> SamplingDecision -> ReaderT (Maybe Scope) m SamplingDecision
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SamplingDecision -> ReaderT (Maybe Scope) m SamplingDecision)
-> SamplingDecision -> ReaderT (Maybe 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 (Maybe Scope) m (TVar Tags)
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO (Tags -> ReaderT (Maybe Scope) m (TVar Tags))
-> Tags -> ReaderT (Maybe Scope) m (TVar Tags)
forall a b. (a -> b) -> a -> b
$ Builder -> Tags
builderTags Builder
bldr
          TVar Logs
logsTV <- Logs -> ReaderT (Maybe Scope) m (TVar Logs)
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO []
          TVar (Maybe POSIXTime)
startTV <- Maybe POSIXTime -> ReaderT (Maybe 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 (Maybe Scope) m a
run = do
              POSIXTime
start <- IO POSIXTime -> ReaderT (Maybe Scope) m POSIXTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO POSIXTime -> ReaderT (Maybe Scope) m POSIXTime)
-> IO POSIXTime -> ReaderT (Maybe Scope) m POSIXTime
forall a b. (a -> b) -> a -> b
$ IO POSIXTime
getPOSIXTime
              STM () -> ReaderT (Maybe Scope) m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> ReaderT (Maybe Scope) m ())
-> STM () -> ReaderT (Maybe 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)
              (Maybe Scope -> Maybe Scope)
-> ReaderT (Maybe Scope) m a -> ReaderT (Maybe Scope) m a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (Maybe Scope -> Maybe Scope -> Maybe Scope
forall a b. a -> b -> a
const (Maybe Scope -> Maybe Scope -> Maybe Scope)
-> Maybe Scope -> Maybe Scope -> Maybe Scope
forall a b. (a -> b) -> a -> b
$ Scope -> Maybe Scope
forall a. a -> Maybe a
Just (Scope -> Maybe Scope) -> Scope -> Maybe 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 (Maybe Scope) m a
reader
            cleanup :: ReaderT (Maybe Scope) m ()
cleanup = do
              POSIXTime
end <- IO POSIXTime -> ReaderT (Maybe Scope) m POSIXTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO POSIXTime -> ReaderT (Maybe Scope) m POSIXTime)
-> IO POSIXTime -> ReaderT (Maybe Scope) m POSIXTime
forall a b. (a -> b) -> a -> b
$ IO POSIXTime
getPOSIXTime
              STM () -> ReaderT (Maybe Scope) m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> ReaderT (Maybe Scope) m ())
-> STM () -> ReaderT (Maybe 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 (Maybe Scope) m a
run ReaderT (Maybe Scope) m a
-> ReaderT (Maybe Scope) m () -> ReaderT (Maybe Scope) m a
forall (m :: * -> *) a b.
MonadBaseControl IO m =>
m a -> m b -> m a
`finally` ReaderT (Maybe Scope) m ()
cleanup
        else (Maybe Scope -> Maybe Scope)
-> ReaderT (Maybe Scope) m a -> ReaderT (Maybe Scope) m a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (Maybe Scope -> Maybe Scope -> Maybe Scope
forall a b. a -> b -> a
const (Maybe Scope -> Maybe Scope -> Maybe Scope)
-> Maybe Scope -> Maybe Scope -> Maybe Scope
forall a b. (a -> b) -> a -> b
$ Scope -> Maybe Scope
forall a. a -> Maybe a
Just (Scope -> Maybe Scope) -> Scope -> Maybe 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 (Maybe Scope) m a
reader

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

  addSpanEntry :: Key -> Value -> TraceT m ()
addSpanEntry Key
key (TagValue Value
val) = ReaderT (Maybe Scope) m () -> TraceT m ()
forall (m :: * -> *) a. ReaderT (Maybe Scope) m a -> TraceT m a
TraceT (ReaderT (Maybe Scope) m () -> TraceT m ())
-> ReaderT (Maybe Scope) m () -> TraceT m ()
forall a b. (a -> b) -> a -> b
$ do
    Maybe (TVar Tags)
mbTV <- (Maybe Scope -> Maybe (TVar Tags))
-> ReaderT (Maybe Scope) m (Maybe (TVar Tags))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Maybe Scope -> (Scope -> Maybe (TVar Tags)) -> Maybe (TVar Tags)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Scope -> Maybe (TVar Tags)
scopeTags)
    Maybe (TVar Tags)
-> (TVar Tags -> ReaderT (Maybe Scope) m ())
-> ReaderT (Maybe 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 (Maybe Scope) m ())
 -> ReaderT (Maybe Scope) m ())
-> (TVar Tags -> ReaderT (Maybe Scope) m ())
-> ReaderT (Maybe Scope) m ()
forall a b. (a -> b) -> a -> b
$ \TVar Tags
tv -> STM () -> ReaderT (Maybe Scope) m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> ReaderT (Maybe Scope) m ())
-> STM () -> ReaderT (Maybe 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 (Maybe Scope) m () -> TraceT m ()
forall (m :: * -> *) a. ReaderT (Maybe Scope) m a -> TraceT m a
TraceT (ReaderT (Maybe Scope) m () -> TraceT m ())
-> ReaderT (Maybe Scope) m () -> TraceT m ()
forall a b. (a -> b) -> a -> b
$ do
    Maybe (TVar Logs)
mbTV <- (Maybe Scope -> Maybe (TVar Logs))
-> ReaderT (Maybe Scope) m (Maybe (TVar Logs))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Maybe Scope -> (Scope -> Maybe (TVar Logs)) -> Maybe (TVar Logs)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Scope -> Maybe (TVar Logs)
scopeLogs)
    Maybe (TVar Logs)
-> (TVar Logs -> ReaderT (Maybe Scope) m ())
-> ReaderT (Maybe 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 (Maybe Scope) m ())
 -> ReaderT (Maybe Scope) m ())
-> (TVar Logs -> ReaderT (Maybe Scope) m ())
-> ReaderT (Maybe Scope) m ()
forall a b. (a -> b) -> a -> b
$ \TVar Logs
tv -> do
      POSIXTime
time <- ReaderT (Maybe Scope) m POSIXTime
-> (POSIXTime -> ReaderT (Maybe Scope) m POSIXTime)
-> Maybe POSIXTime
-> ReaderT (Maybe Scope) m POSIXTime
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (IO POSIXTime -> ReaderT (Maybe Scope) m POSIXTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO POSIXTime
getPOSIXTime) POSIXTime -> ReaderT (Maybe Scope) m POSIXTime
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe POSIXTime
mbTime
      STM () -> ReaderT (Maybe Scope) m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> ReaderT (Maybe Scope) m ())
-> STM () -> ReaderT (Maybe 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]
:)

-- | 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.
--
-- See 'runTraceT'' for a variant which allows discarding spans.
runTraceT :: TraceT m a -> Tracer -> m a
runTraceT :: TraceT m a -> Tracer -> m a
runTraceT TraceT m a
actn Tracer
tracer = TraceT m a -> Maybe Tracer -> m a
forall (m :: * -> *) a. TraceT m a -> Maybe Tracer -> m a
runTraceT' TraceT m a
actn (Tracer -> Maybe Tracer
forall a. a -> Maybe a
Just Tracer
tracer)

-- | Maybe trace an action. If the tracer is 'Nothing', no spans will be published.
runTraceT' :: TraceT m a -> Maybe Tracer -> m a
runTraceT' :: TraceT m a -> Maybe Tracer -> m a
runTraceT' (TraceT ReaderT (Maybe Scope) m a
reader) Maybe Tracer
mbTracer =
  let scope :: Maybe Scope
scope = (Tracer -> Scope) -> Maybe Tracer -> Maybe Scope
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Tracer
tracer -> 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) Maybe Tracer
mbTracer
  in ReaderT (Maybe Scope) m a -> Maybe Scope -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT (Maybe Scope) m a
reader Maybe Scope
scope