{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
module Observe.Event.Render.OpenTelemetry where
import Control.Monad.IO.Class
import Data.Text (Text, pack)
import Observe.Event.Backend
import OpenTelemetry.Context
import OpenTelemetry.Context.ThreadLocal
import OpenTelemetry.Trace.Core hiding (Event)
import OpenTelemetry.Trace.Id
tracerEventBackend :: (MonadIO m) => Tracer -> RenderSelectorOTel s -> EventBackend m Span s
tracerEventBackend :: forall (m :: * -> *) (s :: * -> *).
MonadIO m =>
Tracer -> RenderSelectorOTel s -> EventBackend m Span s
tracerEventBackend Tracer
tracer RenderSelectorOTel s
render = EventBackend m Span s
backend
where
backend :: EventBackend m Span s
backend =
EventBackend
{ newEvent :: forall f. NewEventArgs Span s f -> m (Event m Span f)
newEvent = \args :: NewEventArgs Span s f
args@(NewEventArgs {s f
[f]
[Span]
Maybe Span
newEventSelector :: forall r (s :: * -> *) f. NewEventArgs r s f -> s f
newEventParent :: forall r (s :: * -> *) f. NewEventArgs r s f -> Maybe r
newEventCauses :: forall r (s :: * -> *) f. NewEventArgs r s f -> [r]
newEventInitialFields :: forall r (s :: * -> *) f. NewEventArgs r s f -> [f]
newEventInitialFields :: [f]
newEventCauses :: [Span]
newEventParent :: Maybe Span
newEventSelector :: s f
..}) -> do
Context
ctx <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe Context
empty forall a. a -> a
id forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadIO m => m (Maybe Context)
lookupContext
let ctx' :: Context
ctx' = case Maybe Span
newEventParent of
Just Span
s -> Span -> Context -> Context
insertSpan Span
s Context
ctx
Maybe Span
Nothing -> Context
ctx
OTelRendered {Text
SpanKind
f -> [(Text, Attribute)]
renderField :: forall f. OTelRendered f -> f -> [(Text, Attribute)]
eventKind :: forall f. OTelRendered f -> SpanKind
eventName :: forall f. OTelRendered f -> Text
renderField :: f -> [(Text, Attribute)]
eventKind :: SpanKind
eventName :: Text
..} = RenderSelectorOTel s
render s f
newEventSelector
[NewLink]
links <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b c. (a -> b -> c) -> b -> a -> c
flip SpanContext -> [(Text, Attribute)] -> NewLink
NewLink []) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). MonadIO m => Span -> m SpanContext
getSpanContext) [Span]
newEventCauses
Span
s <-
forall (m :: * -> *).
MonadIO m =>
Tracer -> Context -> Text -> SpanArguments -> m Span
createSpanWithoutCallStack Tracer
tracer Context
ctx' Text
eventName forall a b. (a -> b) -> a -> b
$
SpanArguments
{ kind :: SpanKind
kind = SpanKind
eventKind,
attributes :: [(Text, Attribute)]
attributes = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap f -> [(Text, Attribute)]
renderField [f]
newEventInitialFields,
links :: [NewLink]
links = [NewLink]
links,
startTime :: Maybe Timestamp
startTime = forall a. Maybe a
Nothing
}
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
Event
{ reference :: Span
reference = Span
s,
addField :: f -> m ()
addField = forall (m :: * -> *).
MonadIO m =>
Span -> [(Text, Attribute)] -> m ()
addAttributes Span
s forall b c a. (b -> c) -> (a -> b) -> a -> c
. f -> [(Text, Attribute)]
renderField,
finalize :: Maybe SomeException -> m ()
finalize = \Maybe SomeException
me -> do
let recordError :: a -> m ()
recordError a
e = do
forall (m :: * -> *) e.
(MonadIO m, Exception e) =>
Span -> [(Text, Attribute)] -> Maybe Timestamp -> e -> m ()
recordException Span
s [(Text
"exception.escaped", forall a. ToAttribute a => a -> Attribute
toAttribute Bool
True)] forall a. Maybe a
Nothing a
e
forall (m :: * -> *). MonadIO m => Span -> SpanStatus -> m ()
setStatus Span
s forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> SpanStatus
Error forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show a
e
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *). MonadIO m => Span -> SpanStatus -> m ()
setStatus Span
s SpanStatus
Ok) forall {m :: * -> *} {a}. (MonadIO m, Exception a) => a -> m ()
recordError Maybe SomeException
me
forall (m :: * -> *). MonadIO m => Span -> Maybe Timestamp -> m ()
endSpan Span
s forall a. Maybe a
Nothing
},
emitImmediateEvent :: forall f. NewEventArgs Span s f -> m Span
emitImmediateEvent = \args :: NewEventArgs Span s f
args@(NewEventArgs {s f
[f]
[Span]
Maybe Span
newEventInitialFields :: [f]
newEventCauses :: [Span]
newEventParent :: Maybe Span
newEventSelector :: s f
newEventSelector :: forall r (s :: * -> *) f. NewEventArgs r s f -> s f
newEventParent :: forall r (s :: * -> *) f. NewEventArgs r s f -> Maybe r
newEventCauses :: forall r (s :: * -> *) f. NewEventArgs r s f -> [r]
newEventInitialFields :: forall r (s :: * -> *) f. NewEventArgs r s f -> [f]
..}) -> case Maybe Span
newEventParent of
Maybe Span
Nothing -> do
Maybe Context
m_ctx <- forall (m :: * -> *). MonadIO m => m (Maybe Context)
lookupContext
case Maybe Context
m_ctx forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Context -> Maybe Span
lookupSpan of
Just Span
s ->
forall (m :: * -> *) r (s :: * -> *).
EventBackend m r s -> forall f. NewEventArgs r s f -> m r
emitImmediateEvent EventBackend m Span s
backend forall a b. (a -> b) -> a -> b
$
NewEventArgs Span s f
args
{ newEventParent :: Maybe Span
newEventParent = forall a. a -> Maybe a
Just Span
s
}
Maybe Span
Nothing -> do
Event m Span f
ev <- forall (m :: * -> *) r (s :: * -> *).
EventBackend m r s
-> forall f. NewEventArgs r s f -> m (Event m r f)
newEvent EventBackend m Span s
backend NewEventArgs Span s f
args
forall (m :: * -> *) r f.
Event m r f -> Maybe SomeException -> m ()
finalize Event m Span f
ev forall a. Maybe a
Nothing
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r f. Event m r f -> r
reference Event m Span f
ev
Just Span
s -> do
let OTelRendered {Text
SpanKind
f -> [(Text, Attribute)]
renderField :: f -> [(Text, Attribute)]
eventKind :: SpanKind
eventName :: Text
renderField :: forall f. OTelRendered f -> f -> [(Text, Attribute)]
eventKind :: forall f. OTelRendered f -> SpanKind
eventName :: forall f. OTelRendered f -> Text
..} = RenderSelectorOTel s
render s f
newEventSelector
forall (m :: * -> *). MonadIO m => Span -> NewEvent -> m ()
addEvent Span
s forall a b. (a -> b) -> a -> b
$
NewEvent
{ newEventName :: Text
newEventName = Text
eventName,
newEventAttributes :: [(Text, Attribute)]
newEventAttributes = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap f -> [(Text, Attribute)]
renderField [f]
newEventInitialFields,
newEventTimestamp :: Maybe Timestamp
newEventTimestamp = forall a. Maybe a
Nothing
}
forall (f :: * -> *) a. Applicative f => a -> f a
pure Span
s
}
type RenderSelectorOTel s = forall f. s f -> OTelRendered f
data OTelRendered f = OTelRendered
{
forall f. OTelRendered f -> Text
eventName :: !Text,
forall f. OTelRendered f -> SpanKind
eventKind :: !SpanKind,
forall f. OTelRendered f -> f -> [(Text, Attribute)]
renderField :: !(f -> [(Text, Attribute)])
}