{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

-----------------------------------------------------------------------------

-----------------------------------------------------------------------------

{- |
 Module      :  OpenTelemetry.Trace.Core
 Copyright   :  (c) Ian Duncan, 2021
 License     :  BSD-3
 Description :  Low-level tracing API
 Maintainer  :  Ian Duncan
 Stability   :  experimental
 Portability :  non-portable (GHC extensions)

 Traces track the progression of a single request, called a trace, as it is handled by services that make up an application. The request may be initiated by a user or an application. Distributed tracing is a form of tracing that traverses process, network and security boundaries. Each unit of work in a trace is called a span; a trace is a tree of spans. Spans are objects that represent the work being done by individual services or components involved in a request as it flows through a system. A span contains a span context, which is a set of globally unique identifiers that represent the unique request that each span is a part of. A span provides Request, Error and Duration (RED) metrics that can be used to debug availability as well as performance issues.

 A trace contains a single root span which encapsulates the end-to-end latency for the entire request. You can think of this as a single logical operation, such as clicking a button in a web application to add a product to a shopping cart. The root span would measure the time it took from an end-user clicking that button to the operation being completed or failing (so, the item is added to the cart or some error occurs) and the result being displayed to the user. A trace is comprised of the single root span and any number of child spans, which represent operations taking place as part of the request. Each span contains metadata about the operation, such as its name, start and end timestamps, attributes, events, and status.

 To create and manage 'Span's in OpenTelemetry, the <https://hackage.haskell.org/package/hs-opentelemetry-api OpenTelemetry API> provides the tracer interface. This object is responsible for tracking the active span in your process, and allows you to access the current span in order to perform operations on it such as adding attributes, events, and finishing it when the work it tracks is complete. One or more tracer objects can be created in a process through the tracer provider, a factory interface that allows for multiple 'Tracer's to be instantiated in a single process with different options.

 Generally, the lifecycle of a span resembles the following:

 A request is received by a service. The span context is extracted from the request headers, if it exists.
 A new span is created as a child of the extracted span context; if none exists, a new root span is created.
 The service handles the request. Additional attributes and events are added to the span that are useful for understanding the context of the request, such as the hostname of the machine handling the request, or customer identifiers.
 New spans may be created to represent work being done by sub-components of the service.
 When the service makes a remote call to another service, the current span context is serialized and forwarded to the next service by injecting the span context into the headers or message envelope.
 The work being done by the service completes, successfully or not. The span status is appropriately set, and the span is marked finished.
 For more information, see the traces specification, which covers concepts including: trace, span, parent/child relationship, span context, attributes, events and links.


 This module implements eveything required to conform to the trace & span public interface described
 by the OpenTelemetry specification.

 See OpenTelemetry.Trace.Monad for an implementation that's
 generally easier to use in idiomatic Haskell.
-}
module OpenTelemetry.Trace.Core (
  -- * @TracerProvider@ operations
  TracerProvider,
  createTracerProvider,
  shutdownTracerProvider,
  forceFlushTracerProvider,
  FlushResult (..),
  getTracerProviderResources,
  getTracerProviderPropagators,
  getGlobalTracerProvider,
  setGlobalTracerProvider,
  emptyTracerProviderOptions,
  TracerProviderOptions (..),

  -- * @Tracer@ operations
  Tracer,
  tracerName,
  HasTracer (..),
  makeTracer,
  getTracer,
  getImmutableSpanTracer,
  getTracerTracerProvider,
  InstrumentationLibrary (..),
  detectInstrumentationLibrary,
  TracerOptions (..),
  tracerOptions,

  -- * Span operations
  Span,
  ImmutableSpan (..),
  SpanContext (..),
  -- | W3c Trace flags
  --
  -- https://www.w3.org/TR/trace-context/#trace-flags
  TraceFlags,
  traceFlagsValue,
  traceFlagsFromWord8,
  defaultTraceFlags,
  isSampled,
  setSampled,
  unsetSampled,

  -- ** Creating @Span@s
  inSpan,
  inSpan',
  inSpan'',
  createSpan,
  createSpanWithoutCallStack,
  wrapSpanContext,
  SpanKind (..),
  defaultSpanArguments,
  SpanArguments (..),

  -- ** Recording @Event@s
  Event (..),
  NewEvent (..),
  addEvent,

  -- ** Enriching @Span@s with additional information
  updateName,
  OpenTelemetry.Trace.Core.addAttribute,
  OpenTelemetry.Trace.Core.addAttributes,
  spanGetAttributes,
  Attribute (..),
  ToAttribute (..),
  PrimitiveAttribute (..),
  ToPrimitiveAttribute (..),
  Link (..),
  NewLink (..),
  addLink,

  -- ** Recording error information
  recordException,
  setStatus,
  SpanStatus (..),

  -- ** Completing @Span@s
  endSpan,

  -- ** Accessing other @Span@ information
  getSpanContext,
  isRecording,
  isValid,
  spanIsRemote,

  -- * Utilities
  Timestamp,
  getTimestamp,
  timestampNanoseconds,
  unsafeReadSpan,
  whenSpanIsRecording,
  ownCodeAttributes,
  callerAttributes,
  addAttributesToSpanArguments,

  -- * Limits
  SpanLimits (..),
  defaultSpanLimits,
  bracketError,
) where

import Control.Applicative
import Control.Concurrent (myThreadId)
import Control.Concurrent.Async
import Control.Exception (Exception (..), SomeException (..), try)
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.IO.Unlift
import Data.Coerce
import qualified Data.HashMap.Strict as H
import Data.IORef
import Data.Maybe (fromMaybe, isJust, isNothing)
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.Common
import OpenTelemetry.Context
import OpenTelemetry.Context.ThreadLocal
import OpenTelemetry.Internal.Common.Types
import OpenTelemetry.Internal.Logs.Core (emitOTelLogRecord, logDroppedAttributes)
import qualified OpenTelemetry.Internal.Logs.Types as SeverityNumber (SeverityNumber (..))
import OpenTelemetry.Internal.Trace.Types
import qualified OpenTelemetry.Internal.Trace.Types as Types
import OpenTelemetry.Propagator (Propagator)
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)


