web,otel: Don't overwrite a potential preexisting traceparent

possibly_otel.mli

@@ -1,6 +1,9 @@
 module Otrace := Trace_core
 
-val get_traceparent : unit -> string option
+module Traceparent : sig
+  val name : string
+  val get_ambient : unit -> string option
+end
 
 val enter_manual_span :
   __FUNCTION__:string ->

possibly_otel.real.ml

@@ -1,21 +1,20 @@
-module Otel = Opentelemetry
+open Opentelemetry
 
-let get_traceparent () =
-    let tracing_scope = Otel.Scope.get_ambient_scope () in
+let (let*) o f = Option.map f o
 
-    match tracing_scope with
-    | None -> None
-    | Some Otel.Scope.{ trace_id; span_id; _ } ->
-      let tp_value = Otel.Trace_context.Traceparent.to_value ~trace_id ~parent_id:span_id () in
-      Some (Otel.Trace_context.Traceparent.name ^ ": " ^ tp_value)
+module Traceparent = struct
+  let name = Trace_context.Traceparent.name
 
-let enter_manual_span ~__FUNCTION__ ~__FILE__ ~__LINE__ ?data name =
-    let tracing_scope = Otel.Scope.get_ambient_scope () in
+  let get_ambient () =
+    let* Scope.{ trace_id; span_id; _ } = Scope.get_ambient_scope () in
+    Trace_context.Traceparent.to_value ~trace_id ~parent_id:span_id ()
+end
 
-    match tracing_scope with
+let enter_manual_span ~__FUNCTION__ ~__FILE__ ~__LINE__ ?data name =
+    match Scope.get_ambient_scope () with
     | None ->
       Trace_core.enter_manual_toplevel_span ~__FUNCTION__ ~__FILE__ ~__LINE__ ?data name
-    | Some Otel.Scope.{ span_id; _ } ->
+    | Some Scope.{ span_id; _ } ->
       let otrace_espan = Trace_core.{
         span = Opentelemetry_trace.Internal.otrace_of_otel span_id;
         meta = Trace_core.Meta_map.empty

possibly_otel.stub.ml

@@ -1,4 +1,9 @@
-let get_traceparent () = None
+module Traceparent = struct
+  let name = "traceparent"
+
+  let get_ambient () = None
+end
+
 
 let enter_manual_span ~__FUNCTION__ ~__FILE__ ~__LINE__ ?data name =
   Trace_core.enter_manual_toplevel_span ~__FUNCTION__ ~__FILE__ ~__LINE__ ?data name

web.ml

@@ -244,16 +244,22 @@ module Http (IO : IO_TYPE) (Curl_IO : CURL with type 'a t = 'a IO.t) : HTTP with
     end;
     log #info_s (Buffer.contents b)
 
+  (* Given a list of strings, check pre-existing entry starting with `~prefix`; and adds the concatenation of `~prefix` and `~rest` if not. *)
+  let add_if_absent ~name ~value strs =
+    match strs with
+    | Some strs when List.exists (StringLabels.starts_with ~prefix:(name^":")) strs -> strs
+    | Some strs -> (String.concat ": " [name; value]) :: strs
+    | None -> [String.concat ": " [name; value]]
+
   (* 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 *)
   let http_request' ?ua ?timeout ?(verbose=false) ?(setup=ignore) ?timer ?max_size ?(http_1_0=false) ?headers ?body (action:http_action) url =
     let open Curl in
     let action_name = string_of_http_action action in
 
-    let headers = match Possibly_otel.get_traceparent () with
+    let headers = match Possibly_otel.Traceparent.get_ambient () with
     | None -> headers
-    | Some tp_header ->
-      Some (tp_header :: (Option.default [] headers))
+    | Some value -> Some Possibly_otel.Traceparent.(add_if_absent ~name ~value headers)
     in
 
     let set_body_and_headers h ct body =