-- SPDX-FileCopyrightText: 2026 Alexandra de Wit
--
-- SPDX-License-Identifier: MIT

{- | The provider construction, the lifecycle bracket and the exporter wrappers behind
"Ecluse.Runtime.Telemetry", which documents the substrate and re-exports the curated surface.
Importing this module opts out of that stability promise, the convention @text@ and @bytestring@
use, so production code imports the public one.
-}
module Ecluse.Runtime.Telemetry.Internal (
    -- * Master switch
    TelemetrySwitch (..),
    parseTelemetrySwitch,

    -- * The telemetry handle
    Telemetry (..),
    TelemetryProviders (..),
    telemetryDisabled,
    telemetryEnabled,
    telemetryTracerProvider,
    telemetryMeterProvider,

    -- * Lifecycle
    withTelemetry,

    -- * Export-failure observation (exporter wrappers)
    observeSpanExporter,
    observeMetricExporter,
) where

import Katip (LogEnv)
import OpenTelemetry.Environment (lookupBooleanEnv)
import OpenTelemetry.Exporter.Metric (MetricExporter (..))
import OpenTelemetry.Exporter.OTLP.Span (loadExporterEnvironmentVariables, otlpExporter)
import OpenTelemetry.Exporter.Span (SpanExporter (..))
import OpenTelemetry.Log (initializeGlobalLoggerProvider, shutdownLoggerProvider)
import OpenTelemetry.Metric (
    MeterProvider (..),
    PeriodicMetricReaderHandle (..),
    createMeterProvider,
    defaultSdkMeterProviderOptions,
    forkPeriodicMetricReader,
    noopMeterProvider,
    periodicMetricReaderOptionsFromEnv,
    resolveMetricExporter,
    setGlobalMeterProvider,
    shutdownMeterProvider,
 )
import OpenTelemetry.Registry (registerSpanExporterFactory)
import OpenTelemetry.Resource (materializeResources, mergeResources, mkResource)
import OpenTelemetry.Resource.Detect (detectBuiltInResources, detectResourceAttributes)
import OpenTelemetry.SDK (OTelSignals (..))
import OpenTelemetry.Trace (TracerProvider, initializeGlobalTracerProvider, shutdownTracerProvider)
import UnliftIO (bracket)
import UnliftIO.Exception (catchAny)

import Ecluse.Runtime.Telemetry.ExportFailure (
    ExportFailureSink,
    exportFailureSink,
    installExportErrorHandler,
    observeExportResult,
 )
import Ecluse.Runtime.Telemetry.Scrape (MetricScrape, metricScrapeFor, withScrapeListener)

import Data.Universe.Class (Universe (..))
import Data.Universe.Generic (universeGeneric)

import Ecluse.Core.Wire (WireVocab (..), parseWire)