{- | Create a 'Span'.

 If the provided 'Context' has a span in it (inserted via 'OpenTelemetry.Context.insertSpan'),
 that 'Span' will be used as the parent of the 'Span' created via this API.

 Note: if the @hs-opentelemetry-sdk@ or another SDK is not installed, all actions that use the created
 'Span's produced will be no-ops.

 @since 0.0.1.0
-}
createSpan
  :: (MonadIO m, HasCallStack)
  => Tracer
  -- ^ 'Tracer' to create the span from. Associated 'Processor's and 'Exporter's will be
  -- used for the lifecycle of the created 'Span'
  -> Context
  -- ^ Context, potentially containing a parent span. If no existing parent (or context) exists,
  -- you can use 'OpenTelemetry.Context.empty'.
  -> Text
  -- ^ Span name
  -> SpanArguments
  -- ^ Additional span information
  -> m Span
  -- ^ The created span.
createSpan :: forall (m :: * -> *).
(MonadIO m, HasCallStack) =>
Tracer -> Context -> Text -> SpanArguments -> m Span
createSpan Tracer
t Context
ctxt Text
n SpanArguments
args = Tracer -> Context -> Text -> SpanArguments -> m Span
forall (m :: * -> *).
MonadIO m =>
Tracer -> Context -> Text -> SpanArguments -> m Span
createSpanWithoutCallStack Tracer
t Context
ctxt Text
n (SpanArguments
args {attributes = H.union (attributes args) callerAttributes})


-- | The same thing as 'createSpan', except that it does not have a 'HasCallStack' constraint.
createSpanWithoutCallStack
  :: (MonadIO m)
  => Tracer
  -- ^ 'Tracer' to create the span from. Associated 'Processor's and 'Exporter's will be
  -- used for the lifecycle of the created 'Span'
  -> Context
  -- ^ Context, potentially containing a parent span. If no existing parent (or context) exists,
  -- you can use 'OpenTelemetry.Context.empty'.
  -> Text
  -- ^ Span name
  -> SpanArguments
  -- ^ Additional span information
  -> m Span
  -- ^ The created span.
createSpanWithoutCallStack :: forall (m :: * -> *).
MonadIO m =>
Tracer -> Context -> Text -> SpanArguments -> m Span
createSpanWithoutCallStack Tracer
t Context
ctxt Text
n args :: SpanArguments
args@SpanArguments {[NewLink]
Maybe Timestamp
HashMap Text Attribute
SpanKind
attributes :: SpanArguments -> HashMap Text Attribute
kind :: SpanKind
attributes :: HashMap Text Attribute
links :: [NewLink]
startTime :: Maybe Timestamp
kind :: SpanArguments -> SpanKind
links :: SpanArguments -> [NewLink]
startTime :: SpanArguments -> Maybe Timestamp
..} = IO Span -> m Span
forall a. IO a -> m a
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 a. a -> IO a
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 a. a -> IO a
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 SpanProcessor -> Bool
forall a. Vector a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Vector SpanProcessor -> Bool) -> Vector SpanProcessor -> Bool
forall a b. (a -> b) -> a -> b
$ TracerProvider -> Vector SpanProcessor
tracerProviderProcessors (TracerProvider -> Vector SpanProcessor)
-> TracerProvider -> Vector SpanProcessor
forall a b. (a -> b) -> a -> b
$ Tracer -> TracerProvider
tracerProvider Tracer
t
    then Span -> IO Span
forall a. a -> IO a
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, HashMap Text Attribute
attrs, TraceState
samplingTraceState) <- case Maybe Span
parent of
        -- TODO, this seems logically like what we'd do here
        Just (Dropped SpanContext
_) -> (SamplingResult, HashMap Text Attribute, TraceState)
-> IO (SamplingResult, HashMap Text Attribute, TraceState)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SamplingResult
Drop, [], TraceState
TraceState.empty)
        Maybe Span
_ ->
          Sampler
-> Context
-> TraceId
-> Text
-> SpanArguments
-> IO (SamplingResult, HashMap 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

      -- TODO properly populate
      let ctxtForSpan :: SpanContext
ctxtForSpan =
            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 a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Timestamp
startTime
            ThreadId
tid <- IO ThreadId
myThreadId
            let additionalInfo :: HashMap 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
                    { 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 -> HashMap Text Attribute -> Attributes
forall a.
ToAttribute a =>
AttributeLimits -> Attributes -> HashMap Text a -> Attributes
A.addAttributes
                          (Tracer -> (SpanLimits -> Maybe Int) -> AttributeLimits
limitBy Tracer
t SpanLimits -> Maybe Int
spanAttributeCountLimit)
                          Attributes
emptyAttributes
                          ([HashMap Text Attribute] -> HashMap Text Attribute
forall k v. Eq k => [HashMap k v] -> HashMap k v
H.unions [Item [HashMap Text Attribute]
HashMap Text Attribute
additionalInfo, Item [HashMap Text Attribute]
HashMap Text Attribute
attrs, Item [HashMap Text Attribute]
HashMap Text Attribute
attributes])
                    , spanLinks :: AppendOnlyBoundedCollection Link
spanLinks =
                        let emptyLinks :: AppendOnlyBoundedCollection Link
emptyLinks = Int -> AppendOnlyBoundedCollection Link
forall a. Int -> AppendOnlyBoundedCollection a
emptyAppendOnlyBoundedCollection (Int -> AppendOnlyBoundedCollection Link)
-> Int -> AppendOnlyBoundedCollection Link
forall a b. (a -> b) -> a -> b
$ 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 (AppendOnlyBoundedCollection Link
 -> Link -> AppendOnlyBoundedCollection Link)
-> AppendOnlyBoundedCollection Link
-> [Link]
-> AppendOnlyBoundedCollection Link
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\AppendOnlyBoundedCollection Link
c Link
l -> AppendOnlyBoundedCollection Link
-> Link -> AppendOnlyBoundedCollection Link
forall a.
AppendOnlyBoundedCollection a -> a -> AppendOnlyBoundedCollection a
appendToBoundedCollection AppendOnlyBoundedCollection Link
c Link
l) AppendOnlyBoundedCollection Link
emptyLinks ((NewLink -> Link) -> [NewLink] -> [Link]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Tracer -> NewLink -> Link
freezeLink Tracer
t) [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
                    }

            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Attributes -> Int
A.attributesDropped (ImmutableSpan -> Attributes
spanAttributes ImmutableSpan
is) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO ReadWriteLogRecord -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void IO ReadWriteLogRecord
forall (m :: * -> *). MonadIO m => m ReadWriteLogRecord
logDroppedAttributes

            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
$ (SpanProcessor -> IO ()) -> Vector SpanProcessor -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\SpanProcessor
processor -> SpanProcessor -> IORef ImmutableSpan -> Context -> IO ()
spanProcessorOnStart SpanProcessor
processor IORef ImmutableSpan
s Context
ctxt) (Vector SpanProcessor -> IO ()) -> Vector SpanProcessor -> IO ()
forall a b. (a -> b) -> a -> b
$ TracerProvider -> Vector SpanProcessor
tracerProviderProcessors (TracerProvider -> Vector SpanProcessor)
-> TracerProvider -> Vector SpanProcessor
forall a b. (a -> b) -> a -> b
$ Tracer -> TracerProvider
tracerProvider Tracer
t
            case Either SomeException ()
