-- | Application tracing via <https://opentelemetry.io/>
--
-- @
-- data App = App
--   { -- ...
--   , appTracer :: Tracer
--   }
--
-- instance HasTracer App where
--   tracerL = lens appTracer $ \x y -> x { appTracer = y }
--
-- loadApp f = do
--   -- ...
--   withTracerProvider $ \tracerProvider -> do
--     let appTracer = makeTracer tracerProvider "my-app" tracerOptions
--     f App {..}
-- @
--
-- You may need to do this even if you don't plan to manually trace things, in order to
-- satisfy the 'MonadTracer' constraint required by functions like 'runDB'. If
-- you don't need this feature, and don't plan on running an otel-collector, set
-- @OTEL_TRACES_EXPORTER=none@ in the environment, which makes all tracing a
-- no-op.
--
-- In the future, it should be possible to use @OTEL_SDK_DISABLED@ for the same
-- purpose. See <https://github.com/iand675/hs-opentelemetry/issues/60>.
module Freckle.App.OpenTelemetry
  ( HasTracer (..)
  , Tracer

    -- * Effects
  , MonadTracer (..)
  , inSpan
  , defaultSpanArguments

    -- * Querying
  , withTraceIdContext
  , getCurrentTraceId
  , getCurrentTraceIdAsDatadog
  , getCurrentSpanContext

    -- * Setup
  , withTracerProvider

    -- ** 'Tracer'
  , makeTracer
  , tracerOptions
  ) where

import Freckle.App.Prelude

import Blammo.Logging (MonadMask, withThreadContext, (.=))
import Data.Word (Word64)
import OpenTelemetry.Context (lookupSpan)
import OpenTelemetry.Context.ThreadLocal (getContext)
import OpenTelemetry.Propagator.Datadog
  ( convertOpenTelemetryTraceIdToDatadogTraceId
  )
import OpenTelemetry.Trace hiding (inSpan)
import OpenTelemetry.Trace.Core (getSpanContext)
import qualified OpenTelemetry.Trace.Core as Trace (SpanContext (..))
import OpenTelemetry.Trace.Id (TraceId)
import OpenTelemetry.Trace.Monad
import UnliftIO.Exception (bracket)

withTracerProvider :: MonadUnliftIO m => (TracerProvider -> m a) -> m a
withTracerProvider :: forall (m :: * -> *) a.
MonadUnliftIO m =>
(TracerProvider -> m a) -> m a
withTracerProvider =
  forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket
    (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO TracerProvider
initializeGlobalTracerProvider)
    (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). MonadIO m => TracerProvider -> m ()
shutdownTracerProvider)

getCurrentTraceId :: MonadIO m => m (Maybe TraceId)
getCurrentTraceId :: forall (m :: * -> *). MonadIO m => m (Maybe TraceId)
getCurrentTraceId = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SpanContext -> TraceId
Trace.traceId forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadIO m => m (Maybe SpanContext)
getCurrentSpanContext

getCurrentTraceIdAsDatadog :: MonadIO m => m (Maybe Word64)
getCurrentTraceIdAsDatadog :: forall (m :: * -> *). MonadIO m => m (Maybe Word64)
getCurrentTraceIdAsDatadog =
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TraceId -> Word64
convertOpenTelemetryTraceIdToDatadogTraceId forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadIO m => m (Maybe TraceId)
getCurrentTraceId

getCurrentSpanContext :: MonadIO m => m (Maybe SpanContext)
getCurrentSpanContext :: forall (m :: * -> *). MonadIO m => m (Maybe SpanContext)
getCurrentSpanContext = do
  Maybe Span
mSpan <- Context -> Maybe Span
lookupSpan forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadIO m => m Context
getContext
  forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall (m :: * -> *). MonadIO m => Span -> m SpanContext
getSpanContext Maybe Span
mSpan

withTraceIdContext :: (MonadIO m, MonadMask m) => m a -> m a
withTraceIdContext :: forall (m :: * -> *) a. (MonadIO m, MonadMask m) => m a -> m a
withTraceIdContext m a
f = do
  Maybe Word64
mTraceId <- forall (m :: * -> *). MonadIO m => m (Maybe Word64)
getCurrentTraceIdAsDatadog
  forall b a. b -> (a -> b) -> Maybe a -> b
maybe m a
f (\Word64
traceId -> forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
[Pair] -> m a -> m a
withThreadContext [Key
"trace_id" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Word64
traceId] m a
f) Maybe Word64
mTraceId