-- SPDX-FileCopyrightText: 2026 Alexandra de Wit
--
-- SPDX-License-Identifier: MIT
{-# LANGUAGE RankNTypes #-}

{- | The middleware, the manager settings, the domain-span brackets and the attribute mappings
behind "Ecluse.Runtime.Telemetry.Tracing", which documents the tracing layer 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.Tracing.Internal (
    -- * WAI server span
    telemetryWaiMiddleware,

    -- * http-client data-plane instrumentation
    instrumentDataPlaneManagerSettings,
    dataPlaneInstrumentationConfig,

    -- * Domain spans
    withRuleEvalSpan,
    withMirrorEnqueueSpan,
    withMirrorJobSpan,
    withAdvisorySyncSpan,
    JobSpanOutcome (..),

    -- * The core tracing ports
    tracingPortOf,
    workerTracingPortOf,
    advisorySyncTracingPortOf,

    -- * Verdict attribute mapping
    ruleVerdictFields,
) where

import Network.HTTP.Client (ManagerSettings)
import Network.Wai (Middleware)
import OpenTelemetry.Instrumentation.HttpClient (
    HttpClientInstrumentationConfig,
    httpClientInstrumentationConfig,
    instrumentManagerSettings,
 )
import OpenTelemetry.Instrumentation.Wai (newOpenTelemetryWaiMiddleware')
import OpenTelemetry.Metric.Core (getMeter)
import OpenTelemetry.Propagator.W3CTraceContext (decodeSpanContext, encodeSpanContext)
import OpenTelemetry.Trace (
    NewLink (NewLink, linkAttributes, linkContext),
    Span,
    SpanArguments (kind, links),
    SpanKind (Client, Consumer, Internal, Producer),
    SpanStatus (Error),
    addAttribute,
    defaultSpanArguments,
    inSpan',
    makeTracer,
    setStatus,
    tracerOptions,
 )
import UnliftIO (MonadUnliftIO, withRunInIO)

import Ecluse.Core.Ecosystem (Ecosystem, ecosystemName)
import Ecluse.Core.Package (PackageName, renderPackageName)
import Ecluse.Core.Queue (RemoteSpanContext (RemoteSpanContext, rscTraceparent, rscTracestate))
import Ecluse.Core.Security.Authority (authorityLabel)
import Ecluse.Core.Server.Response (
    RejectReason (BelowIntegrityFloor, ByPolicy, MissingIntegrity, Unavailable, UpstreamInvalid),
    Rejection (rejectionMessage, rejectionReason),
    RuleName (RuleName),
    ServeDecision (Admit, Reject),
 )
import Ecluse.Core.Telemetry.Metrics (AdvisorySyncResult, advisorySyncResultName)
import Ecluse.Core.Telemetry.Span (AdvisorySyncTracingPort (..), JobSpanOutcome (..), TracingPort (..), WorkerTracingPort (..), ecluseScope)
import Ecluse.Core.Version (Version, renderVersion)
import Ecluse.Runtime.Telemetry (
    Telemetry,
    telemetryMeterProvider,
    telemetryTracerProvider,
 )

{- | Build the WAI server-span middleware, or 'id' when telemetry is disabled. It belongs
__outermost__ in the stack, so the span covers the whole request (see "Ecluse.Runtime.Server").
-}
telemetryWaiMiddleware :: Telemetry -> IO Middleware
telemetryWaiMiddleware :: Telemetry -> IO Middleware
telemetryWaiMiddleware Telemetry
telemetry =
    case (Telemetry -> Maybe TracerProvider
telemetryTracerProvider Telemetry
telemetry, Telemetry -> Maybe MeterProvider
telemetryMeterProvider Telemetry
telemetry) of
        (Just TracerProvider
tracerProvider, Just MeterProvider
meterProvider) -> do
            meter <- MeterProvider -> InstrumentationLibrary -> IO Meter
getMeter MeterProvider
meterProvider InstrumentationLibrary
forall s. IsString s => s
ecluseScope
            newOpenTelemetryWaiMiddleware' tracerProvider meter
        (Maybe TracerProvider, Maybe MeterProvider)
_ -> Middleware -> IO Middleware
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Middleware
forall a. a -> a
id

{- | Instrument a data-plane 'ManagerSettings' so upstream fetches open a client span and carry
W3C trace-context headers. Return the settings untouched when telemetry is disabled.
-}
instrumentDataPlaneManagerSettings :: Telemetry -> ManagerSettings -> IO ManagerSettings
instrumentDataPlaneManagerSettings :: Telemetry -> ManagerSettings -> IO ManagerSettings
instrumentDataPlaneManagerSettings Telemetry
telemetry ManagerSettings
settings =
    case Telemetry -> Maybe TracerProvider
telemetryTracerProvider Telemetry
telemetry of
        Maybe TracerProvider
Nothing -> ManagerSettings -> IO ManagerSettings
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ManagerSettings
settings
        Just TracerProvider
_ -> HttpClientInstrumentationConfig
-> ManagerSettings -> IO ManagerSettings
instrumentManagerSettings HttpClientInstrumentationConfig
dataPlaneInstrumentationConfig ManagerSettings
settings

{- | The http-client instrumentation configuration for the data plane. It records __no__ request
or response headers, so an @Authorization@ header never reaches a span.
-}
dataPlaneInstrumentationConfig :: HttpClientInstrumentationConfig
dataPlaneInstrumentationConfig :: HttpClientInstrumentationConfig
dataPlaneInstrumentationConfig = HttpClientInstrumentationConfig
httpClientInstrumentationConfig

{- | Run a rule-evaluation domain span around an action that yields its result and the verdict to
record ('ruleVerdictFields').
-}
withRuleEvalSpan ::
    (MonadUnliftIO m) =>
    Telemetry ->
    PackageName ->
    Version ->
    m (a, ServeDecision) ->
    m a
withRuleEvalSpan :: forall (m :: * -> *) a.
MonadUnliftIO m =>
Telemetry -> PackageName -> Version -> m (a, ServeDecision) -> m a
withRuleEvalSpan Telemetry
telemetry PackageName
name Version
version m (a, ServeDecision)
action =
    Telemetry
-> SpanKind -> [NewLink] -> Text -> (Maybe Span -> m a) -> m a
forall (m :: * -> *) a.
MonadUnliftIO m =>
Telemetry
-> SpanKind -> [NewLink] -> Text -> (Maybe Span -> m a) -> m a
withDomainSpan Telemetry
telemetry SpanKind
Internal [] Text
"ecluse.rule.eval" ((Maybe Span -> m a) -> m a) -> (Maybe Span -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \Maybe Span
mSpan -> do
        Maybe Span -> [(Text, Text)] -> m ()
forall (m :: * -> *).
MonadIO m =>
Maybe Span -> [(Text, Text)] -> m ()
recordFields Maybe Span
mSpan (PackageName -> Version -> [(Text, Text)]
coordinateFields PackageName
name Version
version)
        (result, verdict) <- m (a, ServeDecision)
action
        recordFields mSpan (ruleVerdictFields verdict)
        pure result

{- | Run a mirror-enqueue 'Producer' span, handing the body this span's trace context to stamp onto
the job. It records the artifact authority alone: a URL can carry a credential in userinfo or query.
-}
withMirrorEnqueueSpan ::
    (MonadUnliftIO m) =>
    Telemetry ->
    PackageName ->
    Version ->
    Text ->
    (a -> Maybe Text) ->
    (Maybe RemoteSpanContext -> m a) ->
    m a
withMirrorEnqueueSpan :: forall (m :: * -> *) a.
MonadUnliftIO m =>
Telemetry
-> PackageName
-> Version
-> Text
-> (a -> Maybe Text)
-> (Maybe RemoteSpanContext -> m a)
-> m a
withMirrorEnqueueSpan Telemetry
telemetry PackageName
name Version
version Text
artifactUrl a -> Maybe Text
project Maybe RemoteSpanContext -> m a
body =
    Telemetry
-> SpanKind -> [NewLink] -> Text -> (Maybe Span -> m a) -> m a
forall (m :: * -> *) a.
MonadUnliftIO m =>
Telemetry
-> SpanKind -> [NewLink] -> Text -> (Maybe Span -> m a) -> m a
withDomainSpan Telemetry
telemetry SpanKind
Producer [] Text
"ecluse.mirror.enqueue" ((Maybe Span -> m a) -> m a) -> (Maybe Span -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \Maybe Span
mSpan -> do
        Maybe Span -> [(Text, Text)] -> m ()
forall (m :: * -> *).
MonadIO m =>
Maybe Span -> [(Text, Text)] -> m ()
recordFields Maybe Span
mSpan (PackageName -> Version -> [(Text, Text)]
coordinateFields PackageName
name Version
version [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
forall a. Semigroup a => a -> a -> a
<> [(Text
"ecluse.mirror.artifact_host", Text -> Text
authorityLabel Text
artifactUrl)])
        carrier <- (Span -> m RemoteSpanContext)
-> Maybe Span -> m (Maybe RemoteSpanContext)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse Span -> m RemoteSpanContext
forall (m :: * -> *). MonadIO m => Span -> m RemoteSpanContext
captureRemoteContext Maybe Span
mSpan
        result <- body carrier
        whenJust mSpan $ \Span
theSpan -> Maybe Text -> (Text -> m ()) -> m ()
forall (f :: * -> *) a.
Applicative f =>
Maybe a -> (a -> f ()) -> f ()
whenJust (a -> Maybe Text
project a
result) (Span -> SpanStatus -> m ()
forall (m :: * -> *). MonadIO m => Span -> SpanStatus -> m ()
setStatus Span
theSpan (SpanStatus -> m ()) -> (Text -> SpanStatus) -> Text -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> SpanStatus
Error)
        pure result

{- | Run a mirror-worker-job 'Consumer' span around the worker's fetch, verify, and publish,
linking back to the enqueueing producer span through the carried trace context.
-}
withMirrorJobSpan ::
    (MonadUnliftIO m) =>
    Telemetry ->
    PackageName ->
    Version ->
    Maybe RemoteSpanContext ->
    (a -> JobSpanOutcome) ->
    m a ->
    m a
withMirrorJobSpan :: forall (m :: * -> *) a.
MonadUnliftIO m =>
Telemetry
-> PackageName
-> Version
-> Maybe RemoteSpanContext
-> (a -> JobSpanOutcome)
-> m a
-> m a
withMirrorJobSpan Telemetry
telemetry PackageName
name Version
version Maybe RemoteSpanContext
remoteContext a -> JobSpanOutcome
project m a
action =
    Telemetry
-> SpanKind -> [NewLink] -> Text -> (Maybe Span -> m a) -> m a
forall (m :: * -> *) a.
MonadUnliftIO m =>
Telemetry
-> SpanKind -> [NewLink] -> Text -> (Maybe Span -> m a) -> m a
withDomainSpan Telemetry
telemetry SpanKind
Consumer (Maybe RemoteSpanContext -> [NewLink]
mirrorJobLinks Maybe RemoteSpanContext
remoteContext) Text
"ecluse.mirror.job" ((Maybe Span -> m a) -> m a) -> (Maybe Span -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \Maybe Span
mSpan -> do
        Maybe Span -> [(Text, Text)] -> m ()
forall (m :: * -> *).
MonadIO m =>
Maybe Span -> [(Text, Text)] -> m ()
recordFields Maybe Span
mSpan (PackageName -> Version -> [(Text, Text)]
coordinateFields PackageName
name Version
version)
        result <- m a
action
        let JobSpanOutcome label mDetail = project result
        recordFields mSpan [("ecluse.mirror.outcome", label)]
        whenJust mSpan $ \Span
theSpan -> Maybe Text -> (Text -> m ()) -> m ()
forall (f :: * -> *) a.
Applicative f =>
Maybe a -> (a -> f ()) -> f ()
whenJust Maybe Text
mDetail (Span -> SpanStatus -> m ()
forall (m :: * -> *). MonadIO m => Span -> SpanStatus -> m ()
setStatus Span
theSpan (SpanStatus -> m ()) -> (Text -> SpanStatus) -> Text -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> SpanStatus
Error)
        pure result

{- | Run an advisory-sync 'Internal' span around one sync attempt. The ecosystem and the result are
the vocabulary the @ecluse.advisory.sync.*@ metrics label with, so a trace and a series join on one.
-}
withAdvisorySyncSpan ::
    (MonadUnliftIO m) =>
    Telemetry ->
    Ecosystem ->
    (a -> AdvisorySyncResult) ->
    m a ->
    m a
withAdvisorySyncSpan :: forall (m :: * -> *) a.
MonadUnliftIO m =>
Telemetry -> Ecosystem -> (a -> AdvisorySyncResult) -> m a -> m a
withAdvisorySyncSpan Telemetry
telemetry Ecosystem
eco a -> AdvisorySyncResult
project m a
action =
    Telemetry
-> SpanKind -> [NewLink] -> Text -> (Maybe Span -> m a) -> m a
forall (m :: * -> *) a.
MonadUnliftIO m =>
Telemetry
-> SpanKind -> [NewLink] -> Text -> (Maybe Span -> m a) -> m a
withDomainSpan Telemetry
telemetry SpanKind
Internal [] Text
"ecluse.advisory.sync.attempt" ((Maybe Span -> m a) -> m a) -> (Maybe Span -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \Maybe Span
mSpan -> do
        Maybe Span -> [(Text, Text)] -> m ()
forall (m :: * -> *).
MonadIO m =>
Maybe Span -> [(Text, Text)] -> m ()
recordFields Maybe Span
mSpan [(Text
"ecluse.ecosystem", Ecosystem -> Text
ecosystemName Ecosystem
eco)]
        result <- m a
action
        recordFields mSpan [("ecluse.advisory.sync.result", advisorySyncResultName (project result))]
        pure result

-- A domain span over one package alone: the packument gate and the two metadata legs.
withPackageSpan :: (MonadUnliftIO m) => Telemetry -> SpanKind -> Text -> PackageName -> m a -> m a
withPackageSpan :: forall (m :: * -> *) a.
MonadUnliftIO m =>
Telemetry -> SpanKind -> Text -> PackageName -> m a -> m a
withPackageSpan Telemetry
telemetry SpanKind
spanKind Text
spanName PackageName
name m a
action =
    Telemetry
-> SpanKind -> [NewLink] -> Text -> (Maybe Span -> m a) -> m a
forall (m :: * -> *) a.
MonadUnliftIO m =>
Telemetry
-> SpanKind -> [NewLink] -> Text -> (Maybe Span -> m a) -> m a
withDomainSpan Telemetry
telemetry SpanKind
spanKind [] Text
spanName ((Maybe Span -> m a) -> m a) -> (Maybe Span -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \Maybe Span
mSpan -> do
        Maybe Span -> [(Text, Text)] -> m ()
forall (m :: * -> *).
MonadIO m =>
Maybe Span -> [(Text, Text)] -> m ()
recordFields Maybe Span
mSpan [(Text
"ecluse.package", PackageName -> Text
renderPackageName PackageName
name)]
        m a
action

-- | Project this module's serve-path spans onto the core 'TracingPort' the pipeline brackets with.
tracingPortOf :: Telemetry -> TracingPort
tracingPortOf :: Telemetry -> TracingPort
tracingPortOf Telemetry
telemetry =
    TracingPort
        { spanRuleEval :: forall a. PackageName -> Version -> IO (a, ServeDecision) -> IO a
spanRuleEval = Telemetry
-> PackageName -> Version -> IO (a, ServeDecision) -> IO a
forall (m :: * -> *) a.
MonadUnliftIO m =>
Telemetry -> PackageName -> Version -> m (a, ServeDecision) -> m a
withRuleEvalSpan Telemetry
telemetry
        , spanMirrorEnqueue :: forall a.
PackageName
-> Version
-> Text
-> (a -> Maybe Text)
-> (Maybe RemoteSpanContext -> IO a)
-> IO a
spanMirrorEnqueue = \PackageName
n Version
v Text
url a -> Maybe Text
ok Maybe RemoteSpanContext -> IO a
action -> ((forall a. IO a -> IO a) -> IO a) -> IO a
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. IO a -> IO a) -> IO a) -> IO a)
-> ((forall a. IO a -> IO a) -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
runInIO ->
            Telemetry
-> PackageName
-> Version
-> Text
-> (a -> Maybe Text)
-> (Maybe RemoteSpanContext -> IO a)
-> IO a
forall (m :: * -> *) a.
MonadUnliftIO m =>
Telemetry
-> PackageName
-> Version
-> Text
-> (a -> Maybe Text)
-> (Maybe RemoteSpanContext -> m a)
-> m a
withMirrorEnqueueSpan Telemetry
telemetry PackageName
n Version
v Text
url a -> Maybe Text
ok (IO a -> IO a
forall a. IO a -> IO a
runInIO (IO a -> IO a)
-> (Maybe RemoteSpanContext -> IO a)
-> Maybe RemoteSpanContext
-> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe RemoteSpanContext -> IO a
action)
        , spanPackumentGate :: forall a. PackageName -> IO a -> IO a
spanPackumentGate = \PackageName
n IO a
action -> ((forall a. IO a -> IO a) -> IO a) -> IO a
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. IO a -> IO a) -> IO a) -> IO a)
-> ((forall a. IO a -> IO a) -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
runInIO ->
            Telemetry -> SpanKind -> Text -> PackageName -> IO a -> IO a
forall (m :: * -> *) a.
MonadUnliftIO m =>
Telemetry -> SpanKind -> Text -> PackageName -> m a -> m a
withPackageSpan Telemetry
telemetry SpanKind
Internal Text
"ecluse.packument.gate" PackageName
n (IO a -> IO a
forall a. IO a -> IO a
runInIO IO a
action)
        , spanMetadataFetch :: forall a. PackageName -> IO a -> IO a
spanMetadataFetch = \PackageName
n IO a
action -> ((forall a. IO a -> IO a) -> IO a) -> IO a
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. IO a -> IO a) -> IO a) -> IO a)
-> ((forall a. IO a -> IO a) -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
runInIO ->
            Telemetry -> SpanKind -> Text -> PackageName -> IO a -> IO a
forall (m :: * -> *) a.
MonadUnliftIO m =>
Telemetry -> SpanKind -> Text -> PackageName -> m a -> m a
withPackageSpan Telemetry
telemetry SpanKind
Client Text
"ecluse.metadata.fetch" PackageName
n (IO a -> IO a
forall a. IO a -> IO a
runInIO IO a
action)
        , spanMetadataDecode :: forall a. PackageName -> IO a -> IO a
spanMetadataDecode = \PackageName
n IO a
action -> ((forall a. IO a -> IO a) -> IO a) -> IO a
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. IO a -> IO a) -> IO a) -> IO a)
-> ((forall a. IO a -> IO a) -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
runInIO ->
            Telemetry -> SpanKind -> Text -> PackageName -> IO a -> IO a
forall (m :: * -> *) a.
MonadUnliftIO m =>
Telemetry -> SpanKind -> Text -> PackageName -> m a -> m a
withPackageSpan Telemetry
telemetry SpanKind
Internal Text
"ecluse.metadata.decode" PackageName
n (IO a -> IO a
forall a. IO a -> IO a
runInIO IO a
action)
        }

-- | Project 'withMirrorJobSpan' onto the core 'WorkerTracingPort' that "Ecluse.Core.Worker" uses.
workerTracingPortOf :: Telemetry -> WorkerTracingPort
workerTracingPortOf :: Telemetry -> WorkerTracingPort
workerTracingPortOf Telemetry
telemetry =
    WorkerTracingPort
        { wtpMirrorJobSpan :: forall a.
PackageName
-> Version
-> Maybe RemoteSpanContext
-> (a -> JobSpanOutcome)
-> IO a
-> IO a
wtpMirrorJobSpan = Telemetry
-> PackageName
-> Version
-> Maybe RemoteSpanContext
-> (a -> JobSpanOutcome)
-> IO a
-> IO a
forall (m :: * -> *) a.
MonadUnliftIO m =>
Telemetry
-> PackageName
-> Version
-> Maybe RemoteSpanContext
-> (a -> JobSpanOutcome)
-> m a
-> m a
withMirrorJobSpan Telemetry
telemetry
        }

{- | Project 'withAdvisorySyncSpan' onto the core 'AdvisorySyncTracingPort' that
"Ecluse.Runtime.Cve.Sync" brackets through. Inert when telemetry is disabled.
-}
advisorySyncTracingPortOf :: Telemetry -> AdvisorySyncTracingPort
advisorySyncTracingPortOf :: Telemetry -> AdvisorySyncTracingPort
advisorySyncTracingPortOf Telemetry
telemetry =
    AdvisorySyncTracingPort
        { astpSyncAttemptSpan :: forall a. Ecosystem -> (a -> AdvisorySyncResult) -> IO a -> IO a
astpSyncAttemptSpan = Telemetry -> Ecosystem -> (a -> AdvisorySyncResult) -> IO a -> IO a
forall (m :: * -> *) a.
MonadUnliftIO m =>
Telemetry -> Ecosystem -> (a -> AdvisorySyncResult) -> m a -> m a
withAdvisorySyncSpan Telemetry
telemetry
        }

{- | Map a serve verdict to the rule-evaluation span's attribute fields. None can carry a secret:
the rule name and reason class are a closed vocabulary, and the message is the rendered decision.
-}
ruleVerdictFields :: ServeDecision -> [(Text, Text)]
ruleVerdictFields :: ServeDecision -> [(Text, Text)]
ruleVerdictFields = \case
    ServeDecision
Admit -> [(Text
"ecluse.rule.decision", Text
"admit")]
    Reject Rejection
rejection ->
        [ (Text
"ecluse.rule.decision", Text
"deny")
        , (Text
"ecluse.rule.reason_class", RejectReason -> Text
reasonClass (Rejection -> RejectReason
rejectionReason Rejection
rejection))
        , (Text
"ecluse.rule.message", Rejection -> Text
rejectionMessage Rejection
rejection)
        ]
            [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
forall a. Semigroup a => a -> a -> a
<> RejectReason -> [(Text, Text)]
ruleNameField (Rejection -> RejectReason
rejectionReason Rejection
rejection)

reasonClass :: RejectReason -> Text
reasonClass :: RejectReason -> Text
reasonClass = \case
    ByPolicy RuleName
_ -> Text
"by_policy"
    Unavailable Transience
_ -> Text
"unavailable"
    RejectReason
MissingIntegrity -> Text
"missing_integrity"
    RejectReason
BelowIntegrityFloor -> Text
"below_integrity_floor"
    RejectReason
UpstreamInvalid -> Text
"upstream_invalid"

-- Only a policy denial has a rule to attribute, so no other refusal carries the field.
ruleNameField :: RejectReason -> [(Text, Text)]
ruleNameField :: RejectReason -> [(Text, Text)]
ruleNameField = \case
    ByPolicy (RuleName Text
ruleName) -> [(Text
"ecluse.rule.name", Text
ruleName)]
    Unavailable Transience
_ -> []
    RejectReason
MissingIntegrity -> []
    RejectReason
BelowIntegrityFloor -> []
    RejectReason
UpstreamInvalid -> []

{- Run an action within a domain span, or against 'Nothing' when telemetry is disabled, which
creates no tracer. The span parents on the ambient context, so it nests under the WAI server span. -}
withDomainSpan ::
    (MonadUnliftIO m) =>
    Telemetry ->
    SpanKind ->
    [NewLink] ->
    Text ->
    (Maybe Span -> m a) ->
    m a
withDomainSpan :: forall (m :: * -> *) a.
MonadUnliftIO m =>
Telemetry
-> SpanKind -> [NewLink] -> Text -> (Maybe Span -> m a) -> m a
withDomainSpan Telemetry
telemetry SpanKind
spanKind [NewLink]
spanLinks Text
name Maybe Span -> m a
body =
    case Telemetry -> Maybe TracerProvider
telemetryTracerProvider Telemetry
telemetry of
        Maybe TracerProvider
Nothing -> Maybe Span -> m a
body Maybe Span
forall a. Maybe a
Nothing
        Just TracerProvider
tracerProvider ->
            let tracer :: Tracer
tracer = TracerProvider -> InstrumentationLibrary -> TracerOptions -> Tracer
makeTracer TracerProvider
tracerProvider InstrumentationLibrary
forall s. IsString s => s
ecluseScope TracerOptions
tracerOptions
             in Tracer -> Text -> SpanArguments -> (Span -> m a) -> m a
forall (m :: * -> *) a.
(MonadUnliftIO m, HasCallStack) =>
Tracer -> Text -> SpanArguments -> (Span -> m a) -> m a
inSpan' Tracer
tracer Text
name SpanArguments
defaultSpanArguments{kind = spanKind, links = spanLinks} (Maybe Span -> m a
body (Maybe Span -> m a) -> (Span -> Maybe Span) -> Span -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Span -> Maybe Span
forall a. a -> Maybe a
Just)

-- Capture a live span's trace context as the carrier stamped onto the mirror job, encoded as the
-- standard W3C @traceparent@\/@tracestate@ pair.
captureRemoteContext :: (MonadIO m) => Span -> m RemoteSpanContext
captureRemoteContext :: forall (m :: * -> *). MonadIO m => Span -> m RemoteSpanContext
captureRemoteContext Span
theSpan = do
    (traceparent, tracestate) <- IO (ByteString, ByteString) -> m (ByteString, ByteString)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Span -> IO (ByteString, ByteString)
encodeSpanContext Span
theSpan)
    pure
        RemoteSpanContext
            { rscTraceparent = decodeUtf8 traceparent
            , rscTracestate = decodeUtf8 tracestate
            }

-- The producer span a worker job points back to. A missing or unparsable carrier yields no link
-- and never fails the job, and the remote target leaves the job rooting its own trace.
mirrorJobLinks :: Maybe RemoteSpanContext -> [NewLink]
mirrorJobLinks :: Maybe RemoteSpanContext -> [NewLink]
mirrorJobLinks Maybe RemoteSpanContext
Nothing = []
mirrorJobLinks (Just RemoteSpanContext
remote) =
    case Maybe ByteString -> Maybe ByteString -> Maybe SpanContext
decodeSpanContext (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (Text -> ByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 (RemoteSpanContext -> Text
rscTraceparent RemoteSpanContext
remote))) Maybe ByteString
tracestateHeader of
        Maybe SpanContext
Nothing -> []
        Just SpanContext
ctx -> [NewLink{linkContext :: SpanContext
linkContext = SpanContext
ctx, linkAttributes :: AttributeMap
linkAttributes = AttributeMap
forall a. Monoid a => a
mempty}]
  where
    -- An empty tracestate is passed as absent rather than an empty header value.
    tracestateHeader :: Maybe ByteString
    tracestateHeader :: Maybe ByteString
tracestateHeader
        | RemoteSpanContext -> Text
rscTracestate RemoteSpanContext
remote Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"" = Maybe ByteString
forall a. Maybe a
Nothing
        | Bool
otherwise = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (Text -> ByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 (RemoteSpanContext -> Text
rscTracestate RemoteSpanContext
remote))

-- Record text attribute fields on a span when one is present.
recordFields :: (MonadIO m) => Maybe Span -> [(Text, Text)] -> m ()
recordFields :: forall (m :: * -> *).
MonadIO m =>
Maybe Span -> [(Text, Text)] -> m ()
recordFields Maybe Span
Nothing [(Text, Text)]
_ = m ()
forall (f :: * -> *). Applicative f => f ()
pass
recordFields (Just Span
theSpan) [(Text, Text)]
fields = ((Text, Text) -> m ()) -> [(Text, Text)] -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ ((Text -> Text -> m ()) -> (Text, Text) -> m ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Span -> Text -> Text -> m ()
forall (m :: * -> *) a.
(MonadIO m, ToAttribute a) =>
Span -> Text -> a -> m ()
addAttribute Span
theSpan)) [(Text, Text)]
fields

-- The coordinate fields every domain span carries. They are high-cardinality, which belongs on a
-- span and never on a metric label, and neither rendering can contain a credential.
coordinateFields :: PackageName -> Version -> [(Text, Text)]
coordinateFields :: PackageName -> Version -> [(Text, Text)]
coordinateFields PackageName
name Version
version =
    [ (Text
"ecluse.package", PackageName -> Text
renderPackageName PackageName
name)
    , (Text
"ecluse.version", Version -> Text
renderVersion Version
version)
    ]