eResult of
              Left SomeException
err -> IO ReadWriteLogRecord -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ReadWriteLogRecord -> IO ()) -> IO ReadWriteLogRecord -> IO ()
forall a b. (a -> b) -> a -> b
$ HashMap Text AnyValue
-> SeverityNumber -> Text -> IO ReadWriteLogRecord
forall (m :: * -> *).
MonadIO m =>
HashMap Text AnyValue
-> SeverityNumber -> Text -> m ReadWriteLogRecord
emitOTelLogRecord HashMap Text AnyValue
forall k v. HashMap k v
H.empty SeverityNumber
SeverityNumber.Error (Text -> IO ReadWriteLogRecord) -> Text -> IO ReadWriteLogRecord
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall a. Show a => a -> String
show (SomeException
err :: SomeException)
              Right ()
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            Span -> IO Span
forall a. a -> IO a
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 a. a -> IO a
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


ownCodeAttributes :: (HasCallStack) => H.HashMap Text Attribute
ownCodeAttributes :: HasCallStack => HashMap Text Attribute
ownCodeAttributes = case CallStack -> [(String, SrcLoc)]
getCallStack CallStack
HasCallStack => CallStack
callStack of
  -- The call stack is (probably) not frozen and the top entry is our call. Assume we have a full call stack
  -- and look one further step up for our own code.
  ((String
"ownCodeAttributes", SrcLoc
_) : (String, SrcLoc)
ownCode : [(String, SrcLoc)]
_) -> (String, SrcLoc) -> HashMap Text Attribute
srcAttributes (String, SrcLoc)
ownCode
  -- The call stack doesn't look like we expect, potentially frozen or empty. In this case we can't
  -- really do much, so give up.
  [(String, SrcLoc)]
_ -> HashMap Text Attribute
forall a. Monoid a => a
mempty


callerAttributes :: (HasCallStack) => H.HashMap Text Attribute
callerAttributes :: HasCallStack => HashMap Text Attribute
callerAttributes = case CallStack -> [(String, SrcLoc)]
getCallStack CallStack
HasCallStack => CallStack
callStack of
  -- The call stack is (probably) not frozen and the top entry is our call. Assume we have a full call stack
  -- and look two further steps up for the caller.
  ((String
"callerAttributes", SrcLoc
_) : (String, SrcLoc)
_ : (String, SrcLoc)
caller : [(String, SrcLoc)]
_) -> (String, SrcLoc) -> HashMap Text Attribute
srcAttributes (String, SrcLoc)
caller
  -- The call stack doesn't look like we expect. Guess that it got frozen, and so the most
  -- useful thing to do is to assume that the "caller" is the top of the frozen call stack
  ((String, SrcLoc)
caller : [(String, SrcLoc)]
_) -> (String, SrcLoc) -> HashMap Text Attribute
srcAttributes (String, SrcLoc)
caller
  -- Empty call stack
  [(String, SrcLoc)]
_ -> HashMap Text Attribute
forall a. Monoid a => a
mempty


srcAttributes :: (String, SrcLoc) -> H.HashMap Text Attribute
srcAttributes :: (String, SrcLoc) -> HashMap Text Attribute
srcAttributes (String
fn, SrcLoc
loc) =
  [(Text, Attribute)] -> HashMap Text Attribute
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
H.fromList
    [ (Text
"code.function", Text -> Attribute
forall a. ToAttribute a => a -> Attribute
toAttribute (Text -> Attribute) -> Text -> Attribute
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
fn)
    , (Text
"code.namespace", Text -> Attribute
forall a. ToAttribute a => a -> Attribute
toAttribute (Text -> Attribute) -> Text -> Attribute
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ SrcLoc -> String
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
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ SrcLoc -> String
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
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ SrcLoc -> String
srcLocPackage SrcLoc
loc)
    ]


{- | Attributes are added to the end of the span argument list, so will be discarded
 if the number of attributes in the span exceeds the limit.
-}
addAttributesToSpanArguments :: H.HashMap Text Attribute -> SpanArguments -> SpanArguments
addAttributesToSpanArguments :: HashMap Text Attribute -> SpanArguments -> SpanArguments
addAttributesToSpanArguments HashMap Text Attribute
attrs SpanArguments
args = SpanArguments
args {attributes = H.union (attributes args) attrs}


