{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE ScopedTypeVariables #-}
module OpenTelemetry.Trace.Core (
TracerProvider
, createTracerProvider
, shutdownTracerProvider
, forceFlushTracerProvider
, getTracerProviderResources
, getTracerProviderPropagators
, getGlobalTracerProvider
, setGlobalTracerProvider
, emptyTracerProviderOptions
, TracerProviderOptions(..)
, Tracer
, tracerName
, HasTracer(..)
, makeTracer
, getTracer
, getImmutableSpanTracer
, getTracerTracerProvider
, InstrumentationLibrary(..)
, TracerOptions(..)
, tracerOptions
, Span
, ImmutableSpan(..)
, SpanContext(..)
, TraceFlags
, traceFlagsValue
, traceFlagsFromWord8
, defaultTraceFlags
, isSampled
, setSampled
, unsetSampled
, inSpan
, inSpan'
, inSpan''
, createSpan
, createSpanWithoutCallStack
, wrapSpanContext
, SpanKind(..)
, defaultSpanArguments
, SpanArguments(..)
, NewLink(..)
, Link(..)
, Event(..)
, NewEvent(..)
, addEvent
, updateName
, OpenTelemetry.Trace.Core.addAttribute
, OpenTelemetry.Trace.Core.addAttributes
, spanGetAttributes
, Attribute(..)
, ToAttribute(..)
, PrimitiveAttribute(..)
, ToPrimitiveAttribute(..)
, recordException
, setStatus
, SpanStatus(..)
, endSpan
, getSpanContext
, isRecording
, isValid
, spanIsRemote
, Timestamp
, getTimestamp
, timestampNanoseconds
, unsafeReadSpan
, whenSpanIsRecording
, SpanLimits(..)
, defaultSpanLimits
, bracketError
) where
import Control.Applicative
import Control.Concurrent.Async
import Control.Concurrent (myThreadId)
import Control.Exception ( Exception(..), try, SomeException(..) )
import Control.Monad
import Control.Monad.IO.Class
import Data.Coerce
import Data.IORef
import Data.Maybe (isNothing, fromMaybe, isJust)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Typeable
import qualified Data.Vector as V
import Data.Word (Word64)
import GHC.Stack
import Network.HTTP.Types
import OpenTelemetry.Attributes
import qualified OpenTelemetry.Attributes as A
import OpenTelemetry.Context
import OpenTelemetry.Common
import OpenTelemetry.Context.ThreadLocal
import OpenTelemetry.Propagator (Propagator)
import OpenTelemetry.Internal.Trace.Types
import qualified OpenTelemetry.Internal.Trace.Types as Types
import OpenTelemetry.Resource
import OpenTelemetry.Trace.Id
import OpenTelemetry.Trace.Id.Generator
import OpenTelemetry.Trace.Id.Generator.Dummy
import OpenTelemetry.Trace.Sampler
import qualified OpenTelemetry.Trace.TraceState as TraceState
import OpenTelemetry.Util
import System.Clock
import System.IO.Unsafe
import System.Timeout (timeout)
import Control.Monad.IO.Unlift
import OpenTelemetry.Logging.Core (Log)
createSpan :: (MonadIO m, HasCallStack)
=> Tracer
-> Context
-> Text
-> SpanArguments
-> m Span
createSpan :: Tracer -> Context -> Text -> SpanArguments -> m Span
createSpan Tracer
t Context
c Text
n SpanArguments
args = do
Tracer -> Context -> Text -> SpanArguments -> m Span
forall (m :: * -> *).
MonadIO m =>
Tracer -> Context -> Text -> SpanArguments -> m Span
createSpanWithoutCallStack Tracer
t Context
c Text
n (SpanArguments -> m Span) -> SpanArguments -> m Span
forall a b. (a -> b) -> a -> b
$ case CallStack -> [([Char], SrcLoc)]
getCallStack CallStack
HasCallStack => CallStack
callStack of
[] -> SpanArguments
args
([Char]
_, SrcLoc
loc):[([Char], SrcLoc)]
rest ->
let addFunction :: [(Text, Attribute)] -> [(Text, Attribute)]
addFunction = case [([Char], SrcLoc)]
rest of
([Char]
fn, SrcLoc
_):[([Char], SrcLoc)]
_ -> ((Text
"code.function", Text -> Attribute
forall a. ToAttribute a => a -> Attribute
toAttribute (Text -> Attribute) -> Text -> Attribute
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack [Char]
fn) (Text, Attribute) -> [(Text, Attribute)] -> [(Text, Attribute)]
forall a. a -> [a] -> [a]
:)
[] -> [(Text, Attribute)] -> [(Text, Attribute)]
forall a. a -> a
id
in SpanArguments
args
{ attributes :: [(Text, Attribute)]
attributes =
[(Text, Attribute)] -> [(Text, Attribute)]
addFunction
([(Text, Attribute)] -> [(Text, Attribute)])
-> [(Text, Attribute)] -> [(Text, Attribute)]
forall a b. (a -> b) -> a -> b
$ (Text
"code.namespace", Text -> Attribute
forall a. ToAttribute a => a -> Attribute
toAttribute (Text -> Attribute) -> Text -> Attribute
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ SrcLoc -> [Char]
srcLocModule SrcLoc
loc)
(Text, Attribute) -> [(Text, Attribute)] -> [(Text, Attribute)]
forall a. a -> [a] -> [a]
: (Text
"code.filepath", Text -> Attribute
forall a. ToAttribute a => a -> Attribute
toAttribute (Text -> Attribute) -> Text -> Attribute
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ SrcLoc -> [Char]
srcLocFile SrcLoc
loc)
(Text, Attribute) -> [(Text, Attribute)] -> [(Text, Attribute)]
forall a. a -> [a] -> [a]
: (Text
"code.lineno", Int -> Attribute
forall a. ToAttribute a => a -> Attribute
toAttribute (Int -> Attribute) -> Int -> Attribute
forall a b. (a -> b) -> a -> b
$ SrcLoc -> Int
srcLocStartLine SrcLoc
loc)
(Text, Attribute) -> [(Text, Attribute)] -> [(Text, Attribute)]
forall a. a -> [a] -> [a]
: (Text
"code.package", Text -> Attribute
forall a. ToAttribute a => a -> Attribute
toAttribute (Text -> Attribute) -> Text -> Attribute
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ SrcLoc -> [Char]
srcLocPackage SrcLoc
loc)
(Text, Attribute) -> [(Text, Attribute)] -> [(Text, Attribute)]
forall a. a -> [a] -> [a]
: SpanArguments -> [(Text, Attribute)]
attributes SpanArguments
args
}
createSpanWithoutCallStack
:: MonadIO m
=> Tracer
-> Context
-> Text
-> SpanArguments
-> m Span
createSpanWithoutCallStack :: Tracer -> Context -> Text -> SpanArguments -> m Span
createSpanWithoutCallStack Tracer
t Context
ctxt Text
n args :: SpanArguments
args@SpanArguments{[(Text, Attribute)]
[NewLink]
Maybe Timestamp
SpanKind
startTime :: SpanArguments -> Maybe Timestamp
links :: SpanArguments -> [NewLink]
kind :: SpanArguments -> SpanKind
startTime :: Maybe Timestamp
links :: [NewLink]
attributes :: [(Text, Attribute)]
kind :: SpanKind
attributes :: SpanArguments -> [(Text, Attribute)]
..} = IO Span -> m Span
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Span -> m Span) -> IO Span -> m Span
forall a b. (a -> b) -> a -> b
$ do
SpanId
sId <- IdGenerator -> IO SpanId
forall (m :: * -> *). MonadIO m => IdGenerator -> m SpanId
newSpanId (IdGenerator -> IO SpanId) -> IdGenerator -> IO SpanId
forall a b. (a -> b) -> a -> b
$ TracerProvider -> IdGenerator
tracerProviderIdGenerator (TracerProvider -> IdGenerator) -> TracerProvider -> IdGenerator
forall a b. (a -> b) -> a -> b
$ Tracer -> TracerProvider
tracerProvider Tracer
t
let parent :: Maybe Span
parent = Context -> Maybe Span
lookupSpan Context
ctxt
TraceId
tId <- case Maybe Span
parent of
Maybe Span
Nothing -> IdGenerator -> IO TraceId
forall (m :: * -> *). MonadIO m => IdGenerator -> m TraceId
newTraceId (IdGenerator -> IO TraceId) -> IdGenerator -> IO TraceId
forall a b. (a -> b) -> a -> b
$ TracerProvider -> IdGenerator
tracerProviderIdGenerator (TracerProvider -> IdGenerator) -> TracerProvider -> IdGenerator
forall a b. (a -> b) -> a -> b
$ Tracer -> TracerProvider
tracerProvider Tracer
t
Just (Span IORef ImmutableSpan
s) ->
SpanContext -> TraceId
traceId (SpanContext -> TraceId)
-> (ImmutableSpan -> SpanContext) -> ImmutableSpan -> TraceId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImmutableSpan -> SpanContext
Types.spanContext (ImmutableSpan -> TraceId) -> IO ImmutableSpan -> IO TraceId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef ImmutableSpan -> IO ImmutableSpan
forall a. IORef a -> IO a
readIORef IORef ImmutableSpan
s
Just (FrozenSpan SpanContext
s) -> TraceId -> IO TraceId
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TraceId -> IO TraceId) -> TraceId -> IO TraceId
forall a b. (a -> b) -> a -> b
$ SpanContext -> TraceId
traceId SpanContext
s
Just (Dropped SpanContext
s) -> TraceId -> IO TraceId
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TraceId -> IO TraceId) -> TraceId -> IO TraceId
forall a b. (a -> b) -> a -> b
$ SpanContext -> TraceId
traceId SpanContext
s
if Vector Processor -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Vector Processor -> Bool) -> Vector Processor -> Bool
forall a b. (a -> b) -> a -> b
$ TracerProvider -> Vector Processor
tracerProviderProcessors (TracerProvider -> Vector Processor)
-> TracerProvider -> Vector Processor
forall a b. (a -> b) -> a -> b
$ Tracer -> TracerProvider
tracerProvider Tracer
t
then Span -> IO Span
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Span -> IO Span) -> Span -> IO Span
forall a b. (a -> b) -> a -> b
$ SpanContext -> Span
Dropped (SpanContext -> Span) -> SpanContext -> Span
forall a b. (a -> b) -> a -> b
$ TraceFlags
-> Bool -> TraceId -> SpanId -> TraceState -> SpanContext
SpanContext TraceFlags
defaultTraceFlags Bool
False TraceId
tId SpanId
sId TraceState
TraceState.empty
else do
(SamplingResult
samplingOutcome, [(Text, Attribute)]
attrs, TraceState
samplingTraceState) <- case Maybe Span
parent of
Just (Dropped SpanContext
_) -> (SamplingResult, [(Text, Attribute)], TraceState)
-> IO (SamplingResult, [(Text, Attribute)], TraceState)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SamplingResult
Drop, [], TraceState
TraceState.empty)
Maybe Span
_ -> Sampler
-> Context
-> TraceId
-> Text
-> SpanArguments
-> IO (SamplingResult, [(Text, Attribute)], TraceState)
shouldSample (TracerProvider -> Sampler
tracerProviderSampler (TracerProvider -> Sampler) -> TracerProvider -> Sampler
forall a b. (a -> b) -> a -> b
$ Tracer -> TracerProvider
tracerProvider Tracer
t)
Context
ctxt
TraceId
tId
Text
n
SpanArguments
args
let ctxtForSpan :: SpanContext
ctxtForSpan = SpanContext :: TraceFlags
-> Bool -> TraceId -> SpanId -> TraceState -> SpanContext
SpanContext
{ traceFlags :: TraceFlags
traceFlags = case SamplingResult
samplingOutcome of
SamplingResult
Drop -> TraceFlags
defaultTraceFlags
SamplingResult
RecordOnly -> TraceFlags
defaultTraceFlags
SamplingResult
RecordAndSample -> TraceFlags -> TraceFlags
setSampled TraceFlags
defaultTraceFlags
, isRemote :: Bool
isRemote = Bool
False
, traceState :: TraceState
traceState = TraceState
samplingTraceState
, spanId :: SpanId
spanId = SpanId
sId
, traceId :: TraceId
traceId = TraceId
tId
}
mkRecordingSpan :: IO Span
mkRecordingSpan = do
Timestamp
st <- IO Timestamp
-> (Timestamp -> IO Timestamp) -> Maybe Timestamp -> IO Timestamp
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO Timestamp
forall (m :: * -> *). MonadIO m => m Timestamp
getTimestamp Timestamp -> IO Timestamp
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Timestamp
startTime
ThreadId
tid <- IO ThreadId
myThreadId
let additionalInfo :: [(Text, Attribute)]
additionalInfo = [(Text
"thread.id", Int -> Attribute
forall a. ToAttribute a => a -> Attribute
toAttribute (Int -> Attribute) -> Int -> Attribute
forall a b. (a -> b) -> a -> b
$ ThreadId -> Int
getThreadId ThreadId
tid)]
is :: ImmutableSpan
is = ImmutableSpan :: Text
-> Maybe Span
-> SpanContext
-> SpanKind
-> Timestamp
-> Maybe Timestamp
-> Attributes
-> FrozenBoundedCollection Link
-> AppendOnlyBoundedCollection Event
-> SpanStatus
-> Tracer
-> ImmutableSpan
ImmutableSpan
{ spanName :: Text
spanName = Text
n
, spanContext :: SpanContext
spanContext = SpanContext
ctxtForSpan
, spanParent :: Maybe Span
spanParent = Maybe Span
parent
, spanKind :: SpanKind
spanKind = SpanKind
kind
, spanAttributes :: Attributes
spanAttributes =
AttributeLimits -> Attributes -> [(Text, Attribute)] -> Attributes
forall a.
ToAttribute a =>
AttributeLimits -> Attributes -> [(Text, a)] -> Attributes
A.addAttributes
(Tracer -> (SpanLimits -> Maybe Int) -> AttributeLimits
limitBy Tracer
t SpanLimits -> Maybe Int
spanAttributeCountLimit)
Attributes
emptyAttributes
([[(Text, Attribute)]] -> [(Text, Attribute)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Text, Attribute)]
additionalInfo, [(Text, Attribute)]
attrs, [(Text, Attribute)]
attributes])
, spanLinks :: FrozenBoundedCollection Link
spanLinks =
let limitedLinks :: Int
limitedLinks = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
128 (SpanLimits -> Maybe Int
linkCountLimit (SpanLimits -> Maybe Int) -> SpanLimits -> Maybe Int
forall a b. (a -> b) -> a -> b
$ TracerProvider -> SpanLimits
tracerProviderSpanLimits (TracerProvider -> SpanLimits) -> TracerProvider -> SpanLimits
forall a b. (a -> b) -> a -> b
$ Tracer -> TracerProvider
tracerProvider Tracer
t)
in Int -> [Link] -> FrozenBoundedCollection Link
forall (f :: * -> *) a.
Foldable f =>
Int -> f a -> FrozenBoundedCollection a
frozenBoundedCollection Int
limitedLinks ([Link] -> FrozenBoundedCollection Link)
-> [Link] -> FrozenBoundedCollection Link
forall a b. (a -> b) -> a -> b
$ (NewLink -> Link) -> [NewLink] -> [Link]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NewLink -> Link
freezeLink [NewLink]
links
, spanEvents :: AppendOnlyBoundedCollection Event
spanEvents = Int -> AppendOnlyBoundedCollection Event
forall a. Int -> AppendOnlyBoundedCollection a
emptyAppendOnlyBoundedCollection (Int -> AppendOnlyBoundedCollection Event)
-> Int -> AppendOnlyBoundedCollection Event
forall a b. (a -> b) -> a -> b
$ Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
128 (SpanLimits -> Maybe Int
eventCountLimit (SpanLimits -> Maybe Int) -> SpanLimits -> Maybe Int
forall a b. (a -> b) -> a -> b
$ TracerProvider -> SpanLimits
tracerProviderSpanLimits (TracerProvider -> SpanLimits) -> TracerProvider -> SpanLimits
forall a b. (a -> b) -> a -> b
$ Tracer -> TracerProvider
tracerProvider Tracer
t)
, spanStatus :: SpanStatus
spanStatus = SpanStatus
Unset
, spanStart :: Timestamp
spanStart = Timestamp
st
, spanEnd :: Maybe Timestamp
spanEnd = Maybe Timestamp
forall a. Maybe a
Nothing
, spanTracer :: Tracer
spanTracer = Tracer
t
}
IORef ImmutableSpan
s <- ImmutableSpan -> IO (IORef ImmutableSpan)
forall a. a -> IO (IORef a)
newIORef ImmutableSpan
is
Either SomeException ()
eResult <- IO () -> IO (Either SomeException ())
forall e a. Exception e => IO a -> IO (Either e a)
try (IO () -> IO (Either SomeException ()))
-> IO () -> IO (Either SomeException ())
forall a b. (a -> b) -> a -> b
$ (Processor -> IO ()) -> Vector Processor -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\Processor
processor -> Processor -> IORef ImmutableSpan -> Context -> IO ()
processorOnStart Processor
processor IORef ImmutableSpan
s Context
ctxt) (Vector Processor -> IO ()) -> Vector Processor -> IO ()
forall a b. (a -> b) -> a -> b
$ TracerProvider -> Vector Processor
tracerProviderProcessors (TracerProvider -> Vector Processor)
-> TracerProvider -> Vector Processor
forall a b. (a -> b) -> a -> b
$ Tracer -> TracerProvider
tracerProvider Tracer
t
case Either SomeException ()
eResult of
Left SomeException
err -> SomeException -> IO ()
forall a. Show a => a -> IO ()
print (SomeException
err :: SomeException)
Right ()
_ -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Span -> IO Span
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Span -> IO Span) -> Span -> IO Span
forall a b. (a -> b) -> a -> b
$ IORef ImmutableSpan -> Span
Span IORef ImmutableSpan
s
case SamplingResult
samplingOutcome of
SamplingResult
Drop -> Span -> IO Span
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Span -> IO Span) -> Span -> IO Span
forall a b. (a -> b) -> a -> b
$ SpanContext -> Span
Dropped SpanContext
ctxtForSpan
SamplingResult
RecordOnly -> IO Span
mkRecordingSpan
SamplingResult
RecordAndSample -> IO Span
mkRecordingSpan
where
freezeLink :: NewLink -> Link
freezeLink :: NewLink -> Link
freezeLink NewLink{[(Text, Attribute)]
SpanContext
linkAttributes :: NewLink -> [(Text, Attribute)]
linkContext :: NewLink -> SpanContext
linkAttributes :: [(Text, Attribute)]
linkContext :: SpanContext
..} = Link :: SpanContext -> Attributes -> Link
Link
{ frozenLinkContext :: SpanContext
frozenLinkContext = SpanContext
linkContext
, frozenLinkAttributes :: Attributes
frozenLinkAttributes = AttributeLimits -> Attributes -> [(Text, Attribute)] -> Attributes
forall a.
ToAttribute a =>
AttributeLimits -> Attributes -> [(Text, a)] -> Attributes
A.addAttributes (Tracer -> (SpanLimits -> Maybe Int) -> AttributeLimits
limitBy Tracer
t SpanLimits -> Maybe Int
linkAttributeCountLimit) Attributes
A.emptyAttributes [(Text, Attribute)]
linkAttributes
}
inSpan
:: (MonadUnliftIO m, HasCallStack)
=> Tracer
-> Text
-> SpanArguments
-> m a
-> m a
inSpan :: Tracer -> Text -> SpanArguments -> m a -> m a
inSpan Tracer
t Text
n SpanArguments
args m a
m = Tracer
-> CallStack -> Text -> SpanArguments -> (Span -> m a) -> m a
forall (m :: * -> *) a.
(MonadUnliftIO m, HasCallStack) =>
Tracer
-> CallStack -> Text -> SpanArguments -> (Span -> m a) -> m a
inSpan'' Tracer
t CallStack
HasCallStack => CallStack
callStack Text
n SpanArguments
args (m a -> Span -> m a
forall a b. a -> b -> a
const m a
m)
inSpan'
:: (MonadUnliftIO m, HasCallStack)
=> Tracer
-> Text
-> SpanArguments
-> (Span -> m a)
-> m a
inSpan' :: Tracer -> Text -> SpanArguments -> (Span -> m a) -> m a
inSpan' Tracer
t = Tracer
-> CallStack -> Text -> SpanArguments -> (Span -> m a) -> m a
forall (m :: * -> *) a.
(MonadUnliftIO m, HasCallStack) =>
Tracer
-> CallStack -> Text -> SpanArguments -> (Span -> m a) -> m a
inSpan'' Tracer
t CallStack
HasCallStack => CallStack
callStack
inSpan''
:: (MonadUnliftIO m, HasCallStack)
=> Tracer
-> CallStack
-> Text
-> SpanArguments
-> (Span -> m a)
-> m a
inSpan'' :: Tracer
-> CallStack -> Text -> SpanArguments -> (Span -> m a) -> m a
inSpan'' Tracer
t CallStack
cs Text
n SpanArguments
args Span -> m a
f = do
m (Maybe Span, Span)
-> (Maybe SomeException -> (Maybe Span, Span) -> m ())
-> ((Maybe Span, Span) -> m a)
-> m a
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (Maybe SomeException -> a -> m b) -> (a -> m c) -> m c
bracketError
(IO (Maybe Span, Span) -> m (Maybe Span, Span)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Span, Span) -> m (Maybe Span, Span))
-> IO (Maybe Span, Span) -> m (Maybe Span, Span)
forall a b. (a -> b) -> a -> b
$ do
Context
ctx <- IO Context
forall (m :: * -> *). MonadIO m => m Context
getContext
Span
s <- Tracer -> Context -> Text -> SpanArguments -> IO Span
forall (m :: * -> *).
MonadIO m =>
Tracer -> Context -> Text -> SpanArguments -> m Span
createSpanWithoutCallStack Tracer
t Context
ctx Text
n SpanArguments
args
(Context -> Context) -> IO ()
forall (m :: * -> *). MonadIO m => (Context -> Context) -> m ()
adjustContext (Span -> Context -> Context
insertSpan Span
s)
Span -> IO () -> IO ()
forall (m :: * -> *). MonadIO m => Span -> m () -> m ()
whenSpanIsRecording Span
s (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
case CallStack -> [([Char], SrcLoc)]
getCallStack CallStack
cs of
[] -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
([Char]
fn, SrcLoc
loc):[([Char], SrcLoc)]
_ -> do
Span -> [(Text, Attribute)] -> IO ()
forall (m :: * -> *).
MonadIO m =>
Span -> [(Text, Attribute)] -> m ()
OpenTelemetry.Trace.Core.addAttributes Span
s
[ (Text
"code.function", Text -> Attribute
forall a. ToAttribute a => a -> Attribute
toAttribute (Text -> Attribute) -> Text -> Attribute
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack [Char]
fn)
, (Text
"code.namespace", Text -> Attribute
forall a. ToAttribute a => a -> Attribute
toAttribute (Text -> Attribute) -> Text -> Attribute
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ SrcLoc -> [Char]
srcLocModule SrcLoc
loc)
, (Text
"code.filepath", Text -> Attribute
forall a. ToAttribute a => a -> Attribute
toAttribute (Text -> Attribute) -> Text -> Attribute
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ SrcLoc -> [Char]
srcLocFile SrcLoc
loc)
, (Text
"code.lineno", Int -> Attribute
forall a. ToAttribute a => a -> Attribute
toAttribute (Int -> Attribute) -> Int -> Attribute
forall a b. (a -> b) -> a -> b
$ SrcLoc -> Int
srcLocStartLine SrcLoc
loc)
, (Text
"code.package", Text -> Attribute
forall a. ToAttribute a => a -> Attribute
toAttribute (Text -> Attribute) -> Text -> Attribute
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ SrcLoc -> [Char]
srcLocPackage SrcLoc
loc)
]
(Maybe Span, Span) -> IO (Maybe Span, Span)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Context -> Maybe Span
lookupSpan Context
ctx, Span
s)
)
(\Maybe SomeException
e (Maybe Span
parent, Span
s) -> IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
Maybe SomeException -> (SomeException -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe SomeException
e ((SomeException -> IO ()) -> IO ())
-> (SomeException -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(SomeException e
inner) -> do
Span -> SpanStatus -> IO ()
forall (m :: * -> *). MonadIO m => Span -> SpanStatus -> m ()
setStatus Span
s (SpanStatus -> IO ()) -> SpanStatus -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> SpanStatus
Error (Text -> SpanStatus) -> Text -> SpanStatus
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ e -> [Char]
forall e. Exception e => e -> [Char]
displayException e
inner
Span -> [(Text, Attribute)] -> Maybe Timestamp -> e -> IO ()
forall (m :: * -> *) e.
(MonadIO m, Exception e) =>
Span -> [(Text, Attribute)] -> Maybe Timestamp -> e -> m ()
recordException Span
s [] Maybe Timestamp
forall a. Maybe a
Nothing e
inner
Span -> Maybe Timestamp -> IO ()
forall (m :: * -> *). MonadIO m => Span -> Maybe Timestamp -> m ()
endSpan Span
s Maybe Timestamp
forall a. Maybe a
Nothing
(Context -> Context) -> IO ()
forall (m :: * -> *). MonadIO m => (Context -> Context) -> m ()
adjustContext ((Context -> Context) -> IO ()) -> (Context -> Context) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Context
ctx ->
Context -> (Span -> Context) -> Maybe Span -> Context
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Context
ctx (Span -> Context -> Context
`insertSpan` Context
ctx) Maybe Span
parent
)
(\(Maybe Span
_, Span
s) -> Span -> m a
f Span
s)
isRecording :: MonadIO m => Span -> m Bool
isRecording :: Span -> m Bool
isRecording (Span IORef ImmutableSpan
s) = IO Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Maybe Timestamp -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe Timestamp -> Bool)
-> (ImmutableSpan -> Maybe Timestamp) -> ImmutableSpan -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImmutableSpan -> Maybe Timestamp
spanEnd (ImmutableSpan -> Bool) -> IO ImmutableSpan -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef ImmutableSpan -> IO ImmutableSpan
forall a. IORef a -> IO a
readIORef IORef ImmutableSpan
s)
isRecording (FrozenSpan SpanContext
_) = Bool -> m Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
isRecording (Dropped SpanContext
_) = Bool -> m Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
addAttribute :: (MonadIO m, A.ToAttribute a)
=> Span
-> Text
-> a
-> m ()
addAttribute :: Span -> Text -> a -> m ()
addAttribute (Span IORef ImmutableSpan
s) Text
k a
v = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef ImmutableSpan -> (ImmutableSpan -> ImmutableSpan) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef ImmutableSpan
s ((ImmutableSpan -> ImmutableSpan) -> IO ())
-> (ImmutableSpan -> ImmutableSpan) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ImmutableSpan
i -> ImmutableSpan
i
{ spanAttributes :: Attributes
spanAttributes =
AttributeLimits -> Attributes -> Text -> a -> Attributes
forall a.
ToAttribute a =>
AttributeLimits -> Attributes -> Text -> a -> Attributes
OpenTelemetry.Attributes.addAttribute
(Tracer -> (SpanLimits -> Maybe Int) -> AttributeLimits
limitBy (ImmutableSpan -> Tracer
spanTracer ImmutableSpan
i) SpanLimits -> Maybe Int
spanAttributeCountLimit)
(ImmutableSpan -> Attributes
spanAttributes ImmutableSpan
i)
Text
k
a
v
}
addAttribute (FrozenSpan SpanContext
_) Text
_ a
_ = () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
addAttribute (Dropped SpanContext
_) Text
_ a
_ = () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
addAttributes :: MonadIO m => Span -> [(Text, A.Attribute)] -> m ()
addAttributes :: Span -> [(Text, Attribute)] -> m ()
addAttributes (Span IORef ImmutableSpan
s) [(Text, Attribute)]
attrs = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef ImmutableSpan -> (ImmutableSpan -> ImmutableSpan) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef ImmutableSpan
s ((ImmutableSpan -> ImmutableSpan) -> IO ())
-> (ImmutableSpan -> ImmutableSpan) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ImmutableSpan
i -> ImmutableSpan
i
{ spanAttributes :: Attributes
spanAttributes =
AttributeLimits -> Attributes -> [(Text, Attribute)] -> Attributes
forall a.
ToAttribute a =>
AttributeLimits -> Attributes -> [(Text, a)] -> Attributes
OpenTelemetry.Attributes.addAttributes
(Tracer -> (SpanLimits -> Maybe Int) -> AttributeLimits
limitBy (ImmutableSpan -> Tracer
spanTracer ImmutableSpan
i) SpanLimits -> Maybe Int
spanAttributeCountLimit)
(ImmutableSpan -> Attributes
spanAttributes ImmutableSpan
i)
[(Text, Attribute)]
attrs
}
addAttributes (FrozenSpan SpanContext
_) [(Text, Attribute)]
_ = () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
addAttributes (Dropped SpanContext
_) [(Text, Attribute)]
_ = () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
addEvent :: MonadIO m => Span -> NewEvent -> m ()
addEvent :: Span -> NewEvent -> m ()
addEvent (Span IORef ImmutableSpan
s) NewEvent{[(Text, Attribute)]
Maybe Timestamp
Text
newEventTimestamp :: NewEvent -> Maybe Timestamp
newEventAttributes :: NewEvent -> [(Text, Attribute)]
newEventName :: NewEvent -> Text
newEventTimestamp :: Maybe Timestamp
newEventAttributes :: [(Text, Attribute)]
newEventName :: Text
..} = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
Timestamp
t <- IO Timestamp
-> (Timestamp -> IO Timestamp) -> Maybe Timestamp -> IO Timestamp
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO Timestamp
forall (m :: * -> *). MonadIO m => m Timestamp
getTimestamp Timestamp -> IO Timestamp
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Timestamp
newEventTimestamp
IORef ImmutableSpan -> (ImmutableSpan -> ImmutableSpan) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef ImmutableSpan
s ((ImmutableSpan -> ImmutableSpan) -> IO ())
-> (ImmutableSpan -> ImmutableSpan) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ImmutableSpan
i -> ImmutableSpan
i
{ spanEvents :: AppendOnlyBoundedCollection Event
spanEvents = AppendOnlyBoundedCollection Event
-> Event -> AppendOnlyBoundedCollection Event
forall a.
AppendOnlyBoundedCollection a -> a -> AppendOnlyBoundedCollection a
appendToBoundedCollection (ImmutableSpan -> AppendOnlyBoundedCollection Event
spanEvents ImmutableSpan
i) (Event -> AppendOnlyBoundedCollection Event)
-> Event -> AppendOnlyBoundedCollection Event
forall a b. (a -> b) -> a -> b
$
Event :: Text -> Attributes -> Timestamp -> Event
Event
{ eventName :: Text
eventName = Text
newEventName
, eventAttributes :: Attributes
eventAttributes = AttributeLimits -> Attributes -> [(Text, Attribute)] -> Attributes
forall a.
ToAttribute a =>
AttributeLimits -> Attributes -> [(Text, a)] -> Attributes
A.addAttributes
(Tracer -> (SpanLimits -> Maybe Int) -> AttributeLimits
limitBy (ImmutableSpan -> Tracer
spanTracer ImmutableSpan
i) SpanLimits -> Maybe Int
eventAttributeCountLimit)
Attributes
emptyAttributes
[(Text, Attribute)]
newEventAttributes
, eventTimestamp :: Timestamp
eventTimestamp = Timestamp
t
}
}
addEvent (FrozenSpan SpanContext
_) NewEvent
_ = () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
addEvent (Dropped SpanContext
_) NewEvent
_ = () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
setStatus :: MonadIO m => Span -> SpanStatus -> m ()
setStatus :: Span -> SpanStatus -> m ()
setStatus (Span IORef ImmutableSpan
s) SpanStatus
st = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef ImmutableSpan -> (ImmutableSpan -> ImmutableSpan) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef ImmutableSpan
s ((ImmutableSpan -> ImmutableSpan) -> IO ())
-> (ImmutableSpan -> ImmutableSpan) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ImmutableSpan
i -> ImmutableSpan
i
{ spanStatus :: SpanStatus
spanStatus = if SpanStatus
st SpanStatus -> SpanStatus -> Bool
forall a. Ord a => a -> a -> Bool
> ImmutableSpan -> SpanStatus
spanStatus ImmutableSpan
i
then SpanStatus
st
else ImmutableSpan -> SpanStatus
spanStatus ImmutableSpan
i
}
setStatus (FrozenSpan SpanContext
_) SpanStatus
_ = () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
setStatus (Dropped SpanContext
_) SpanStatus
_ = () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
updateName :: MonadIO m =>
Span
-> Text
-> m ()
updateName :: Span -> Text -> m ()
updateName (Span IORef ImmutableSpan
s) Text
n = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef ImmutableSpan -> (ImmutableSpan -> ImmutableSpan) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef ImmutableSpan
s ((ImmutableSpan -> ImmutableSpan) -> IO ())
-> (ImmutableSpan -> ImmutableSpan) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ImmutableSpan
i -> ImmutableSpan
i { spanName :: Text
spanName = Text
n }
updateName (FrozenSpan SpanContext
_) Text
_ = () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
updateName (Dropped SpanContext
_) Text
_ = () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
endSpan :: MonadIO m
=> Span
-> Maybe Timestamp
-> m ()
endSpan :: Span -> Maybe Timestamp -> m ()
endSpan (Span IORef ImmutableSpan
s) Maybe Timestamp
mts = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
Timestamp
ts <- IO Timestamp
-> (Timestamp -> IO Timestamp) -> Maybe Timestamp -> IO Timestamp
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO Timestamp
forall (m :: * -> *). MonadIO m => m Timestamp
getTimestamp Timestamp -> IO Timestamp
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Timestamp
mts
(Bool
alreadyFinished, ImmutableSpan
frozenS) <- IORef ImmutableSpan
-> (ImmutableSpan -> (ImmutableSpan, (Bool, ImmutableSpan)))
-> IO (Bool, ImmutableSpan)
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef ImmutableSpan
s ((ImmutableSpan -> (ImmutableSpan, (Bool, ImmutableSpan)))
-> IO (Bool, ImmutableSpan))
-> (ImmutableSpan -> (ImmutableSpan, (Bool, ImmutableSpan)))
-> IO (Bool, ImmutableSpan)
forall a b. (a -> b) -> a -> b
$ \ImmutableSpan
i ->
let ref :: ImmutableSpan
ref = ImmutableSpan
i { spanEnd :: Maybe Timestamp
spanEnd = ImmutableSpan -> Maybe Timestamp
spanEnd ImmutableSpan
i Maybe Timestamp -> Maybe Timestamp -> Maybe Timestamp
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Timestamp -> Maybe Timestamp
forall a. a -> Maybe a
Just Timestamp
ts }
in (ImmutableSpan
ref, (Maybe Timestamp -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Timestamp -> Bool) -> Maybe Timestamp -> Bool
forall a b. (a -> b) -> a -> b
$ ImmutableSpan -> Maybe Timestamp
spanEnd ImmutableSpan
i, ImmutableSpan
ref))
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
alreadyFinished (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Either SomeException ()
eResult <- IO () -> IO (Either SomeException ())
forall e a. Exception e => IO a -> IO (Either e a)
try (IO () -> IO (Either SomeException ()))
-> IO () -> IO (Either SomeException ())
forall a b. (a -> b) -> a -> b
$ (Processor -> IO ()) -> Vector Processor -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Processor -> IORef ImmutableSpan -> IO ()
`processorOnEnd` IORef ImmutableSpan
s) (Vector Processor -> IO ()) -> Vector Processor -> IO ()
forall a b. (a -> b) -> a -> b
$ TracerProvider -> Vector Processor
tracerProviderProcessors (TracerProvider -> Vector Processor)
-> TracerProvider -> Vector Processor
forall a b. (a -> b) -> a -> b
$ Tracer -> TracerProvider
tracerProvider (Tracer -> TracerProvider) -> Tracer -> TracerProvider
forall a b. (a -> b) -> a -> b
$ ImmutableSpan -> Tracer
spanTracer ImmutableSpan
frozenS
case Either SomeException ()
eResult of
Left SomeException
err -> SomeException -> IO ()
forall a. Show a => a -> IO ()
print (SomeException
err :: SomeException)
Right ()
_ -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
endSpan (FrozenSpan SpanContext
_) Maybe Timestamp
_ = () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
endSpan (Dropped SpanContext
_) Maybe Timestamp
_ = () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
recordException :: (MonadIO m, Exception e) => Span -> [(Text, Attribute)] -> Maybe Timestamp -> e -> m ()
recordException :: Span -> [(Text, Attribute)] -> Maybe Timestamp -> e -> m ()
recordException Span
s [(Text, Attribute)]
attrs Maybe Timestamp
ts e
e = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
[[Char]]
cs <- e -> IO [[Char]]
forall a. a -> IO [[Char]]
whoCreated e
e
let message :: Text
message = [Char] -> Text
T.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ e -> [Char]
forall a. Show a => a -> [Char]
show e
e
Span -> NewEvent -> IO ()
forall (m :: * -> *). MonadIO m => Span -> NewEvent -> m ()
addEvent Span
s (NewEvent -> IO ()) -> NewEvent -> IO ()
forall a b. (a -> b) -> a -> b
$ NewEvent :: Text -> [(Text, Attribute)] -> Maybe Timestamp -> NewEvent
NewEvent
{ newEventName :: Text
newEventName = Text
"exception"
, newEventAttributes :: [(Text, Attribute)]
newEventAttributes =
[(Text, Attribute)]
attrs [(Text, Attribute)] -> [(Text, Attribute)] -> [(Text, Attribute)]
forall a. [a] -> [a] -> [a]
++
[ (Text
"exception.type", Text -> Attribute
forall a. ToAttribute a => a -> Attribute
A.toAttribute (Text -> Attribute) -> Text -> Attribute
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ TypeRep -> [Char]
forall a. Show a => a -> [Char]
show (TypeRep -> [Char]) -> TypeRep -> [Char]
forall a b. (a -> b) -> a -> b
$ e -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf e
e)
, (Text
"exception.message", Text -> Attribute
forall a. ToAttribute a => a -> Attribute
A.toAttribute Text
message)
, (Text
"exception.stacktrace", Text -> Attribute
forall a. ToAttribute a => a -> Attribute
A.toAttribute (Text -> Attribute) -> Text -> Attribute
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ ([Char] -> Text) -> [[Char]] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Text
T.pack [[Char]]
cs)
]
, newEventTimestamp :: Maybe Timestamp
newEventTimestamp = Maybe Timestamp
ts
}
isValid :: SpanContext -> Bool
isValid :: SpanContext -> Bool
isValid SpanContext
sc = Bool -> Bool
not
(TraceId -> Bool
isEmptyTraceId (SpanContext -> TraceId
traceId SpanContext
sc) Bool -> Bool -> Bool
&& SpanId -> Bool
isEmptySpanId (SpanContext -> SpanId
spanId SpanContext
sc))
spanIsRemote :: MonadIO m => Span -> m Bool
spanIsRemote :: Span -> m Bool
spanIsRemote (Span IORef ImmutableSpan
s) = IO Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ do
ImmutableSpan
i <- IORef ImmutableSpan -> IO ImmutableSpan
forall a. IORef a -> IO a
readIORef IORef ImmutableSpan
s
Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ SpanContext -> Bool
Types.isRemote (SpanContext -> Bool) -> SpanContext -> Bool
forall a b. (a -> b) -> a -> b
$ ImmutableSpan -> SpanContext
Types.spanContext ImmutableSpan
i
spanIsRemote (FrozenSpan SpanContext
c) = Bool -> m Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> m Bool) -> Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ SpanContext -> Bool
Types.isRemote SpanContext
c
spanIsRemote (Dropped SpanContext
_) = Bool -> m Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
unsafeReadSpan :: MonadIO m => Span -> m ImmutableSpan
unsafeReadSpan :: Span -> m ImmutableSpan
unsafeReadSpan = \case
Span IORef ImmutableSpan
ref -> IO ImmutableSpan -> m ImmutableSpan
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ImmutableSpan -> m ImmutableSpan)
-> IO ImmutableSpan -> m ImmutableSpan
forall a b. (a -> b) -> a -> b
$ IORef ImmutableSpan -> IO ImmutableSpan
forall a. IORef a -> IO a
readIORef IORef ImmutableSpan
ref
FrozenSpan SpanContext
_s -> [Char] -> m ImmutableSpan
forall a. HasCallStack => [Char] -> a
error [Char]
"This span is from another process"
Dropped SpanContext
_s -> [Char] -> m ImmutableSpan
forall a. HasCallStack => [Char] -> a
error [Char]
"This span was dropped"
wrapSpanContext :: SpanContext -> Span
wrapSpanContext :: SpanContext -> Span
wrapSpanContext = SpanContext -> Span
FrozenSpan
spanGetAttributes :: MonadIO m => Span -> m A.Attributes
spanGetAttributes :: Span -> m Attributes
spanGetAttributes = \case
Span IORef ImmutableSpan
ref -> do
ImmutableSpan
s <- IO ImmutableSpan -> m ImmutableSpan
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ImmutableSpan -> m ImmutableSpan)
-> IO ImmutableSpan -> m ImmutableSpan
forall a b. (a -> b) -> a -> b
$ IORef ImmutableSpan -> IO ImmutableSpan
forall a. IORef a -> IO a
readIORef IORef ImmutableSpan
ref
Attributes -> m Attributes
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Attributes -> m Attributes) -> Attributes -> m Attributes
forall a b. (a -> b) -> a -> b
$ ImmutableSpan -> Attributes
spanAttributes ImmutableSpan
s
FrozenSpan SpanContext
_ -> Attributes -> m Attributes
forall (f :: * -> *) a. Applicative f => a -> f a
pure Attributes
A.emptyAttributes
Dropped SpanContext
_ -> Attributes -> m Attributes
forall (f :: * -> *) a. Applicative f => a -> f a
pure Attributes
A.emptyAttributes
getTimestamp :: MonadIO m => m Timestamp
getTimestamp :: m Timestamp
getTimestamp = IO Timestamp -> m Timestamp
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Timestamp -> m Timestamp) -> IO Timestamp -> m Timestamp
forall a b. (a -> b) -> a -> b
$ Coercible (IO TimeSpec) (IO Timestamp) =>
IO TimeSpec -> IO Timestamp
coerce @(IO TimeSpec) @(IO Timestamp) (IO TimeSpec -> IO Timestamp) -> IO TimeSpec -> IO Timestamp
forall a b. (a -> b) -> a -> b
$ Clock -> IO TimeSpec
getTime Clock
Realtime
limitBy ::
Tracer
-> (SpanLimits -> Maybe Int)
-> AttributeLimits
limitBy :: Tracer -> (SpanLimits -> Maybe Int) -> AttributeLimits
limitBy Tracer
t SpanLimits -> Maybe Int
countF = AttributeLimits :: Maybe Int -> Maybe Int -> AttributeLimits
AttributeLimits
{ attributeCountLimit :: Maybe Int
attributeCountLimit = Maybe Int
countLimit
, attributeLengthLimit :: Maybe Int
attributeLengthLimit = Maybe Int
lengthLimit
}
where
countLimit :: Maybe Int
countLimit =
SpanLimits -> Maybe Int
countF (TracerProvider -> SpanLimits
tracerProviderSpanLimits (TracerProvider -> SpanLimits) -> TracerProvider -> SpanLimits
forall a b. (a -> b) -> a -> b
$ Tracer -> TracerProvider
tracerProvider Tracer
t) Maybe Int -> Maybe Int -> Maybe Int
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
AttributeLimits -> Maybe Int
attributeCountLimit
(TracerProvider -> AttributeLimits
tracerProviderAttributeLimits (TracerProvider -> AttributeLimits)
-> TracerProvider -> AttributeLimits
forall a b. (a -> b) -> a -> b
$ Tracer -> TracerProvider
tracerProvider Tracer
t)
lengthLimit :: Maybe Int
lengthLimit =
SpanLimits -> Maybe Int
spanAttributeValueLengthLimit (TracerProvider -> SpanLimits
tracerProviderSpanLimits (TracerProvider -> SpanLimits) -> TracerProvider -> SpanLimits
forall a b. (a -> b) -> a -> b
$ Tracer -> TracerProvider
tracerProvider Tracer
t) Maybe Int -> Maybe Int -> Maybe Int
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
AttributeLimits -> Maybe Int
attributeLengthLimit
(TracerProvider -> AttributeLimits
tracerProviderAttributeLimits (TracerProvider -> AttributeLimits)
-> TracerProvider -> AttributeLimits
forall a b. (a -> b) -> a -> b
$ Tracer -> TracerProvider
tracerProvider Tracer
t)
globalTracer :: IORef TracerProvider
globalTracer :: IORef TracerProvider
globalTracer = IO (IORef TracerProvider) -> IORef TracerProvider
forall a. IO a -> a
unsafePerformIO (IO (IORef TracerProvider) -> IORef TracerProvider)
-> IO (IORef TracerProvider) -> IORef TracerProvider
forall a b. (a -> b) -> a -> b
$ do
TracerProvider
p <- [Processor] -> TracerProviderOptions -> IO TracerProvider
forall (m :: * -> *).
MonadIO m =>
[Processor] -> TracerProviderOptions -> m TracerProvider
createTracerProvider
[]
TracerProviderOptions
emptyTracerProviderOptions
TracerProvider -> IO (IORef TracerProvider)
forall a. a -> IO (IORef a)
newIORef TracerProvider
p
{-# NOINLINE globalTracer #-}
data TracerProviderOptions = TracerProviderOptions
{ TracerProviderOptions -> IdGenerator
tracerProviderOptionsIdGenerator :: IdGenerator
, TracerProviderOptions -> Sampler
tracerProviderOptionsSampler :: Sampler
, TracerProviderOptions -> MaterializedResources
tracerProviderOptionsResources :: MaterializedResources
, TracerProviderOptions -> AttributeLimits
tracerProviderOptionsAttributeLimits :: AttributeLimits
, TracerProviderOptions -> SpanLimits
tracerProviderOptionsSpanLimits :: SpanLimits
, TracerProviderOptions
-> Propagator Context RequestHeaders RequestHeaders
tracerProviderOptionsPropagators :: Propagator Context RequestHeaders ResponseHeaders
, TracerProviderOptions -> Log Text -> IO ()
tracerProviderOptionsLogger :: Log Text -> IO ()
}
emptyTracerProviderOptions :: TracerProviderOptions
emptyTracerProviderOptions :: TracerProviderOptions
emptyTracerProviderOptions = IdGenerator
-> Sampler
-> MaterializedResources
-> AttributeLimits
-> SpanLimits
-> Propagator Context RequestHeaders RequestHeaders
-> (Log Text -> IO ())
-> TracerProviderOptions
TracerProviderOptions
IdGenerator
dummyIdGenerator
(ParentBasedOptions -> Sampler
parentBased (ParentBasedOptions -> Sampler) -> ParentBasedOptions -> Sampler
forall a b. (a -> b) -> a -> b
$ Sampler -> ParentBasedOptions
parentBasedOptions Sampler
alwaysOn)
MaterializedResources
emptyMaterializedResources
AttributeLimits
defaultAttributeLimits
SpanLimits
defaultSpanLimits
Propagator Context RequestHeaders RequestHeaders
forall a. Monoid a => a
mempty
(\Log Text
_ -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
createTracerProvider :: MonadIO m => [Processor] -> TracerProviderOptions -> m TracerProvider
createTracerProvider :: [Processor] -> TracerProviderOptions -> m TracerProvider
createTracerProvider [Processor]
ps TracerProviderOptions
opts = IO TracerProvider -> m TracerProvider
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO TracerProvider -> m TracerProvider)
-> IO TracerProvider -> m TracerProvider
forall a b. (a -> b) -> a -> b
$ do
let g :: IdGenerator
g = TracerProviderOptions -> IdGenerator
tracerProviderOptionsIdGenerator TracerProviderOptions
opts
TracerProvider -> IO TracerProvider
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TracerProvider -> IO TracerProvider)
-> TracerProvider -> IO TracerProvider
forall a b. (a -> b) -> a -> b
$ Vector Processor
-> IdGenerator
-> Sampler
-> MaterializedResources
-> AttributeLimits
-> SpanLimits
-> Propagator Context RequestHeaders RequestHeaders
-> (Log Text -> IO ())
-> TracerProvider
TracerProvider
([Processor] -> Vector Processor
forall a. [a] -> Vector a
V.fromList [Processor]
ps)
IdGenerator
g
(TracerProviderOptions -> Sampler
tracerProviderOptionsSampler TracerProviderOptions
opts)
(TracerProviderOptions -> MaterializedResources
tracerProviderOptionsResources TracerProviderOptions
opts)
(TracerProviderOptions -> AttributeLimits
tracerProviderOptionsAttributeLimits TracerProviderOptions
opts)
(TracerProviderOptions -> SpanLimits
tracerProviderOptionsSpanLimits TracerProviderOptions
opts)
(TracerProviderOptions
-> Propagator Context RequestHeaders RequestHeaders
tracerProviderOptionsPropagators TracerProviderOptions
opts)
(TracerProviderOptions -> Log Text -> IO ()
tracerProviderOptionsLogger TracerProviderOptions
opts)
getGlobalTracerProvider :: MonadIO m => m TracerProvider
getGlobalTracerProvider :: m TracerProvider
getGlobalTracerProvider = IO TracerProvider -> m TracerProvider
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO TracerProvider -> m TracerProvider)
-> IO TracerProvider -> m TracerProvider
forall a b. (a -> b) -> a -> b
$ IORef TracerProvider -> IO TracerProvider
forall a. IORef a -> IO a
readIORef IORef TracerProvider
globalTracer
setGlobalTracerProvider :: MonadIO m => TracerProvider -> m ()
setGlobalTracerProvider :: TracerProvider -> m ()
setGlobalTracerProvider = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ())
-> (TracerProvider -> IO ()) -> TracerProvider -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IORef TracerProvider -> TracerProvider -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef TracerProvider
globalTracer
getTracerProviderResources :: TracerProvider -> MaterializedResources
getTracerProviderResources :: TracerProvider -> MaterializedResources
getTracerProviderResources = TracerProvider -> MaterializedResources
tracerProviderResources
getTracerProviderPropagators :: TracerProvider -> Propagator Context RequestHeaders ResponseHeaders
getTracerProviderPropagators :: TracerProvider -> Propagator Context RequestHeaders RequestHeaders
getTracerProviderPropagators = TracerProvider -> Propagator Context RequestHeaders RequestHeaders
tracerProviderPropagators
newtype TracerOptions = TracerOptions
{ TracerOptions -> Maybe Text
tracerSchema :: Maybe Text
}
tracerOptions :: TracerOptions
tracerOptions :: TracerOptions
tracerOptions = Maybe Text -> TracerOptions
TracerOptions Maybe Text
forall a. Maybe a
Nothing
class HasTracer s where
tracerL :: Lens' s Tracer
makeTracer :: TracerProvider -> InstrumentationLibrary -> TracerOptions -> Tracer
makeTracer :: TracerProvider -> InstrumentationLibrary -> TracerOptions -> Tracer
makeTracer TracerProvider
tp InstrumentationLibrary
n TracerOptions{} = InstrumentationLibrary -> TracerProvider -> Tracer
Tracer InstrumentationLibrary
n TracerProvider
tp
getTracer :: MonadIO m => TracerProvider -> InstrumentationLibrary -> TracerOptions -> m Tracer
getTracer :: TracerProvider
-> InstrumentationLibrary -> TracerOptions -> m Tracer
getTracer TracerProvider
tp InstrumentationLibrary
n TracerOptions{} = 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
$ do
Tracer -> IO Tracer
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tracer -> IO Tracer) -> Tracer -> IO Tracer
forall a b. (a -> b) -> a -> b
$ InstrumentationLibrary -> TracerProvider -> Tracer
Tracer InstrumentationLibrary
n TracerProvider
tp
{-# DEPRECATED getTracer "use makeTracer" #-}
getImmutableSpanTracer :: ImmutableSpan -> Tracer
getImmutableSpanTracer :: ImmutableSpan -> Tracer
getImmutableSpanTracer = ImmutableSpan -> Tracer
spanTracer
getTracerTracerProvider :: Tracer -> TracerProvider
getTracerTracerProvider :: Tracer -> TracerProvider
getTracerTracerProvider = Tracer -> TracerProvider
tracerProvider
defaultSpanArguments :: SpanArguments
defaultSpanArguments :: SpanArguments
defaultSpanArguments = SpanArguments :: SpanKind
-> [(Text, Attribute)]
-> [NewLink]
-> Maybe Timestamp
-> SpanArguments
SpanArguments
{ kind :: SpanKind
kind = SpanKind
Internal
, attributes :: [(Text, Attribute)]
attributes = []
, links :: [NewLink]
links = []
, startTime :: Maybe Timestamp
startTime = Maybe Timestamp
forall a. Maybe a
Nothing
}
shutdownTracerProvider :: MonadIO m => TracerProvider -> m ()
shutdownTracerProvider :: TracerProvider -> m ()
shutdownTracerProvider TracerProvider{Vector Processor
AttributeLimits
Propagator Context RequestHeaders RequestHeaders
MaterializedResources
IdGenerator
SpanLimits
Sampler
Log Text -> IO ()
tracerProviderLogger :: TracerProvider -> Log Text -> IO ()
tracerProviderLogger :: Log Text -> IO ()
tracerProviderPropagators :: Propagator Context RequestHeaders RequestHeaders
tracerProviderSpanLimits :: SpanLimits
tracerProviderAttributeLimits :: AttributeLimits
tracerProviderResources :: MaterializedResources
tracerProviderSampler :: Sampler
tracerProviderIdGenerator :: IdGenerator
tracerProviderProcessors :: Vector Processor
tracerProviderPropagators :: TracerProvider -> Propagator Context RequestHeaders RequestHeaders
tracerProviderResources :: TracerProvider -> MaterializedResources
tracerProviderAttributeLimits :: TracerProvider -> AttributeLimits
tracerProviderSpanLimits :: TracerProvider -> SpanLimits
tracerProviderSampler :: TracerProvider -> Sampler
tracerProviderProcessors :: TracerProvider -> Vector Processor
tracerProviderIdGenerator :: TracerProvider -> IdGenerator
..} = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
Vector (Async ShutdownResult)
asyncShutdownResults <- Vector Processor
-> (Processor -> IO (Async ShutdownResult))
-> IO (Vector (Async ShutdownResult))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Vector Processor
tracerProviderProcessors ((Processor -> IO (Async ShutdownResult))
-> IO (Vector (Async ShutdownResult)))
-> (Processor -> IO (Async ShutdownResult))
-> IO (Vector (Async ShutdownResult))
forall a b. (a -> b) -> a -> b
$ \Processor
processor -> do
Processor -> IO (Async ShutdownResult)
processorShutdown Processor
processor
(Async ShutdownResult -> IO ShutdownResult)
-> Vector (Async ShutdownResult) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Async ShutdownResult -> IO ShutdownResult
forall a. Async a -> IO a
wait Vector (Async ShutdownResult)
asyncShutdownResults
forceFlushTracerProvider
:: MonadIO m
=> TracerProvider
-> Maybe Int
-> m FlushResult
forceFlushTracerProvider :: TracerProvider -> Maybe Int -> m FlushResult
forceFlushTracerProvider TracerProvider{Vector Processor
AttributeLimits
Propagator Context RequestHeaders RequestHeaders
MaterializedResources
IdGenerator
SpanLimits
Sampler
Log Text -> IO ()
tracerProviderLogger :: Log Text -> IO ()
tracerProviderPropagators :: Propagator Context RequestHeaders RequestHeaders
tracerProviderSpanLimits :: SpanLimits
tracerProviderAttributeLimits :: AttributeLimits
tracerProviderResources :: MaterializedResources
tracerProviderSampler :: Sampler
tracerProviderIdGenerator :: IdGenerator
tracerProviderProcessors :: Vector Processor
tracerProviderLogger :: TracerProvider -> Log Text -> IO ()
tracerProviderPropagators :: TracerProvider -> Propagator Context RequestHeaders RequestHeaders
tracerProviderResources :: TracerProvider -> MaterializedResources
tracerProviderAttributeLimits :: TracerProvider -> AttributeLimits
tracerProviderSpanLimits :: TracerProvider -> SpanLimits
tracerProviderSampler :: TracerProvider -> Sampler
tracerProviderProcessors :: TracerProvider -> Vector Processor
tracerProviderIdGenerator :: TracerProvider -> IdGenerator
..} Maybe Int
mtimeout = IO FlushResult -> m FlushResult
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FlushResult -> m FlushResult)
-> IO FlushResult -> m FlushResult
forall a b. (a -> b) -> a -> b
$ do
Vector (Async ())
jobs <- Vector Processor
-> (Processor -> IO (Async ())) -> IO (Vector (Async ()))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Vector Processor
tracerProviderProcessors ((Processor -> IO (Async ())) -> IO (Vector (Async ())))
-> (Processor -> IO (Async ())) -> IO (Vector (Async ()))
forall a b. (a -> b) -> a -> b
$ \Processor
processor -> IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ do
Processor -> IO ()
processorForceFlush Processor
processor
Maybe FlushResult
mresult <- Int -> IO FlushResult -> IO (Maybe FlushResult)
forall a. Int -> IO a -> IO (Maybe a)
timeout (Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
5_000_000 Maybe Int
mtimeout) (IO FlushResult -> IO (Maybe FlushResult))
-> IO FlushResult -> IO (Maybe FlushResult)
forall a b. (a -> b) -> a -> b
$
(FlushResult -> Async () -> IO FlushResult)
-> FlushResult -> Vector (Async ()) -> IO FlushResult
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM
(\FlushResult
status Async ()
action -> do
Either SomeException ()
res <- Async () -> IO (Either SomeException ())
forall a. Async a -> IO (Either SomeException a)
waitCatch Async ()
action
FlushResult -> IO FlushResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FlushResult -> IO FlushResult) -> FlushResult -> IO FlushResult
forall a b. (a -> b) -> a -> b
$! case Either SomeException ()
res of
Left SomeException
_err -> FlushResult
FlushError
Right ()
_ok -> FlushResult
status
)
FlushResult
FlushSuccess
Vector (Async ())
jobs
case Maybe FlushResult
mresult of
Maybe FlushResult
Nothing -> FlushResult -> IO FlushResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure FlushResult
FlushTimeout
Just FlushResult
res -> FlushResult -> IO FlushResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure FlushResult
res
whenSpanIsRecording :: MonadIO m => Span -> m () -> m ()
whenSpanIsRecording :: Span -> m () -> m ()
whenSpanIsRecording (Span IORef ImmutableSpan
ref) m ()
m = do
ImmutableSpan
span_ <- IO ImmutableSpan -> m ImmutableSpan
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ImmutableSpan -> m ImmutableSpan)
-> IO ImmutableSpan -> m ImmutableSpan
forall a b. (a -> b) -> a -> b
$ IORef ImmutableSpan -> IO ImmutableSpan
forall a. IORef a -> IO a
readIORef IORef ImmutableSpan
ref
case ImmutableSpan -> Maybe Timestamp
spanEnd ImmutableSpan
span_ of
Maybe Timestamp
Nothing -> m ()
m
Just Timestamp
_ -> () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
whenSpanIsRecording (FrozenSpan SpanContext
_) m ()
_ = () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
whenSpanIsRecording (Dropped SpanContext
_) m ()
_ = () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
timestampNanoseconds :: Timestamp -> Word64
timestampNanoseconds :: Timestamp -> Word64
timestampNanoseconds (Timestamp TimeSpec{Int64
sec :: TimeSpec -> Int64
nsec :: TimeSpec -> Int64
nsec :: Int64
sec :: Int64
..}) = Int64 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64
sec Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
* Int64
1_000_000_000) Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Int64 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
nsec