{- | The @ECLUSE_OBSERVABILITY__TELEMETRY@ master switch. Telemetry is opt-in, so
'TelemetryOff' is the default.
-}
data TelemetrySwitch
    = -- | Telemetry is disabled (the default): nothing is wired and nothing is emitted.
      TelemetryOff
    | {- | Telemetry is enabled: the SDK providers are built from the standard
      @OTEL_*@ environment and the OTLP exporter is active.
      -}
      TelemetryOn
    deriving stock (TelemetrySwitch -> TelemetrySwitch -> Bool
(TelemetrySwitch -> TelemetrySwitch -> Bool)
-> (TelemetrySwitch -> TelemetrySwitch -> Bool)
-> Eq TelemetrySwitch
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TelemetrySwitch -> TelemetrySwitch -> Bool
== :: TelemetrySwitch -> TelemetrySwitch -> Bool
$c/= :: TelemetrySwitch -> TelemetrySwitch -> Bool
/= :: TelemetrySwitch -> TelemetrySwitch -> Bool
Eq, (forall x. TelemetrySwitch -> Rep TelemetrySwitch x)
-> (forall x. Rep TelemetrySwitch x -> TelemetrySwitch)
-> Generic TelemetrySwitch
forall x. Rep TelemetrySwitch x -> TelemetrySwitch
forall x. TelemetrySwitch -> Rep TelemetrySwitch x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. TelemetrySwitch -> Rep TelemetrySwitch x
from :: forall x. TelemetrySwitch -> Rep TelemetrySwitch x
$cto :: forall x. Rep TelemetrySwitch x -> TelemetrySwitch
to :: forall x. Rep TelemetrySwitch x -> TelemetrySwitch
Generic, Int -> TelemetrySwitch -> ShowS
[TelemetrySwitch] -> ShowS
TelemetrySwitch -> String
(Int -> TelemetrySwitch -> ShowS)
-> (TelemetrySwitch -> String)
-> ([TelemetrySwitch] -> ShowS)
-> Show TelemetrySwitch
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TelemetrySwitch -> ShowS
showsPrec :: Int -> TelemetrySwitch -> ShowS
$cshow :: TelemetrySwitch -> String
show :: TelemetrySwitch -> String
$cshowList :: [TelemetrySwitch] -> ShowS
showList :: [TelemetrySwitch] -> ShowS
Show)

instance Universe TelemetrySwitch where universe :: [TelemetrySwitch]
universe = [TelemetrySwitch]
forall a. (Generic a, GUniverse (Rep a)) => [a]
universeGeneric

-- Listed @on@ before @off@: that is the order the accepted-set message names them.
instance WireVocab TelemetrySwitch where
    wireKind :: Text
wireKind = Text
"telemetry switch"
    wireTable :: NonEmpty (TelemetrySwitch, Text)
wireTable =
        (TelemetrySwitch
TelemetryOn, Text
"on")
            (TelemetrySwitch, Text)
-> [(TelemetrySwitch, Text)] -> NonEmpty (TelemetrySwitch, Text)
forall a. a -> [a] -> NonEmpty a
:| [(TelemetrySwitch
TelemetryOff, Text
"off")]

{- | Parse a 'TelemetrySwitch' from its wire name. An unrecognised value fails loudly with the
accepted set, never falling back to a mode.

>>> parseTelemetrySwitch "off"
Right TelemetryOff

>>> parseTelemetrySwitch "on"
Right TelemetryOn

>>> parseTelemetrySwitch "maybe"
Left "unknown telemetry switch \"maybe\" (expected one of: on, off)"
-}
parseTelemetrySwitch :: Text -> Either Text TelemetrySwitch
parseTelemetrySwitch :: Text -> Either Text TelemetrySwitch
parseTelemetrySwitch = Text -> Either Text TelemetrySwitch
forall a. WireVocab a => Text -> Either Text a
parseWire

{- | The telemetry handle held in the composition root: the off-by-default no-op or the enabled
providers. The disabled case carries no provider, so telemetry is inert rather than unsampled.
-}
data Telemetry
    = -- | The off-by-default no-op: no providers, nothing emitted.
      TelemetryDisabled
    | {- | The enabled handle carrying the SDK's providers, built from the standard
      @OTEL_*@ environment. The providers live in a 'TelemetryProviders' product so
      neither field is a partial record selector on this sum.
      -}
      TelemetryEnabled TelemetryProviders

{- | The SDK providers an enabled 'Telemetry' handle carries: a total product, so its
fields are not partial selectors over the 'Telemetry' sum.
-}
data TelemetryProviders = TelemetryProviders
    { TelemetryProviders -> TracerProvider
tpTracerProvider :: TracerProvider
    -- ^ The SDK tracer provider the proxy hangs spans on.
    , TelemetryProviders -> MeterProvider
tpMeterProvider :: MeterProvider
    -- ^ The SDK meter provider the proxy hangs metric instruments on.
    }