{- | The simplest function for annotating code with trace information.

 @since 0.0.1.0
-}
inSpan
  :: (MonadUnliftIO m, HasCallStack)
  => Tracer
  -> Text
  -- ^ The name of the span. This may be updated later via 'updateName'
  -> SpanArguments
  -- ^ Additional options for creating the span, such as 'SpanKind',
  -- span links, starting attributes, etc.
  -> m a
  -- ^ The action to perform. 'inSpan' will record the time spent on the
  -- action without forcing strict evaluation of the result. Any uncaught
  -- exceptions will be recorded and rethrown.
  -> m a
inSpan :: forall (m :: * -> *) a.
(MonadUnliftIO m, HasCallStack) =>
Tracer -> Text -> SpanArguments -> m a -> m a
inSpan Tracer
t Text
n SpanArguments
args m a
m = Tracer -> Text -> SpanArguments -> (Span -> m a) -> m a
forall (m :: * -> *) a.
(MonadUnliftIO m, HasCallStack) =>
Tracer -> Text -> SpanArguments -> (Span -> m a) -> m a
inSpan'' Tracer
t Text
n (SpanArguments
args {attributes = H.union (attributes args) callerAttributes}) (m a -> Span -> m a
forall a b. a -> b -> a
const m a
m)


inSpan'
  :: (MonadUnliftIO m, HasCallStack)
  => Tracer
  -> Text
  -- ^ The name of the span. This may be updated later via 'updateName'
  -> SpanArguments
  -> (Span -> m a)
  -> m a
inSpan' :: forall (m :: * -> *) a.
(MonadUnliftIO m, HasCallStack) =>
Tracer -> Text -> SpanArguments -> (Span -> m a) -> m a
inSpan' Tracer
t Text
n SpanArguments
args = Tracer -> Text -> SpanArguments -> (Span -> m a) -> m a
forall (m :: * -> *) a.
(MonadUnliftIO m, HasCallStack) =>
Tracer -> Text -> SpanArguments -> (Span -> m a) -> m a
inSpan'' Tracer
t Text
n (SpanArguments
args {attributes = H.union (attributes args) callerAttributes})


inSpan''
  :: (MonadUnliftIO m, HasCallStack)
  => Tracer
  -> Text
  -- ^ The name of the span. This may be updated later via 'updateName'
  -> SpanArguments
  -> (Span -> m a)
  -> m a
inSpan'' :: forall (m :: * -> *) a.
(MonadUnliftIO m, HasCallStack) =>
Tracer -> Text -> SpanArguments -> (Span -> m a) -> m a
inSpan'' Tracer
t 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 a. IO a -> m a
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)
        (Maybe Span, Span) -> IO (Maybe Span, Span)
forall a. a -> IO a
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 a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
        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
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ e -> String
forall e. Exception e => e -> String
displayException e
inner
          Span -> HashMap Text Attribute -> Maybe Timestamp -> e -> IO ()
forall (m :: * -> *) e.
(MonadIO m, Exception e) =>
Span -> HashMap Text Attribute -> Maybe Timestamp -> e -> m ()
recordException Span
s [(Text
"exception.escaped", Bool -> Attribute
forall a. ToAttribute a => a -> Attribute
toAttribute Bool
True)] 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 -> Context
removeSpan Context
ctx) (Span -> Context -> Context
`insertSpan` Context
ctx) Maybe Span
parent
    )
    (\(Maybe Span
_, Span
s) -> Span -> m a
f Span
s)


{- | Returns whether the the @Span@ is currently recording. If a span
 is dropped, this will always return False. If a span is from an
 external process, this will return True, and if the span was
 created by this process, the span will return True until endSpan
 is called.
-}
isRecording :: (MonadIO m) => Span -> m Bool
isRecording :: forall (m :: * -> *). MonadIO m => Span -> m Bool
isRecording (Span IORef ImmutableSpan
s) = IO Bool -> m Bool
forall a. IO a -> m a
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 a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
isRecording (Dropped SpanContext
_) = Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False


{- | Add an attribute to a span. Only has a useful effect on recording spans.

As an application developer when you need to record an attribute first consult existing semantic conventions for Resources, Spans, and Metrics. If an appropriate name does not exists you will need to come up with a new name. To do that consider a few options:

The name is specific to your company and may be possibly used outside the company as well. To avoid clashes with names introduced by other companies (in a distributed system that uses applications from multiple vendors) it is recommended to prefix the new name by your company’s reverse domain name, e.g. 'com.acme.shopname'.

The name is specific to your application that will be used internally only. If you already have an internal company process that helps you to ensure no name clashes happen then feel free to follow it. Otherwise it is recommended to prefix the attribute name by your application name, provided that the application name is reasonably unique within your organization (e.g. 'myuniquemapapp.longitude' is likely fine). Make sure the application name does not clash with an existing semantic convention namespace.

The name may be generally applicable to applications in the industry. In that case consider submitting a proposal to this specification to add a new name to the semantic conventions, and if necessary also to add a new namespace.

It is recommended to limit names to printable Basic Latin characters (more precisely to 'U+0021' .. 'U+007E' subset of Unicode code points), although the Haskell OpenTelemetry specification DOES provide full Unicode support.

Attribute names that start with 'otel.' are reserved to be defined by OpenTelemetry specification. These are typically used to express OpenTelemetry concepts in formats that don’t have a corresponding concept.

For example, the 'otel.library.name' attribute is used to record the instrumentation library name, which is an OpenTelemetry concept that is natively represented in OTLP, but does not have an equivalent in other telemetry formats and protocols.

Any additions to the 'otel.*' namespace MUST be approved as part of OpenTelemetry specification.

@since 0.0.1.0
-}
addAttribute
  :: (MonadIO m, A.ToAttribute a)
  => Span
  -- ^ Span to add the attribute to
  -> Text
  -- ^ Attribute name
  -> a
  -- ^ Attribute value
  -> m ()
