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 => (Maybe Honeycomb.HoneycombTarget -> m a) -> m a
withGlobalTracing :: forall (m :: * -> *) a.
MonadUnliftIO m =>
(Maybe HoneycombTarget -> m a) -> m a
withGlobalTracing Maybe HoneycombTarget -> m a
act = do
    m (Maybe Context) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (Maybe Context) -> m ()) -> m (Maybe Context) -> m ()
forall a b. (a -> b) -> a -> b
$ Context -> m (Maybe Context)
forall (m :: * -> *). MonadIO m => Context -> m (Maybe Context)
attachContext Context
Context.empty
    IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
setParentSpanFromEnvironment
    m TracerProvider
-> (TracerProvider -> m ()) -> (TracerProvider -> m a) -> m a
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket (IO TracerProvider -> m TracerProvider
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO TracerProvider
initializeGlobalTracerProvider) TracerProvider -> m ()
forall (m :: * -> *). MonadIO m => TracerProvider -> m ()
shutdownTracerProvider ((TracerProvider -> m a) -> m a) -> (TracerProvider -> m a) -> m a
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
        Maybe HoneycombTarget
mTarget <-
          NominalDiffTime -> m (Maybe HoneycombTarget)
forall (m :: * -> *).
MonadIO m =>
NominalDiffTime -> m (Maybe HoneycombTarget)
Honeycomb.getOrInitializeHoneycombTargetInContext NominalDiffTime
initializationTimeout
            m (Maybe HoneycombTarget)
-> (SomeException -> m (Maybe HoneycombTarget))
-> m (Maybe HoneycombTarget)
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.
              IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (ByteString -> IO ()) -> ByteString -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> ByteString -> IO ()
BS8.hPutStrLn Handle
stderr (ByteString -> m ()) -> ByteString -> m ()
forall a b. (a -> b) -> a -> b
$ ByteString
"error setting up Honeycomb trace links: " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> (String -> ByteString
BS8.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall e. Exception e => e -> String
displayException SomeException
e)
              pure Maybe HoneycombTarget
forall a. Maybe a
Nothing

        Maybe HoneycombTarget -> m a
act Maybe HoneycombTarget
mTarget
  where
    initializationTimeout :: NominalDiffTime
initializationTimeout = Pico -> NominalDiffTime
secondsToNominalDiffTime Pico
1

globalTracer :: MonadIO m => m Tracer
globalTracer :: forall (m :: * -> *). MonadIO m => m Tracer
globalTracer = m TracerProvider
forall (m :: * -> *). MonadIO m => m TracerProvider
getGlobalTracerProvider m TracerProvider -> (TracerProvider -> m Tracer) -> m Tracer
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \TracerProvider
tp -> Tracer -> m Tracer
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tracer -> m Tracer) -> Tracer -> m Tracer
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 =
    Text -> SpanArguments -> (Span -> m a) -> m a
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 =
    Text -> SpanArguments -> (Span -> m a) -> m a
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 <- m Tracer
forall (m :: * -> *). MonadIO m => m Tracer
globalTracer
    Tracer -> Text -> SpanArguments -> (Span -> m a) -> m a
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 =
    Text -> SpanArguments -> m a -> m a
forall (m :: * -> *) a.
MonadUnliftIO m =>
Text -> SpanArguments -> m a -> m a
inSpanWith Text
spanName SpanArguments
defaultSpanArguments