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

{- | The throttle and the sink behind "Ecluse.Runtime.Telemetry.ExportFailure", which documents
the routing 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.ExportFailure.Internal (
    -- * The throttle (pure core)
    ThrottleState (..),
    ThrottleEmit (..),
    initialThrottle,
    throttleStep,

    -- * Routing
    ExportFailureSink,
    newExportFailureSink,
    exportFailureSink,
    observeExportResult,
    installExportErrorHandler,
) where

import Data.Time (NominalDiffTime, UTCTime, diffUTCTime, getCurrentTime)

import Katip (LogEnv, Severity (WarningS))
import OpenTelemetry.Exporter.Span (ExportResult (..))
import OpenTelemetry.Internal.Logging (setGlobalErrorHandler)

import Ecluse.Runtime.Log (moduleLog)

{- | The throttle state for SDK export-error routing. Exposed so a test asserts the throttle
decision without wall-clock timing.
-}
data ThrottleState = ThrottleState
    { ThrottleState -> Maybe UTCTime
tsLastLogged :: Maybe UTCTime
    -- ^ When an error was last surfaced ('Nothing' before the first).
    , ThrottleState -> Int
tsSuppressed :: Int
    -- ^ Errors suppressed since the last surfaced one.
    }
    deriving stock (ThrottleState -> ThrottleState -> Bool
(ThrottleState -> ThrottleState -> Bool)
-> (ThrottleState -> ThrottleState -> Bool) -> Eq ThrottleState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ThrottleState -> ThrottleState -> Bool
== :: ThrottleState -> ThrottleState -> Bool
$c/= :: ThrottleState -> ThrottleState -> Bool
/= :: ThrottleState -> ThrottleState -> Bool
Eq, Int -> ThrottleState -> ShowS
[ThrottleState] -> ShowS
ThrottleState -> String
(Int -> ThrottleState -> ShowS)
-> (ThrottleState -> String)
-> ([ThrottleState] -> ShowS)
-> Show ThrottleState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ThrottleState -> ShowS
showsPrec :: Int -> ThrottleState -> ShowS
$cshow :: ThrottleState -> String
show :: ThrottleState -> String
$cshowList :: [ThrottleState] -> ShowS
showList :: [ThrottleState] -> ShowS
Show)

-- | What 'throttleStep' decided to do with an export error.
data ThrottleEmit
    = -- | The first error: surface it plainly.
      EmitFirst
    | {- | The throttle window elapsed: surface a heartbeat carrying the count of
      errors since the last surfaced one (this one included).
      -}
      EmitHeartbeat Int
    | -- | Within the window: suppress and count.
      EmitSuppress
    deriving stock (ThrottleEmit -> ThrottleEmit -> Bool
(ThrottleEmit -> ThrottleEmit -> Bool)
-> (ThrottleEmit -> ThrottleEmit -> Bool) -> Eq ThrottleEmit
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ThrottleEmit -> ThrottleEmit -> Bool
== :: ThrottleEmit -> ThrottleEmit -> Bool
$c/= :: ThrottleEmit -> ThrottleEmit -> Bool
/= :: ThrottleEmit -> ThrottleEmit -> Bool
Eq, Int -> ThrottleEmit -> ShowS
[ThrottleEmit] -> ShowS
ThrottleEmit -> String
(Int -> ThrottleEmit -> ShowS)
-> (ThrottleEmit -> String)
-> ([ThrottleEmit] -> ShowS)
-> Show ThrottleEmit
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ThrottleEmit -> ShowS
showsPrec :: Int -> ThrottleEmit -> ShowS
$cshow :: ThrottleEmit -> String
show :: ThrottleEmit -> String
$cshowList :: [ThrottleEmit] -> ShowS
showList :: [ThrottleEmit] -> ShowS
Show)

-- | The initial throttle state: nothing logged, nothing suppressed.
initialThrottle :: ThrottleState
initialThrottle :: ThrottleState
initialThrottle = Maybe UTCTime -> Int -> ThrottleState
ThrottleState Maybe UTCTime
forall a. Maybe a
Nothing Int
0

-- How long export errors are coalesced between surfaced heartbeats.
throttleInterval :: NominalDiffTime
throttleInterval :: NominalDiffTime
throttleInterval = NominalDiffTime
60

{- | Advance the throttle for one export error at @now@: the first surfaces, a heartbeat once
@interval@ has elapsed since the last surfaced error, and anything between is suppressed and counted.
-}
throttleStep :: NominalDiffTime -> UTCTime -> ThrottleState -> (ThrottleState, ThrottleEmit)
throttleStep :: NominalDiffTime
-> UTCTime -> ThrottleState -> (ThrottleState, ThrottleEmit)
throttleStep NominalDiffTime
interval UTCTime
now ThrottleState
st = case ThrottleState -> Maybe UTCTime
tsLastLogged ThrottleState
st of
    Maybe UTCTime
Nothing -> (Maybe UTCTime -> Int -> ThrottleState
ThrottleState (UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just UTCTime
now) Int
0, ThrottleEmit
EmitFirst)
    Just UTCTime
lastLogged
        | UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
now UTCTime
lastLogged NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
>= NominalDiffTime
interval ->
            (Maybe UTCTime -> Int -> ThrottleState
ThrottleState (UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just UTCTime
now) Int
0, Int -> ThrottleEmit
EmitHeartbeat (ThrottleState -> Int
tsSuppressed ThrottleState
st Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1))
        | Bool
otherwise ->
            (ThrottleState
st{tsSuppressed = tsSuppressed st + 1}, ThrottleEmit
EmitSuppress)

{- | One throttle and one @katip@ target shared by every export-failure feed. The clock and the
surfacing action are injected, so a test asserts the throttle decision without wall-clock timing.
-}
data ExportFailureSink = ExportFailureSink
    { ExportFailureSink -> IO UTCTime
sinkNow :: IO UTCTime
    , ExportFailureSink -> IORef ThrottleState
sinkState :: IORef ThrottleState
    , ExportFailureSink -> Severity -> Text -> IO ()
sinkSurface :: Severity -> Text -> IO ()
    }

-- | Build an export-failure sink over an injected clock and surfacing action.
newExportFailureSink :: IO UTCTime -> (Severity -> Text -> IO ()) -> IO ExportFailureSink
newExportFailureSink :: IO UTCTime -> (Severity -> Text -> IO ()) -> IO ExportFailureSink
newExportFailureSink IO UTCTime
now Severity -> Text -> IO ()
surface = do
    throttleRef <- ThrottleState -> IO (IORef ThrottleState)
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef ThrottleState
initialThrottle
    pure ExportFailureSink{sinkNow = now, sinkState = throttleRef, sinkSurface = surface}

-- | The production sink: the wall clock and the composition-root 'LogEnv' as the @katip@ target.
exportFailureSink :: LogEnv -> IO ExportFailureSink
exportFailureSink :: LogEnv -> IO ExportFailureSink
exportFailureSink LogEnv
logEnv = IO UTCTime -> (Severity -> Text -> IO ()) -> IO ExportFailureSink
newExportFailureSink IO UTCTime
getCurrentTime (LogEnv -> Text -> Severity -> Text -> IO ()
moduleLog LogEnv
logEnv Text
sinkModule)

-- The @module@ field these lines carry. Operators filter on it, so it names the resolver that
-- owns the telemetry configuration rather than this module.
sinkModule :: Text
sinkModule :: Text
sinkModule = Text
"Ecluse.Runtime.Telemetry.Resolve"

{- Route one export-failure diagnostic through the shared throttle into @katip@. The first
error surfaces plainly and later ones fold into a heartbeat carrying the suppressed count. -}
routeExportFailure :: ExportFailureSink -> Text -> IO ()
routeExportFailure :: ExportFailureSink -> Text -> IO ()
routeExportFailure ExportFailureSink
sink Text
diagnostic = do
    now <- ExportFailureSink -> IO UTCTime
sinkNow ExportFailureSink
sink
    emit <- atomicModifyIORef' (sinkState sink) (throttleStep throttleInterval now)
    case emit of
        ThrottleEmit
EmitFirst -> ExportFailureSink -> Severity -> Text -> IO ()
sinkSurface ExportFailureSink
sink Severity
WarningS (Text -> Text
firstErrorMessage Text
diagnostic)
        EmitHeartbeat Int
suppressed -> ExportFailureSink -> Severity -> Text -> IO ()
sinkSurface ExportFailureSink
sink Severity
WarningS (Int -> Text -> Text
heartbeatMessage Int
suppressed Text
diagnostic)
        ThrottleEmit
EmitSuppress -> IO ()
forall (f :: * -> *). Applicative f => f ()
pass

{- | Observe one exporter's 'ExportResult', routing a 'Failure' through the sink. @signal@ names the
exporter (@span@ \/ @metric@). @hs-opentelemetry 1.0.0.0@ drops a failed OTLP export, so only this feed reports one.
-}
observeExportResult :: ExportFailureSink -> Text -> ExportResult -> IO ()
observeExportResult :: ExportFailureSink -> Text -> ExportResult -> IO ()
observeExportResult ExportFailureSink
sink Text
signal = \case
    ExportResult
Success -> IO ()
forall (f :: * -> *). Applicative f => f ()
pass
    Failure Maybe SomeException
mErr -> ExportFailureSink -> Text -> IO ()
routeExportFailure ExportFailureSink
sink (Text
signal Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" export failed" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> (SomeException -> Text) -> Maybe SomeException -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" ((Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text) -> (SomeException -> Text) -> SomeException -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> Text
forall b a. (Show a, IsString b) => a -> b
show) Maybe SomeException
mErr)

{- | Install a process-global handler for the SDK's own diagnostic stream, forwarded verbatim. Ecluse
reads none of @OTEL_EXPORTER_OTLP_HEADERS@, @DD_API_KEY@, @DD_SITE@, so the SDK's own text is the only leak channel.
-}
installExportErrorHandler :: ExportFailureSink -> IO ()
installExportErrorHandler :: ExportFailureSink -> IO ()
installExportErrorHandler ExportFailureSink
sink = (String -> IO ()) -> IO ()
setGlobalErrorHandler (ExportFailureSink -> Text -> IO ()
routeExportFailure ExportFailureSink
sink (Text -> IO ()) -> (String -> Text) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
forall a. ToText a => a -> Text
toText)

firstErrorMessage :: Text -> Text
firstErrorMessage :: Text -> Text
firstErrorMessage Text
diagnostic =
    Text
"telemetry export error (subsequent identical errors are throttled): " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
diagnostic

heartbeatMessage :: Int -> Text -> Text
heartbeatMessage :: Int -> Text -> Text
heartbeatMessage Int
suppressed Text
diagnostic =
    Text
"telemetry export still failing: "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall b a. (Show a, IsString b) => a -> b
show Int
suppressed
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" export errors since the last report. Latest: "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
diagnostic