addAttribute :: forall (m :: * -> *) a.
(MonadIO m, ToAttribute a) =>
Span -> Text -> a -> m ()
addAttribute (Span IORef ImmutableSpan
s) Text
k a
v = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ 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 =
        OpenTelemetry.Attributes.addAttribute
          (limitBy (spanTracer i) spanAttributeCountLimit)
          (spanAttributes i)
          k
          v
    }
addAttribute (FrozenSpan SpanContext
_) Text
_ a
_ = () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
addAttribute (Dropped SpanContext
_) Text
_ a
_ = () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()


{- | A convenience function related to 'addAttribute' that adds multiple attributes to a span at the same time.

 This function may be slightly more performant than repeatedly calling 'addAttribute'.

 @since 0.0.1.0
-}
addAttributes :: (MonadIO m) => Span -> H.HashMap Text A.Attribute -> m ()
addAttributes :: forall (m :: * -> *).
MonadIO m =>
Span -> HashMap Text Attribute -> m ()
addAttributes (Span IORef ImmutableSpan
s) HashMap Text Attribute
attrs = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ 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 =
        OpenTelemetry.Attributes.addAttributes
          (limitBy (spanTracer i) spanAttributeCountLimit)
          (spanAttributes i)
          attrs
    }
addAttributes (FrozenSpan SpanContext
_) HashMap Text Attribute
_ = () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
addAttributes (Dropped SpanContext
_) HashMap Text Attribute
_ = () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()


{- | Add an event to a recording span. Events will not be recorded for remote spans and dropped spans.

 @since 0.0.1.0
-}
addEvent :: (MonadIO m) => Span -> NewEvent -> m ()
addEvent :: forall (m :: * -> *). MonadIO m => Span -> NewEvent -> m ()
addEvent (Span IORef ImmutableSpan
s) NewEvent {Maybe Timestamp
Text
HashMap Text Attribute
newEventName :: Text
newEventAttributes :: HashMap Text Attribute
newEventTimestamp :: Maybe Timestamp
newEventName :: NewEvent -> Text
newEventAttributes :: NewEvent -> HashMap Text Attribute
newEventTimestamp :: NewEvent -> Maybe Timestamp
..} = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
  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 a. a -> IO a
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 =
          appendToBoundedCollection (spanEvents i) $
            Event
              { eventName = newEventName
              , eventAttributes =
                  A.addAttributes
                    (limitBy (spanTracer i) eventAttributeCountLimit)
                    emptyAttributes
                    newEventAttributes
              , eventTimestamp = t
              }
      }
addEvent (FrozenSpan SpanContext
_) NewEvent
_ = () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
addEvent (Dropped SpanContext
_) NewEvent
_ = () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()


-- | Add a link to a recording span.
addLink :: (MonadIO m) => Span -> NewLink -> m ()
addLink :: forall (m :: * -> *). MonadIO m => Span -> NewLink -> m ()
addLink (Span IORef ImmutableSpan
s) NewLink
l = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
  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 {spanLinks = appendToBoundedCollection (spanLinks i) (freezeLink (spanTracer i) l)}
addLink (FrozenSpan SpanContext
_) NewLink
_ = () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
addLink (Dropped SpanContext
_) NewLink
_ = () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()


freezeLink :: Tracer -> NewLink -> Link
freezeLink :: Tracer -> NewLink -> Link
freezeLink Tracer
t NewLink {HashMap Text Attribute
SpanContext
linkContext :: SpanContext
linkAttributes :: HashMap Text Attribute
linkContext :: NewLink -> SpanContext
linkAttributes :: NewLink -> HashMap Text Attribute
..} =
  Link
    { frozenLinkContext :: SpanContext
frozenLinkContext = SpanContext
linkContext
    , frozenLinkAttributes :: Attributes
frozenLinkAttributes = AttributeLimits
-> Attributes -> HashMap Text Attribute -> Attributes
forall a.
ToAttribute a =>
AttributeLimits -> Attributes -> HashMap Text a -> Attributes
A.addAttributes (Tracer -> (SpanLimits -> Maybe Int) -> AttributeLimits
limitBy Tracer
t SpanLimits -> Maybe Int
linkAttributeCountLimit) Attributes
A.emptyAttributes HashMap Text Attribute
linkAttributes
    }


{- | Sets the Status of the Span. If used, this will override the default @Span@ status, which is @Unset@.

 These values form a total order: Ok > Error > Unset. This means that setting Status with StatusCode=Ok will override any prior or future attempts to set span Status with StatusCode=Error or StatusCode=Unset.

 @since 0.0.1.0
-}
setStatus :: (MonadIO m) => Span -> SpanStatus -> m ()
setStatus :: forall (m :: * -> *). MonadIO m => Span -> SpanStatus -> m ()
setStatus (Span IORef ImmutableSpan
s) SpanStatus
st = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ 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 = max st (spanStatus i)
    }
setStatus (FrozenSpan SpanContext
_) SpanStatus
_ = () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
setStatus (Dropped SpanContext
_) SpanStatus
_ = () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()


alterFlags :: (MonadIO m) => Span -> (TraceFlags -> TraceFlags) -> m ()
alterFlags :: forall (m :: * -> *).
MonadIO m =>
Span -> (TraceFlags -> TraceFlags) -> m ()
alterFlags (Span IORef ImmutableSpan
s) TraceFlags -> TraceFlags
f = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ 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
    { spanContext =
        (spanContext i)
          { traceFlags = f $ traceFlags $ spanContext i
          }
    }
alterFlags (FrozenSpan SpanContext
_) TraceFlags -> TraceFlags
_ = () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
alterFlags (Dropped SpanContext
_) TraceFlags -> TraceFlags
_ = () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()


