module HotelCalifornia.Tracing
    ( module HotelCalifornia.Tracing
    , defaultSpanArguments
    ) where

import Control.Monad
import qualified Data.ByteString.Char8 as BS8
import Data.Text (Text)
import Data.Time
import HotelCalifornia.Tracing.TraceParent
import OpenTelemetry.Context as Context hiding (lookup)
import OpenTelemetry.Context.ThreadLocal (attachContext)
import OpenTelemetry.Trace hiding
       ( SpanKind(..)
       , SpanStatus(..)
       , addAttribute
       , addAttributes
       , createSpan
       , inSpan
       , inSpan'
       , inSpan''
       )
import qualified OpenTelemetry.Trace as Trace
import qualified OpenTelemetry.Vendor.Honeycomb as Honeycomb
import UnliftIO

-- | Initialize the global tracing provider for the application and run an action
--   (that action is generally the entry point of the application), cleaning
--   up the provider afterwards.
--
--   This also sets up an empty context (creating a new trace ID).
withGlobalTracing :: MonadUnliftIO m => m a -> m a
withGlobalTracing :: forall (m :: * -> *) a. MonadUnliftIO m => m a -> m a
withGlobalTracing m a
act = do
    forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadIO m => Context -> m (Maybe Context)
attachContext Context
Context.empty
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
setParentSpanFromEnvironment
    forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket forall (m :: * -> *). MonadUnliftIO m => m TracerProvider
initializeTracing forall (m :: * -> *). MonadIO m => TracerProvider -> m ()
shutdownTracerProvider forall a b. (a -> b) -> a -> b
$ \TracerProvider
_ -> do
        -- note: this is not in a span since we don't have a root span yet so it
        -- would not wind up in the trace in a helpful way anyway
        forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$
          forall (m :: * -> *).
MonadIO m =>
NominalDiffTime -> m (Maybe HoneycombTarget)
Honeycomb.getOrInitializeHoneycombTargetInContext NominalDiffTime
initializationTimeout
            forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \(SomeException
e :: SomeException) -> do
              -- we are too early in initialization to be able to use a normal logger,
              -- but this needs to get out somehow.
              --
              -- honeycomb links are not load-bearing, so we let them just not come
              -- up if the API fails.
              forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> ByteString -> IO ()
BS8.hPutStrLn Handle
stderr forall a b. (a -> b) -> a -> b
$ ByteString
"error setting up Honeycomb trace links: " forall a. Semigroup a => a -> a -> a
<> (String -> ByteString
BS8.pack forall a b. (a -> b) -> a -> b
$ forall e. Exception e => e -> String
displayException SomeException
e)
              pure forall a. Maybe a
Nothing

        m a
act
  where
    initializationTimeout :: NominalDiffTime
initializationTimeout = Pico -> NominalDiffTime
secondsToNominalDiffTime Pico
3

initializeTracing :: MonadUnliftIO m => m TracerProvider
initializeTracing :: forall (m :: * -> *). MonadUnliftIO m => m TracerProvider
initializeTracing = do
  ([Processor]
processors, TracerProviderOptions
tracerOptions') <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ([Processor], TracerProviderOptions)
getTracerProviderInitializationOptions
  TracerProvider
provider <- forall (m :: * -> *).
MonadIO m =>
[Processor] -> TracerProviderOptions -> m TracerProvider
createTracerProvider [Processor]
processors TracerProviderOptions
tracerOptions'
  forall (m :: * -> *). MonadIO m => TracerProvider -> m ()
setGlobalTracerProvider TracerProvider
provider
  pure TracerProvider
provider

globalTracer :: MonadIO m => m Tracer
globalTracer :: forall (m :: * -> *). MonadIO m => m Tracer
globalTracer = forall (m :: * -> *). MonadIO m => m TracerProvider
getGlobalTracerProvider forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \TracerProvider
tp -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ TracerProvider -> InstrumentationLibrary -> TracerOptions -> Tracer
makeTracer TracerProvider
tp InstrumentationLibrary
"hotel-california" TracerOptions
tracerOptions

inSpan' :: (MonadUnliftIO m) => Text -> (Span -> m a) -> m a
inSpan' :: forall (m :: * -> *) a.
MonadUnliftIO m =>
Text -> (Span -> m a) -> m a
inSpan' Text
spanName =
    forall (m :: * -> *) a.
MonadUnliftIO m =>
Text -> SpanArguments -> (Span -> m a) -> m a
inSpanWith' Text
spanName SpanArguments
defaultSpanArguments

inSpanWith :: (MonadUnliftIO m) => Text -> SpanArguments -> m a -> m a
inSpanWith :: forall (m :: * -> *) a.
MonadUnliftIO m =>
Text -> SpanArguments -> m a -> m a
inSpanWith Text
spanName SpanArguments
args m a
action =
    forall (m :: * -> *) a.
MonadUnliftIO m =>
Text -> SpanArguments -> (Span -> m a) -> m a
inSpanWith' Text
spanName SpanArguments
args \Span
_ -> m a
action

inSpanWith' :: (MonadUnliftIO m) => Text -> SpanArguments -> (Span -> m a) -> m a
inSpanWith' :: forall (m :: * -> *) a.
MonadUnliftIO m =>
Text -> SpanArguments -> (Span -> m a) -> m a
inSpanWith' Text
spanName SpanArguments
args Span -> m a
action = do
    Tracer
tr <- forall (m :: * -> *). MonadIO m => m Tracer
globalTracer
    forall (m :: * -> *) a.
(MonadUnliftIO m, HasCallStack) =>
Tracer -> Text -> SpanArguments -> (Span -> m a) -> m a
Trace.inSpan'' Tracer
tr Text
spanName SpanArguments
args Span -> m a
action

inSpan :: (MonadUnliftIO m) => Text -> m a -> m a
inSpan :: forall (m :: * -> *) a. MonadUnliftIO m => Text -> m a -> m a
inSpan Text
spanName =
    forall (m :: * -> *) a.
MonadUnliftIO m =>
Text -> SpanArguments -> m a -> m a
inSpanWith Text
spanName SpanArguments
defaultSpanArguments