{- | The disabled telemetry handle: the off-by-default no-op that holds no providers
and emits nothing. This is what an unset @ECLUSE_OBSERVABILITY__TELEMETRY@ resolves to.
-}
telemetryDisabled :: Telemetry
telemetryDisabled :: Telemetry
telemetryDisabled = Telemetry
TelemetryDisabled

-- | Build an enabled telemetry handle from the SDK signals 'withTelemetry' brackets.
telemetryEnabled :: OTelSignals -> Telemetry
telemetryEnabled :: OTelSignals -> Telemetry
telemetryEnabled OTelSignals
signals =
    TelemetryProviders -> Telemetry
TelemetryEnabled
        TelemetryProviders
            { tpTracerProvider :: TracerProvider
tpTracerProvider = OTelSignals -> TracerProvider
otelTracerProvider OTelSignals
signals
            , tpMeterProvider :: MeterProvider
tpMeterProvider = OTelSignals -> MeterProvider
otelMeterProvider OTelSignals
signals
            }

{- | The tracer provider a 'Telemetry' handle exposes, 'Nothing' when telemetry is disabled.
'Nothing' means emit nothing, never fabricate a no-op provider at the edge.
-}
telemetryTracerProvider :: Telemetry -> Maybe TracerProvider
telemetryTracerProvider :: Telemetry -> Maybe TracerProvider
telemetryTracerProvider = \case
    Telemetry
TelemetryDisabled -> Maybe TracerProvider
forall a. Maybe a
Nothing
    TelemetryEnabled TelemetryProviders
providers -> TracerProvider -> Maybe TracerProvider
forall a. a -> Maybe a
Just (TelemetryProviders -> TracerProvider
tpTracerProvider TelemetryProviders
providers)

{- | The meter provider a 'Telemetry' handle exposes, 'Nothing' when telemetry is
disabled (the dual of 'telemetryTracerProvider' for metric instruments).
-}
telemetryMeterProvider :: Telemetry -> Maybe MeterProvider
telemetryMeterProvider :: Telemetry -> Maybe MeterProvider
telemetryMeterProvider = \case
    Telemetry
TelemetryDisabled -> Maybe MeterProvider
forall a. Maybe a
Nothing
    TelemetryEnabled TelemetryProviders
providers -> MeterProvider -> Maybe MeterProvider
forall a. a -> Maybe a
Just (TelemetryProviders -> MeterProvider
tpMeterProvider TelemetryProviders
providers)

{- | Run an action with a 'Telemetry' handle bracketed by the 'TelemetrySwitch'. 'TelemetryOff'
opens nothing. 'TelemetryOn' builds the providers, runs the scrape listener, and tears both down.
-}
withTelemetry :: TelemetrySwitch -> LogEnv -> (Telemetry -> IO a) -> IO a
withTelemetry :: forall a. TelemetrySwitch -> LogEnv -> (Telemetry -> IO a) -> IO a
withTelemetry TelemetrySwitch
switch LogEnv
logEnv Telemetry -> IO a
use = case TelemetrySwitch
switch of
    TelemetrySwitch
TelemetryOff -> Telemetry -> IO a
use Telemetry
telemetryDisabled
    TelemetrySwitch
TelemetryOn -> do
        sink <- LogEnv -> IO ExportFailureSink
exportFailureSink LogEnv
logEnv
        installExportErrorHandler sink
        registerObservedSpanExporter sink
        bracket (initializeObservedOpenTelemetry sink) (otelShutdown . fst) $ \(OTelSignals
signals, Maybe MetricScrape
scrape) ->
            LogEnv -> Maybe MetricScrape -> IO a -> IO a
forall a. LogEnv -> Maybe MetricScrape -> IO a -> IO a
withScrapeListener LogEnv
logEnv Maybe MetricScrape
scrape (Telemetry -> IO a
use (OTelSignals -> Telemetry
telemetryEnabled OTelSignals
signals))