{- |
Updates the Span name. Upon this update, any sampling behavior based on Span name will depend on the implementation.

Note that @Sampler@s can only consider information already present during span creation. Any changes done later, including updated span name, cannot change their decisions.

Alternatives for the name update may be late Span creation, when Span is started with the explicit timestamp from the past at the moment where the final Span name is known, or reporting a Span with the desired name as a child Span.

@since 0.0.1.0
-}
updateName
  :: (MonadIO m)
  => Span
  -> Text
  -- ^ The new span name, which supersedes whatever was passed in when the Span was started
  -> m ()
updateName :: forall (m :: * -> *). MonadIO m => Span -> Text -> m ()
updateName (Span IORef ImmutableSpan
s) Text
n = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ 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 = n}
updateName (FrozenSpan SpanContext
_) Text
_ = () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
updateName (Dropped SpanContext
_) Text
_ = () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()


{- |
Signals that the operation described by this span has now (or at the time optionally specified) ended.

This does have any effects on child spans. Those may still be running and can be ended later.

This also does not inactivate the Span in any Context it is active in. It is still possible to use an ended span as
parent via a Context it is contained in. Also, putting the Span into a Context will still work after the Span was ended.

@since 0.0.1.0
-}
endSpan
  :: (MonadIO m)
  => Span
  -> Maybe Timestamp
  -- ^ Optional @Timestamp@ signalling the end time of the span. If not provided, the current time will be used.
  -> m ()
endSpan :: forall (m :: * -> *). MonadIO m => Span -> Maybe Timestamp -> m ()
endSpan (Span IORef ImmutableSpan
s) Maybe Timestamp
mts = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
  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 a. a -> IO a
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 = spanEnd i <|> Just 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
$ (SpanProcessor -> IO ()) -> Vector SpanProcessor -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (SpanProcessor -> IORef ImmutableSpan -> IO ()
`spanProcessorOnEnd` IORef ImmutableSpan
s) (Vector SpanProcessor -> IO ()) -> Vector SpanProcessor -> IO ()
forall a b. (a -> b) -> a -> b
$ TracerProvider -> Vector SpanProcessor
tracerProviderProcessors (TracerProvider -> Vector SpanProcessor)
-> TracerProvider -> Vector SpanProcessor
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 a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
endSpan (FrozenSpan SpanContext
_) Maybe Timestamp
_ = () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
endSpan (Dropped SpanContext
_) Maybe Timestamp
_ = () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()


{- | A specialized variant of @addEvent@ that records attributes conforming to
 the OpenTelemetry specification's
 <https://github.com/open-telemetry/opentelemetry-specification/blob/49c2f56f3c0468ceb2b69518bcadadd96e0a5a8b/specification/trace/semantic_conventions/exceptions.md semantic conventions>

 @since 0.0.1.0
-}
recordException :: (MonadIO m, Exception e) => Span -> H.HashMap Text Attribute -> Maybe Timestamp -> e -> m ()
recordException :: forall (m :: * -> *) e.
(MonadIO m, Exception e) =>
Span -> HashMap Text Attribute -> Maybe Timestamp -> e -> m ()
recordException Span
s HashMap Text Attribute
attrs Maybe Timestamp
ts e
e = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
  [String]
cs <- e -> IO [String]
forall a. a -> IO [String]
whoCreated e
e
  let message :: Text
message = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ e -> String
forall a. Show a => a -> String
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
      { newEventName :: Text
newEventName = Text
"exception"
      , newEventAttributes :: HashMap Text Attribute
newEventAttributes =
          HashMap Text Attribute
-> HashMap Text Attribute -> HashMap Text Attribute
forall k v. Eq k => HashMap k v -> HashMap k v -> HashMap k v
H.union
            HashMap Text Attribute
attrs
            [ (Text
"exception.type", Text -> Attribute
forall a. ToAttribute a => a -> Attribute
A.toAttribute (Text -> Attribute) -> Text -> Attribute
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ TypeRep -> String
forall a. Show a => a -> String
show (TypeRep -> String) -> TypeRep -> String
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
$ (String -> Text) -> [String] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map String -> Text
T.pack [String]
cs)
            ]
      , newEventTimestamp :: Maybe Timestamp
newEventTimestamp = Maybe Timestamp
ts
      }


-- | Returns @True@ if the @SpanContext@ has a non-zero @TraceID@ and a non-zero @SpanID@
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))


{- |
Returns @True@ if the @SpanContext@ was propagated from a remote parent,

When extracting a SpanContext through the Propagators API, isRemote MUST return @True@,
whereas for the SpanContext of any child spans it MUST return @False@.
-}
spanIsRemote :: (MonadIO m) => Span -> m Bool
spanIsRemote :: forall (m :: * -> *). MonadIO m => Span -> m Bool
spanIsRemote (Span IORef ImmutableSpan
s) = IO Bool -> m Bool
forall a. IO a -> m a
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 a. a -> IO a
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 a. a -> m a
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 a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False


{- | Really only intended for tests, this function does not conform
 to semantic versioning .
-}
unsafeReadSpan :: (MonadIO m) => Span -> m ImmutableSpan
unsafeReadSpan :: forall (m :: * -> *). MonadIO m => Span -> m ImmutableSpan
unsafeReadSpan = \case
  Span IORef ImmutableSpan
ref -> IO ImmutableSpan -> m ImmutableSpan
forall a. IO a -> m a
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 -> String -> m ImmutableSpan
forall a. HasCallStack => String -> a
error String
"This span is from another process"
  Dropped SpanContext
_s -> String -> m ImmutableSpan
forall a. HasCallStack => String -> a
error String
"This span was dropped"


wrapSpanContext :: SpanContext -> Span
wrapSpanContext :: SpanContext -> Span
wrapSpanContext = SpanContext -> Span
FrozenSpan


{- | This can be useful for pulling data for attributes and
 using it to copy / otherwise use the data to further enrich
 instrumentation.
-}
spanGetAttributes :: (MonadIO m) => Span -> m A.Attributes
spanGetAttributes :: forall (m :: * -> *). MonadIO m => Span -> m Attributes
spanGetAttributes = \case
  Span IORef ImmutableSpan
