{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UnicodeSyntax #-}
module Observe.Event.Backend.OpenTelemetry
( TracerEventBackend (..)
, RenderOTel
, OTelRendered (..)
)
where
import Control.Monad.IO.Class
import Data.Functor.Parametric
import Data.HashMap.Strict as HashMap
import Data.Maybe
import Data.Text (Text, pack)
import Observe.Event.Backend
import OpenTelemetry.Context as Context
import OpenTelemetry.Context.ThreadLocal
import OpenTelemetry.Trace.Core
data TracerEventBackend selector = TracerEventBackend
{ forall (selector :: * -> *). TracerEventBackend selector -> Tracer
tracer ∷ !Tracer
, forall (selector :: * -> *).
TracerEventBackend selector -> RenderOTel selector
render ∷ !(RenderOTel selector)
}
type RenderOTel selector = ∀ field. Selectors selector field → OTelRendered field
data OTelRendered field = OTelRendered
{ forall field. OTelRendered field -> Text
eventName ∷ !Text
, forall field. OTelRendered field -> SpanKind
eventKind ∷ !SpanKind
, forall field. OTelRendered field -> field -> HashMap Text Attribute
renderField ∷ !(field → HashMap Text Attribute)
}
instance EventBackend (TracerEventBackend selector) where
type BackendEvent (TracerEventBackend selector) = TracerEventBackendEvent
type RootSelector (TracerEventBackend selector) = selector
instance (MonadIO m, ParametricFunctor m) ⇒ EventBackendIn m (TracerEventBackend selector) where
newEvent :: forall field.
TracerEventBackend selector
-> EventParams
(RootSelector (TracerEventBackend selector))
field
(EventReference (BackendEvent (TracerEventBackend selector)))
-> m (BackendEvent (TracerEventBackend selector) field)
newEvent TracerEventBackend selector
be EventParams
(RootSelector (TracerEventBackend selector))
field
(EventReference (BackendEvent (TracerEventBackend selector)))
params = do
Context
ctx ← Context -> Maybe Context -> Context
forall a. a -> Maybe a -> a
fromMaybe Context
Context.empty (Maybe Context -> Context) -> m (Maybe Context) -> m Context
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Maybe Context)
forall (m :: * -> *). MonadIO m => m (Maybe Context)
lookupContext
let ctx' :: 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) EventParams selector field Span
EventParams
(RootSelector (TracerEventBackend selector))
field
(EventReference (BackendEvent (TracerEventBackend selector)))
params.parent
rendered :: OTelRendered field
rendered = TracerEventBackend selector -> RenderOTel selector
forall (selector :: * -> *).
TracerEventBackend selector -> RenderOTel selector
render TracerEventBackend selector
be EventParams selector field Span
EventParams
(RootSelector (TracerEventBackend selector))
field
(EventReference (BackendEvent (TracerEventBackend selector)))
params.selectors
[NewLink]
links ← (Span -> m NewLink) -> [Span] -> m [NewLink]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ((SpanContext -> NewLink) -> m SpanContext -> m NewLink
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SpanContext -> HashMap Text Attribute -> NewLink
`NewLink` HashMap Text Attribute
forall k v. HashMap k v
HashMap.empty) (m SpanContext -> m NewLink)
-> (Span -> m SpanContext) -> Span -> m NewLink
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Span -> m SpanContext
forall (m :: * -> *). MonadIO m => Span -> m SpanContext
getSpanContext) EventParams selector field Span
EventParams
(RootSelector (TracerEventBackend selector))
field
(EventReference (BackendEvent (TracerEventBackend selector)))
params.causes
Span
otelSpan ←
Tracer -> Context -> Text -> SpanArguments -> m Span
forall (m :: * -> *).
MonadIO m =>
Tracer -> Context -> Text -> SpanArguments -> m Span
createSpanWithoutCallStack TracerEventBackend selector
be.tracer Context
ctx' OTelRendered field
rendered.eventName (SpanArguments -> m Span) -> SpanArguments -> m Span
forall a b. (a -> b) -> a -> b
$
SpanArguments
{ kind :: SpanKind
kind = OTelRendered field
rendered.eventKind
, attributes :: HashMap Text Attribute
attributes = (field -> HashMap Text Attribute)
-> [field] -> HashMap Text Attribute
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (OTelRendered field -> field -> HashMap Text Attribute
forall field. OTelRendered field -> field -> HashMap Text Attribute
renderField OTelRendered field
rendered) EventParams selector field Span
EventParams
(RootSelector (TracerEventBackend selector))
field
(EventReference (BackendEvent (TracerEventBackend selector)))
params.initialFields
, [NewLink]
links :: [NewLink]
links :: [NewLink]
links
, startTime :: Maybe Timestamp
startTime = Maybe Timestamp
forall a. Maybe a
Nothing
}
TracerEventBackendEvent field -> m (TracerEventBackendEvent field)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TracerEventBackendEvent field
-> m (TracerEventBackendEvent field))
-> TracerEventBackendEvent field
-> m (TracerEventBackendEvent field)
forall a b. (a -> b) -> a -> b
$ TracerEventBackendEvent{Span
otelSpan :: Span
$sel:otelSpan:TracerEventBackendEvent :: Span
otelSpan, $sel:renderField':TracerEventBackendEvent :: field -> HashMap Text Attribute
renderField' = OTelRendered field -> field -> HashMap Text Attribute
forall field. OTelRendered field -> field -> HashMap Text Attribute
renderField OTelRendered field
rendered}
newInstantEvent :: forall field.
TracerEventBackend selector
-> EventParams
(RootSelector (TracerEventBackend selector))
field
(EventReference (BackendEvent (TracerEventBackend selector)))
-> m (EventReference (BackendEvent (TracerEventBackend selector)))
newInstantEvent TracerEventBackend selector
be EventParams
(RootSelector (TracerEventBackend selector))
field
(EventReference (BackendEvent (TracerEventBackend selector)))
params = case EventParams selector field Span
EventParams
(RootSelector (TracerEventBackend selector))
field
(EventReference (BackendEvent (TracerEventBackend selector)))
params.parent of
Maybe Span
Nothing → do
Maybe Context
m_ctx ← m (Maybe Context)
forall (m :: * -> *). MonadIO m => m (Maybe Context)
lookupContext
case Maybe Context
m_ctx Maybe Context -> (Context -> Maybe Span) -> Maybe Span
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Context -> Maybe Span
lookupSpan of
Just Span
s → TracerEventBackend selector
-> EventParams
(RootSelector (TracerEventBackend selector))
field
(EventReference (BackendEvent (TracerEventBackend selector)))
-> m (EventReference (BackendEvent (TracerEventBackend selector)))
forall field.
TracerEventBackend selector
-> EventParams
(RootSelector (TracerEventBackend selector))
field
(EventReference (BackendEvent (TracerEventBackend selector)))
-> m (EventReference (BackendEvent (TracerEventBackend selector)))
forall (m :: * -> *) backend field.
EventBackendIn m backend =>
backend
-> EventParams
(RootSelector backend)
field
(EventReference (BackendEvent backend))
-> m (EventReference (BackendEvent backend))
newInstantEvent TracerEventBackend selector
be (EventParams
(RootSelector (TracerEventBackend selector))
field
(EventReference (BackendEvent (TracerEventBackend selector)))
-> m (EventReference (BackendEvent (TracerEventBackend selector))))
-> EventParams
(RootSelector (TracerEventBackend selector))
field
(EventReference (BackendEvent (TracerEventBackend selector)))
-> m (EventReference (BackendEvent (TracerEventBackend selector)))
forall a b. (a -> b) -> a -> b
$ EventParams
(RootSelector (TracerEventBackend selector))
field
(EventReference (BackendEvent (TracerEventBackend selector)))
params{parent = Just s}
Maybe Span
Nothing → do
TracerEventBackendEvent field
ev ← TracerEventBackend selector
-> EventParams
(RootSelector (TracerEventBackend selector))
field
(EventReference (BackendEvent (TracerEventBackend selector)))
-> m (BackendEvent (TracerEventBackend selector) field)
forall field.
TracerEventBackend selector
-> EventParams
(RootSelector (TracerEventBackend selector))
field
(EventReference (BackendEvent (TracerEventBackend selector)))
-> m (BackendEvent (TracerEventBackend selector) field)
forall (m :: * -> *) backend field.
EventBackendIn m backend =>
backend
-> EventParams
(RootSelector backend)
field
(EventReference (BackendEvent backend))
-> m (BackendEvent backend field)
newEvent TracerEventBackend selector
be EventParams
(RootSelector (TracerEventBackend selector))
field
(EventReference (BackendEvent (TracerEventBackend selector)))
params
TracerEventBackendEvent field -> Maybe SomeException -> m ()
forall field.
TracerEventBackendEvent field -> Maybe SomeException -> m ()
forall (m :: * -> *) (event :: * -> *) field.
EventIn m event =>
event field -> Maybe SomeException -> m ()
finalize TracerEventBackendEvent field
ev Maybe SomeException
forall a. Maybe a
Nothing
Span -> m Span
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Span -> m Span) -> Span -> m Span
forall a b. (a -> b) -> a -> b
$ TracerEventBackendEvent field
-> EventReference TracerEventBackendEvent
forall field.
TracerEventBackendEvent field
-> EventReference TracerEventBackendEvent
forall (event :: * -> *) field.
Event event =>
event field -> EventReference event
reference TracerEventBackendEvent field
ev
Just Span
s → do
let rendered :: OTelRendered field
rendered = TracerEventBackend selector -> RenderOTel selector
forall (selector :: * -> *).
TracerEventBackend selector -> RenderOTel selector
render TracerEventBackend selector
be EventParams selector field Span
EventParams
(RootSelector (TracerEventBackend selector))
field
(EventReference (BackendEvent (TracerEventBackend selector)))
params.selectors
Span -> NewEvent -> m ()
forall (m :: * -> *). MonadIO m => Span -> NewEvent -> m ()
addEvent Span
s (NewEvent -> m ()) -> NewEvent -> m ()
forall a b. (a -> b) -> a -> b
$
NewEvent
{ newEventName :: Text
newEventName = OTelRendered field
rendered.eventName
, newEventAttributes :: HashMap Text Attribute
newEventAttributes = (field -> HashMap Text Attribute)
-> [field] -> HashMap Text Attribute
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (OTelRendered field -> field -> HashMap Text Attribute
forall field. OTelRendered field -> field -> HashMap Text Attribute
renderField OTelRendered field
rendered) EventParams selector field Span
EventParams
(RootSelector (TracerEventBackend selector))
field
(EventReference (BackendEvent (TracerEventBackend selector)))
params.initialFields
, newEventTimestamp :: Maybe Timestamp
newEventTimestamp = Maybe Timestamp
forall a. Maybe a
Nothing
}
Span -> m Span
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Span
s
data TracerEventBackendEvent field = TracerEventBackendEvent
{ forall field.
TracerEventBackendEvent field -> field -> HashMap Text Attribute
renderField' ∷ !(field → HashMap Text Attribute)
, forall field. TracerEventBackendEvent field -> Span
otelSpan ∷ Span
}
instance Observe.Event.Backend.Event TracerEventBackendEvent where
type EventReference TracerEventBackendEvent = Span
reference :: forall field.
TracerEventBackendEvent field
-> EventReference TracerEventBackendEvent
reference = (.otelSpan)
instance (MonadIO m, ParametricFunctor m) ⇒ EventIn m TracerEventBackendEvent where
finalize :: forall field.
TracerEventBackendEvent field -> Maybe SomeException -> m ()
finalize TracerEventBackendEvent field
ev Maybe SomeException
err = do
case Maybe SomeException
err of
Just SomeException
e → do
Span
-> HashMap Text Attribute
-> Maybe Timestamp
-> SomeException
-> m ()
forall (m :: * -> *) e.
(MonadIO m, Exception e) =>
Span -> HashMap Text Attribute -> Maybe Timestamp -> e -> m ()
recordException TracerEventBackendEvent field
ev.otelSpan (Text -> Attribute -> HashMap Text Attribute
forall k v. Hashable k => k -> v -> HashMap k v
singleton Text
"exception.escaped" (Bool -> Attribute
forall a. ToAttribute a => a -> Attribute
toAttribute Bool
True)) Maybe Timestamp
forall a. Maybe a
Nothing SomeException
e
Span -> SpanStatus -> m ()
forall (m :: * -> *). MonadIO m => Span -> SpanStatus -> m ()
setStatus TracerEventBackendEvent field
ev.otelSpan (SpanStatus -> m ()) -> (String -> SpanStatus) -> String -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> SpanStatus
Error (Text -> SpanStatus) -> (String -> Text) -> String -> SpanStatus
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall a. Show a => a -> String
show SomeException
e
Maybe SomeException
Nothing → Span -> SpanStatus -> m ()
forall (m :: * -> *). MonadIO m => Span -> SpanStatus -> m ()
setStatus TracerEventBackendEvent field
ev.otelSpan SpanStatus
Ok
Span -> Maybe Timestamp -> m ()
forall (m :: * -> *). MonadIO m => Span -> Maybe Timestamp -> m ()
endSpan TracerEventBackendEvent field
ev.otelSpan Maybe Timestamp
forall a. Maybe a
Nothing
addField :: forall field. TracerEventBackendEvent field -> field -> m ()
addField TracerEventBackendEvent field
ev = Span -> HashMap Text Attribute -> m ()
forall (m :: * -> *).
MonadIO m =>
Span -> HashMap Text Attribute -> m ()
addAttributes TracerEventBackendEvent field
ev.otelSpan (HashMap Text Attribute -> m ())
-> (field -> HashMap Text Attribute) -> field -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TracerEventBackendEvent field -> field -> HashMap Text Attribute
forall field.
TracerEventBackendEvent field -> field -> HashMap Text Attribute
renderField' TracerEventBackendEvent field
ev