Tracing.hs

{-# LANGUAGE CPP #-}

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

import Control.Monad
import Data.ByteString.Char8 qualified 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 OpenTelemetry.Trace qualified as Trace
import OpenTelemetry.Vendor.Honeycomb qualified 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 act = do
    void $ attachContext Context.empty
    liftIO setParentSpanFromEnvironment
    withTracer $ \_ -> 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
        mTarget <-
            Honeycomb.getOrInitializeHoneycombTargetInContext initializationTimeout
                `catch` \(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.
                    liftIO . BS8.hPutStrLn stderr $
                        "error setting up Honeycomb trace links: " <> (BS8.pack $ displayException e)
                    pure Nothing

        act mTarget
  where
    initializationTimeout = secondsToNominalDiffTime 1

globalTracer :: (MonadIO m) => m Tracer
globalTracer =
    getGlobalTracerProvider >>= \tp -> pure $ makeTracer tp "hotel-california" tracerOptions

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

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

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

inSpan :: (MonadUnliftIO m) => Text -> m a -> m a
inSpan spanName =
    inSpanWith spanName defaultSpanArguments

withTracer :: (MonadUnliftIO m) => (TracerProvider -> m a) -> m a
withTracer =
    bracket (liftIO initializeGlobalTracerProvider) shutdown
  where
#if MIN_VERSION_hs_opentelemetry_api(1,0,0)
    shutdown tp = shutdownTracerProvider tp Nothing
#else
    shutdown tp = shutdownTracerProvider tp
#endif