ref -> do
    ImmutableSpan
s <- IO ImmutableSpan -> m ImmutableSpan
forall a. IO a -> m a
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 a. a -> m a
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 a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Attributes
A.emptyAttributes
  Dropped SpanContext
_ -> Attributes -> m Attributes
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Attributes
A.emptyAttributes


{- | Sometimes, you may have a more accurate notion of when a traced
 operation has ended. In this case you may call 'getTimestamp', and then
 supply 'endSpan' with the more accurate timestamp you have acquired.

 When using the monadic interface, (such as 'OpenTelemetry.Trace.Monad.inSpan', you may call
 'endSpan' early to record the information, and the first call to 'endSpan' will be honored.

 @since 0.0.1.0
-}
getTimestamp :: (MonadIO m) => m Timestamp
getTimestamp :: forall (m :: * -> *). MonadIO m => m Timestamp
getTimestamp = IO Timestamp -> m Timestamp
forall a. IO a -> m a
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
$ forall a b. Coercible a b => a -> b
forall a b. Coercible a b => a -> b
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)
  -- ^ Attribute count
  -> AttributeLimits
limitBy :: Tracer -> (SpanLimits -> Maybe Int) -> AttributeLimits
limitBy Tracer
t SpanLimits -> Maybe Int
countF =
  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 a. Maybe a -> Maybe a -> Maybe a
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 a. Maybe a -> Maybe a -> Maybe a
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 <-
    [SpanProcessor] -> TracerProviderOptions -> IO TracerProvider
forall (m :: * -> *).
MonadIO m =>
[SpanProcessor] -> 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
  }


{- | Options for creating a 'TracerProvider' with invalid ids, no resources, default limits, and no propagators.

 In effect, tracing is a no-op when using this configuration.

 @since 0.0.1.0
-}
emptyTracerProviderOptions :: TracerProviderOptions
emptyTracerProviderOptions :: TracerProviderOptions
emptyTracerProviderOptions =
  IdGenerator
-> Sampler
-> MaterializedResources
-> AttributeLimits
-> SpanLimits
-> Propagator Context RequestHeaders RequestHeaders
-> 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


{- | Initialize a new tracer provider

 You should generally use 'getGlobalTracerProvider' for most applications.
-}
createTracerProvider :: (MonadIO m) => [SpanProcessor] -> TracerProviderOptions -> m TracerProvider
createTracerProvider :: forall (m :: * -> *).
MonadIO m =>
[SpanProcessor] -> TracerProviderOptions -> m TracerProvider
createTracerProvider [SpanProcessor]
ps TracerProviderOptions
opts = IO TracerProvider -> m TracerProvider
forall a. IO a -> m a
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 a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TracerProvider -> IO TracerProvider)
-> TracerProvider -> IO TracerProvider
forall a b. (a -> b) -> a -> b
$
    Vector SpanProcessor
-> IdGenerator
-> Sampler
-> MaterializedResources
-> AttributeLimits
-> SpanLimits
-> Propagator Context RequestHeaders RequestHeaders
-> TracerProvider
TracerProvider
      ([SpanProcessor] -> Vector SpanProcessor
forall a. [a] -> Vector a
V.fromList [SpanProcessor]
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)


{- | Access the globally configured 'TracerProvider'. Once the
 the global tracer provider is initialized via the OpenTelemetry SDK,
 'Tracer's created from this 'TracerProvider' will export spans to their
 configured exporters. Prior to that, any 'Tracer's acquired from the
 uninitialized 'TracerProvider' will create no-op spans.

 @since 0.0.1.0
-}
getGlobalTracerProvider :: (MonadIO m) => m TracerProvider
getGlobalTracerProvider :: forall (m :: * -> *). MonadIO m => m TracerProvider
getGlobalTracerProvider = IO TracerProvider -> m TracerProvider
forall a. IO a -> m a
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


{- | Overwrite the globally configured 'TracerProvider'.

 'Tracer's acquired from the previously installed 'TracerProvider'
 will continue to use that 'TracerProvider's configured span processors,
 exporters, and other settings.

 @since 0.0.1.0
-}
setGlobalTracerProvider :: (MonadIO m) => TracerProvider -> m ()
setGlobalTracerProvider :: forall (m :: * -> *). MonadIO m => TracerProvider -> m ()
setGlobalTracerProvider = IO () -> m ()
forall a. IO a -> m a
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


-- | Tracer configuration options.
newtype TracerOptions = TracerOptions
  { TracerOptions -> Maybe Text
tracerSchema :: Maybe Text
  -- ^ OpenTelemetry provides a schema for describing common attributes so that backends can easily parse and identify relevant information.
  -- It is important to understand these conventions when writing instrumentation, in order to normalize your data and increase its utility.
  --
  -- In particular, this option is valuable to set when possible, because it allows vendors to normalize data accross releases in order to account
  -- for attribute name changes.
  }


-- | Default Tracer options
tracerOptions :: TracerOptions
tracerOptions :: TracerOptions
tracerOptions = Maybe Text -> TracerOptions
TracerOptions Maybe Text
forall a. Maybe a
Nothing


{- | A small utility lens for extracting a 'Tracer' from a larger data type

 This will generally be most useful as a means of implementing 'OpenTelemetry.Trace.Monad.getTracer'

 @since 0.0.1.0
-}
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 :: forall (m :: * -> *).
MonadIO m =>
TracerProvider
-> InstrumentationLibrary -> TracerOptions -> m Tracer
getTracer TracerProvider
tp InstrumentationLibrary
n TracerOptions {} = IO Tracer -> m Tracer
forall a. IO a -> m a
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 a. a -> IO a
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