{- Wrap the OTLP span exporter so a failed export is observed: @hs-opentelemetry@ 1.0.0.0
discards the 'ExportResult' in the batch processor, so the failure is otherwise invisible. -}
observeSpanExporter :: ExportFailureSink -> SpanExporter -> SpanExporter
observeSpanExporter :: ExportFailureSink -> SpanExporter -> SpanExporter
observeSpanExporter ExportFailureSink
sink SpanExporter
inner =
    SpanExporter
inner
        { spanExporterExport = \HashMap InstrumentationLibrary (Vector ImmutableSpan)
completedSpans -> do
            result <- SpanExporter
-> HashMap InstrumentationLibrary (Vector ImmutableSpan)
-> IO ExportResult
spanExporterExport SpanExporter
inner HashMap InstrumentationLibrary (Vector ImmutableSpan)
completedSpans
            observeExportResult sink "span" result
            pure result
        }

-- Dual of 'observeSpanExporter' for the periodic metric reader's exporter (which likewise
-- discards the 'ExportResult').
observeMetricExporter :: ExportFailureSink -> MetricExporter -> MetricExporter
observeMetricExporter :: ExportFailureSink -> MetricExporter -> MetricExporter
observeMetricExporter ExportFailureSink
sink MetricExporter
inner =
    MetricExporter
inner
        { metricExporterExport = \Vector ResourceMetricsExport
batches -> do
            result <- MetricExporter -> Vector ResourceMetricsExport -> IO ExportResult
metricExporterExport MetricExporter
inner Vector ResourceMetricsExport
batches
            observeExportResult sink "metric" result
            pure result
        }

{- Register the observed OTLP span exporter under the @otlp@ key before the SDK's env-driven
tracer init runs: the registry prefers a registered factory over the built-in default. -}
registerObservedSpanExporter :: ExportFailureSink -> IO ()
registerObservedSpanExporter :: ExportFailureSink -> IO ()
registerObservedSpanExporter ExportFailureSink
sink =
    Text -> IO SpanExporter -> IO ()
registerSpanExporterFactory
        Text
"otlp"
        (ExportFailureSink -> SpanExporter -> SpanExporter
observeSpanExporter ExportFailureSink
sink (SpanExporter -> SpanExporter)
-> IO SpanExporter -> IO SpanExporter
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (OTLPExporterConfig -> IO SpanExporter
forall (m :: * -> *).
MonadIO m =>
OTLPExporterConfig -> m SpanExporter
otlpExporter (OTLPExporterConfig -> IO SpanExporter)
-> IO OTLPExporterConfig -> IO SpanExporter
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO OTLPExporterConfig
forall (m :: * -> *). MonadIO m => m OTLPExporterConfig
loadExporterEnvironmentVariables))

{- Mirror @hs-opentelemetry-sdk@ 1.0.0.0's @initializeOpenTelemetry@. The tracer reads the
registry, so 'registerObservedSpanExporter' runs first. Re-diff against the SDK on a bump. -}
initializeObservedOpenTelemetry :: ExportFailureSink -> IO (OTelSignals, Maybe MetricScrape)
initializeObservedOpenTelemetry :: ExportFailureSink -> IO (OTelSignals, Maybe MetricScrape)
initializeObservedOpenTelemetry ExportFailureSink
sink = do
    tracerProvider <- IO TracerProvider
