{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}

-- |
-- Description : EventBackend for rendering events as OpenTelemetry traces
-- Copyright   : Copyright 2023 Shea Levy.
-- License     : Apache-2.0
-- Maintainer  : shea@shealevy.com
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

-- | An 'EventBackend' built on a 'Tracer'.
--
-- When no explicit parent is set, the backend will try to find a parent in the "OpenTelemetry.Context.ThreadLocal" 'Context'.
-- However, it will never update that 'Context', as the primitive 'EventBackend' API has no way to determine if it's being
-- consumed in a scoped context or one allowing for general interleaving.
--
-- When possible, events created with 'emitImmediateEvent' will use the span event API. However, this requires a parent event
-- (explicitly specified or found in the thread-local 'Context'), so the backend will fallback to creating and 'finalize'ing a new
-- 'Span'. If a span event is created, the resulting 'reference' will be to its parent, as span events cannot be parents/links. Span
-- events do not allow for non-parent links, so any `newEventCauses` are dropped; in the future, we may either add them as custom
-- 'Attribute's or fall back to a full span if any are specified.
--
-- Event 'Link's are currently not given any attributes. In the future, arbitrary link metadata could be added to the core 'EventBackend'
-- API, in which case we could add a renderer for the link metadata type.
--
-- Currently the backend lets the underlying 'Tracer' set all timestamps. In the future, 'RenderSelectorOTel' could be allowed to run in
-- @m@ and have a timestamp field.
--
-- Exceptions passed to 'finalize' are 'recordException'ed without any custom attributes. In the future, an @Exception -> [Text, Attribute]@
-- argument could be added, or arbitrary exception metadata added to 'finalize'.
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
        }

-- | Render a given selector (and all of its fields) to OpenTelemetry
type RenderSelectorOTel s = forall f. s f -> OTelRendered f

-- | The result of rendering a specific selector with field type @f@
data OTelRendered f = OTelRendered
  { -- | The name of the event. See section on "span name" at <https://opentelemetry.io/docs/reference/specification/trace/api/#span>
    forall f. OTelRendered f -> Text
eventName :: !Text,
    -- | See the specification on [SpanKind](https://opentelemetry.io/docs/reference/specification/trace/api/#spankind)
    forall f. OTelRendered f -> SpanKind
eventKind :: !SpanKind,
    -- | Render a field to a set of span [attributes](https://opentelemetry.io/docs/reference/specification/common/#attribute).
    --
    -- Note especially the [attribute naming guidelines](https://opentelemetry.io/docs/reference/specification/common/attribute-naming/)
    forall f. OTelRendered f -> f -> [(Text, Attribute)]
renderField :: !(f -> [(Text, Attribute)])
  }