{- | Smart constructor for 'SpanArguments' providing reasonable values for most 'Span's created
 that are internal to an application.

 Defaults:

 - `kind`: `Internal`
 - `attributes`: @[]@
 - `links`: @[]@
 - `startTime`: `Nothing` (`getTimestamp` will be called upon `Span` creation)
-}
defaultSpanArguments :: SpanArguments
defaultSpanArguments :: SpanArguments
defaultSpanArguments =
  SpanArguments
    { kind :: SpanKind
kind = SpanKind
Internal
    , attributes :: HashMap Text Attribute
attributes = []
    , links :: [NewLink]
links = []
    , startTime :: Maybe Timestamp
startTime = Maybe Timestamp
forall a. Maybe a
Nothing
    }


{- | This method provides a way for provider to do any cleanup required.

 This will also trigger shutdowns on all internal processors.

 @since 0.0.1.0
-}
shutdownTracerProvider :: (MonadIO m) => TracerProvider -> m ()
shutdownTracerProvider :: forall (m :: * -> *). MonadIO m => TracerProvider -> m ()
shutdownTracerProvider TracerProvider {AttributeLimits
Propagator Context RequestHeaders RequestHeaders
MaterializedResources
IdGenerator
Vector SpanProcessor
SpanLimits
Sampler
tracerProviderIdGenerator :: TracerProvider -> IdGenerator
tracerProviderProcessors :: TracerProvider -> Vector SpanProcessor
tracerProviderSampler :: TracerProvider -> Sampler
tracerProviderSpanLimits :: TracerProvider -> SpanLimits
tracerProviderAttributeLimits :: TracerProvider -> AttributeLimits
tracerProviderResources :: TracerProvider -> MaterializedResources
tracerProviderPropagators :: TracerProvider -> Propagator Context RequestHeaders RequestHeaders
tracerProviderProcessors :: Vector SpanProcessor
tracerProviderIdGenerator :: IdGenerator
tracerProviderSampler :: Sampler
tracerProviderResources :: MaterializedResources
tracerProviderAttributeLimits :: AttributeLimits
tracerProviderSpanLimits :: SpanLimits
tracerProviderPropagators :: Propagator Context RequestHeaders RequestHeaders
..} = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
  Vector (Async ShutdownResult)
asyncShutdownResults <- Vector SpanProcessor
-> (SpanProcessor -> 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 SpanProcessor
tracerProviderProcessors ((SpanProcessor -> IO (Async ShutdownResult))
 -> IO (Vector (Async ShutdownResult)))
-> (SpanProcessor -> IO (Async ShutdownResult))
-> IO (Vector (Async ShutdownResult))
forall a b. (a -> b) -> a -> b
$ \SpanProcessor
processor -> do
    SpanProcessor -> IO (Async ShutdownResult)
spanProcessorShutdown SpanProcessor
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


{- | This method provides a way for provider to immediately export all spans that have not yet
 been exported for all the internal processors.
-}
forceFlushTracerProvider
  :: (MonadIO m)
  => TracerProvider
  -> Maybe Int
  -- ^ Optional timeout in microseconds, defaults to 5,000,000 (5s)
  -> m FlushResult
  -- ^ Result that denotes whether the flush action succeeded, failed, or timed out.
forceFlushTracerProvider :: forall (m :: * -> *).
MonadIO m =>
TracerProvider -> Maybe Int -> m FlushResult
forceFlushTracerProvider TracerProvider {AttributeLimits
Propagator Context RequestHeaders RequestHeaders
MaterializedResources
IdGenerator
Vector SpanProcessor
SpanLimits
Sampler
tracerProviderIdGenerator :: TracerProvider -> IdGenerator
tracerProviderProcessors :: TracerProvider -> Vector SpanProcessor
tracerProviderSampler :: TracerProvider -> Sampler
tracerProviderSpanLimits :: TracerProvider -> SpanLimits
tracerProviderAttributeLimits :: TracerProvider -> AttributeLimits
tracerProviderResources :: TracerProvider -> MaterializedResources
tracerProviderPropagators :: TracerProvider -> Propagator Context RequestHeaders RequestHeaders
tracerProviderProcessors :: Vector SpanProcessor
tracerProviderIdGenerator :: IdGenerator
tracerProviderSampler :: Sampler
tracerProviderResources :: MaterializedResources
tracerProviderAttributeLimits :: AttributeLimits
tracerProviderSpanLimits :: SpanLimits
tracerProviderPropagators :: Propagator Context RequestHeaders RequestHeaders
..} Maybe Int
mtimeout = IO FlushResult -> m FlushResult
forall a. IO a -> m a
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 SpanProcessor
-> (SpanProcessor -> IO (Async ())) -> IO (Vector (Async ()))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Vector SpanProcessor
tracerProviderProcessors ((SpanProcessor -> IO (Async ())) -> IO (Vector (Async ())))
-> (SpanProcessor -> IO (Async ())) -> IO (Vector (Async ()))
forall a b. (a -> b) -> a -> b
$ \SpanProcessor
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
    SpanProcessor -> IO ()
spanProcessorForceFlush SpanProcessor
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 a. a -> IO a
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 a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FlushResult
FlushTimeout
    Just FlushResult
res -> FlushResult -> IO FlushResult
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FlushResult
res


{- | Utility function to only perform costly attribute annotations
 for spans that are actually
-}
whenSpanIsRecording :: (MonadIO m) => Span -> m () -> m ()
whenSpanIsRecording :: forall (m :: * -> *). MonadIO m => Span -> m () -> m ()
whenSpanIsRecording (Span IORef ImmutableSpan
ref) m ()
m = do
  ImmutableSpan
span_ <- IO ImmutableSpan -> m ImmutableSpan
forall a. IO a -> m a
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 a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
whenSpanIsRecording (FrozenSpan SpanContext
_) m ()
_ = () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
whenSpanIsRecording (Dropped SpanContext
_) m ()
_ = () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()


timestampNanoseconds :: Timestamp -> Word64
timestampNanoseconds :: Timestamp -> Word64
timestampNanoseconds (Timestamp TimeSpec {Int64
sec :: Int64
nsec :: Int64
sec :: TimeSpec -> Int64
nsec :: TimeSpec -> 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