-- Copyright 2024 Shea Levy
--
-- Licensed under the Apache License, Version 2.0 (the "License");
-- you may not use this file except in compliance with the License.
-- You may obtain a copy of the License at
--
--     http://www.apache.org/licenses/LICENSE-2.0
--
-- Unless required by applicable law or agreed to in writing, software
-- distributed under the License is distributed on an "AS IS" BASIS,
-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-- See the License for the specific language governing permissions and
-- limitations under the License.
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UnicodeSyntax #-}

{- |
Description : 'EventBackend' rendering 'Observe.Event.Event's as OpenTelemetry traces
Copyright   : Copyright 2024 Shea Levy.
License     : Apache-2.0
Maintainer  : shea@shealevy.com
-}
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

{- | 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 'Observe.Event.instantEvent' 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 'Observe.Event.eventReference' will be to its parent, as span events cannot be parents/links.
Span events do not allow for non-parent links, so any @causes@ 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 t'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.

The underlying 'Tracer' is responsible for timestamping.

Exceptions are 'recordException'ed without any custom attributes. In the future, an @Exception -> HashMap Text Attribute@
argument could be added, or arbitrary exception metadata added to 'Observe.Event.finalizeEvent'.
-}
data TracerEventBackend selector = TracerEventBackend
  { forall (selector :: * -> *). TracerEventBackend selector -> Tracer
tracer ∷ !Tracer
  -- ^ The 'Tracer' from @hs-opentelemetry-api@.
  --
  -- See the [hs-opentelemetry-sdk intialization docs](https://hackage.haskell.org/package/hs-opentelemetry-sdk#initialization) for
  -- the typical way of getting a 'Tracer' in your application.
  , forall (selector :: * -> *).
TracerEventBackend selector -> RenderOTel selector
render ∷ !(RenderOTel selector)
  -- ^ The domain-specific logic for translating 'Observe.Event.Event's rooted
  -- in a given [selector](https://hackage.haskell.org/package/e11y/docs/Observe-Event.html#g:selectorAndField).
  }

{- | The domain-specific logic for translating 'Observe.Event.Event's rooted
in a given [selector](https://hackage.haskell.org/package/e11y/docs/Observe-Event.html#g:selectorAndField).
-}
type RenderOTel selector = ∀ field. Selectors selector field → OTelRendered field

{- | The domain-specific logic for translating a specific 'Observe.Event.Event'
with a given [field](https://hackage.haskell.org/package/e11y/docs/Observe-Event.html#g:selectorAndField)
type.
-}
data OTelRendered field = OTelRendered
  { forall field. OTelRendered field -> Text
eventName ∷ !Text
  -- ^ The name of the event.
  --
  -- See the "span name" section of the [open-telemetry span documentation](https://opentelemetry.io/docs/reference/specification/trace/api/#span).
  , forall field. OTelRendered field -> SpanKind
eventKind ∷ !SpanKind
  -- ^ The kind of span to create.
  --
  -- See the [SpanKind](https://opentelemetry.io/docs/reference/specification/trace/api/#spankind) specification.
  , forall field. OTelRendered field -> field -> HashMap Text Attribute
renderField ∷ !(field → HashMap Text Attribute)
  -- ^ 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/).
  }

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