initializeGlobalTracerProvider
    (meterProvider, scrape) <- initializeObservedMeterProvider sink
    loggerProvider <- initializeGlobalLoggerProvider
    let shutdown = do
            IO ShutdownResult -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (TracerProvider -> Maybe Int -> IO ShutdownResult
forall (m :: * -> *).
MonadIO m =>
TracerProvider -> Maybe Int -> m ShutdownResult
shutdownTracerProvider TracerProvider
tracerProvider Maybe Int
forall a. Maybe a
Nothing) IO () -> (SomeException -> IO ()) -> IO ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
`catchAny` IO () -> SomeException -> IO ()
forall a b. a -> b -> a
const IO ()
forall (f :: * -> *). Applicative f => f ()
pass
            IO ShutdownResult -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (MeterProvider -> Maybe Int -> IO ShutdownResult
shutdownMeterProvider MeterProvider
meterProvider Maybe Int
forall a. Maybe a
Nothing) IO () -> (SomeException -> IO ()) -> IO ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
`catchAny` IO () -> SomeException -> IO ()
forall a b. a -> b -> a
const IO ()
forall (f :: * -> *). Applicative f => f ()
pass
            IO ShutdownResult -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (LoggerProvider -> Maybe Int -> IO ShutdownResult
forall (m :: * -> *).
MonadIO m =>
LoggerProvider -> Maybe Int -> m ShutdownResult
shutdownLoggerProvider LoggerProvider
loggerProvider Maybe Int
forall a. Maybe a
Nothing) IO () -> (SomeException -> IO ()) -> IO ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
`catchAny` IO () -> SomeException -> IO ()
forall a b. a -> b -> a
const IO ()
forall (f :: * -> *). Applicative f => f ()
pass
    pure
        ( OTelSignals
            { otelTracerProvider = tracerProvider
            , otelMeterProvider = meterProvider
            , otelLoggerProvider = loggerProvider
            , otelPropagators = mempty
            , otelShutdown = shutdown
            }
        , scrape
        )

{- Mirror @hs-opentelemetry-sdk@ 1.0.0.0's @initializeGlobalMeterProvider@, observing the metric
exporter's failures and lifting the meter environment out for the scrape. Re-diff on a bump. -}
initializeObservedMeterProvider :: ExportFailureSink -> IO (MeterProvider, Maybe MetricScrape)
initializeObservedMeterProvider :: ExportFailureSink -> IO (MeterProvider, Maybe MetricScrape)
initializeObservedMeterProvider ExportFailureSink
sink = do
    disabled <- String -> IO Bool
lookupBooleanEnv String
"OTEL_SDK_DISABLED"
    if disabled
        then (noopMeterProvider, Nothing) <$ setGlobalMeterProvider noopMeterProvider
        else do
            exporter <- observeMetricExporter sink <$> resolveMetricExporter
            readerOptions <- periodicMetricReaderOptionsFromEnv
            builtInResources <- detectBuiltInResources
            envResources <- mkResource . map Just <$> detectResourceAttributes
            let resources = Resource -> MaterializedResources
materializeResources (Resource -> Resource -> Resource
mergeResources Resource
envResources Resource
builtInResources)
            (provider, env) <- createMeterProvider resources defaultSdkMeterProviderOptions
            readerHandle <- forkPeriodicMetricReader env exporter readerOptions
            let provider' = PeriodicMetricReaderHandle -> MeterProvider -> MeterProvider
stopReaderOnShutdown PeriodicMetricReaderHandle
readerHandle MeterProvider
provider
            setGlobalMeterProvider provider'
            scrape <- metricScrapeFor env
            pure (provider', scrape)

{- Mirrors the SDK's own shutdown ordering, and is part of the same version-pin re-diff
surface as 'initializeObservedMeterProvider'. -}
stopReaderOnShutdown :: PeriodicMetricReaderHandle -> MeterProvider -> MeterProvider
stopReaderOnShutdown :: PeriodicMetricReaderHandle -> MeterProvider -> MeterProvider
stopReaderOnShutdown PeriodicMetricReaderHandle
readerHandle MeterProvider
provider =
    MeterProvider
provider
        { meterProviderShutdown = \Maybe Int
timeout -> do
            PeriodicMetricReaderHandle -> IO ()
stopPeriodicMetricReader PeriodicMetricReaderHandle
readerHandle
            MeterProvider -> Maybe Int -> IO ShutdownResult
meterProviderShutdown MeterProvider
provider Maybe Int
timeout
        }