From 9ad2429f5bb7d0b946b9247b2bb6a0e0ce8c43ff Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Fri, 9 Oct 2026 12:20:46 -0400 Subject: [PATCH] handle traceparent and tracestate headers in web --- devkit.opam | 2 +- possibly_otel.mli | 12 +++++++++++- possibly_otel.real.ml | 34 ++++++++++++++++++++++++---------- possibly_otel.stub.ml | 6 ++++++ web.ml | 19 ++++++++++--------- 5 files changed, 52 insertions(+), 21 deletions(-) diff --git a/devkit.opam b/devkit.opam index 3940a5fd..2190e06c 100644 --- a/devkit.opam +++ b/devkit.opam @@ -40,6 +40,6 @@ depopts: [ ] conflicts: [ "jemalloc" {< "0.2"} - "opentelemetry" {< "0.13"} + "opentelemetry" {< "0.91"} ] available: arch != "arm32" & arch != "x86_32" diff --git a/possibly_otel.mli b/possibly_otel.mli index 5179fe92..a7cdfdb4 100644 --- a/possibly_otel.mli +++ b/possibly_otel.mli @@ -1,9 +1,19 @@ module Otrace := Trace_core +module Trace_context : sig + val header_names : string list + (** Names of the W3C trace context headers ([traceparent], [tracestate]) *) + + val get_ambient_headers : ?explicit_span:Trace_core.span -> unit -> (string * string) list + (** Headers propagating the context of [explicit_span], or else of the ambient span: + [traceparent] with the span's sampled flag, and [tracestate] if non-empty. + Empty if there is no OTEL span. *) +end + module Traceparent : sig val name : string val get_ambient : ?explicit_span:Trace_core.span -> unit -> string option -end +end [@@deprecated "use Trace_context, which also propagates tracestate"] val enter_manual_span : __FUNCTION__:string -> diff --git a/possibly_otel.real.ml b/possibly_otel.real.ml index aa643225..679cbc83 100644 --- a/possibly_otel.real.ml +++ b/possibly_otel.real.ml @@ -1,18 +1,32 @@ open Opentelemetry +let ambient_span ?explicit_span () = + match explicit_span, Trace_core.current_span () with + | Some (Opentelemetry_trace.Extensions.Span_otel span), _ + | _, Some (Opentelemetry_trace.Extensions.Span_otel span) -> Some span + | _ -> None + +module Trace_context = struct + let header_names = Opentelemetry.Trace_context.[ Traceparent.name; Tracestate.name ] + + let get_ambient_headers ?explicit_span () = + match ambient_span ?explicit_span () with + | Some span -> Opentelemetry.Trace_context.headers_of_span_ctx (Span.to_span_ctx span) + | None -> [] +end + module Traceparent = struct - let name = Trace_context.Traceparent.name + let name = Opentelemetry.Trace_context.Traceparent.name let get_ambient ?explicit_span () = - match explicit_span, Trace_core.current_span () with - | Some (Opentelemetry_trace.Extensions.Span_otel span), _ - | _, Some (Opentelemetry_trace.Extensions.Span_otel span) -> - let ctx = Trace_context.Traceparent.to_value - ~trace_id:(Span.trace_id span) ~parent_id:(Span.id span) () in - Some ctx - | _ -> None + match ambient_span ?explicit_span () with + | Some span -> + Some (Opentelemetry.Trace_context.Traceparent.to_value + ~trace_flags:(Span.trace_flags span) ~trace_id:(Span.trace_id span) ~parent_id:(Span.id span) ()) + | None -> None end +(* no explicit [~parent]: the current span if any, otherwise let the collector look for + an ambient context (e.g. from an incoming traceparent) instead of forcing a new trace *) let enter_manual_span ~__FUNCTION__ ~__FILE__ ~__LINE__ ?data name = - let parent = Trace_core.current_span () in - Trace_core.enter_span ~parent ~__FUNCTION__ ~__FILE__ ~__LINE__ ?data name + Trace_core.enter_span ~__FUNCTION__ ~__FILE__ ~__LINE__ ?data name diff --git a/possibly_otel.stub.ml b/possibly_otel.stub.ml index ce58859e..94149972 100644 --- a/possibly_otel.stub.ml +++ b/possibly_otel.stub.ml @@ -1,3 +1,9 @@ +module Trace_context = struct + let header_names = [ "traceparent"; "tracestate" ] + + let get_ambient_headers ?explicit_span:_ () = [] +end + module Traceparent = struct let name = "traceparent" diff --git a/web.ml b/web.ml index aa52ec5f..859663c0 100644 --- a/web.ml +++ b/web.ml @@ -329,12 +329,12 @@ module Http (IO : IO_TYPE) (Curl_IO : CURL with type 'a t = 'a IO.t) : HTTP with | `Plain, _ -> verbose_curl_result_plain nr_http action t hr | `Logfmt, _ -> verbose_curl_result_logfmt nr_http action t hr - (* Given a list of strings, check pre-existing entry starting with `~name`; and adds the concatenation of `~name` and `~value` if not. *) - let add_if_absent ~name ~value strs = - match strs with - | Some strs when List.exists (fun s -> Stre.starts_with s (name^":")) strs -> strs - | Some strs -> (String.concat ": " [name; value]) :: strs - | None -> [String.concat ": " [name; value]] + (* Remove from the list of "Name: value" headers those whose name (case-insensitive) is in `names`, then add `pairs`. *) + let replace_headers ~names pairs strs = + let is_replaced s = let (n, _) = Stre.dividec s ':' in List.exists (Stre.iequal (String.strip n)) names in + let strs = Option.default [] strs in + let strs = if List.exists is_replaced strs then List.filter (fun s -> not (is_replaced s)) strs else strs in + List.map (fun (n, v) -> sprintf "%s: %s" n v) pairs @ strs (* NOTE don't forget to set http_1_0=true when sending requests to a Httpev-based server *) (* Don't use curl_setheaders when using ?headers option *) @@ -414,9 +414,10 @@ module Http (IO : IO_TYPE) (Curl_IO : CURL with type 'a t = 'a IO.t) : HTTP with Possibly_otel.enter_manual_span ~__FUNCTION__:"Devkit.Web.Http.http_request_k" ~__FILE__ ~__LINE__ ~data:describe span_name in - let headers = match Possibly_otel.Traceparent.get_ambient ~explicit_span () with - | None -> headers - | Some value -> Some (add_if_absent ~name:(Possibly_otel.Traceparent.name) ~value headers) + (* trace context headers always override the caller's *) + let headers = match Possibly_otel.Trace_context.get_ambient_headers ~explicit_span () with + | [] -> headers + | pairs -> Some (replace_headers ~names:Possibly_otel.Trace_context.header_names pairs headers) in let set_body_and_headers h ct body =