From b03a5fa65bd9be50ddb02ac2a0b771caa28dc696 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sat, 4 Apr 2026 03:02:25 +0000 Subject: [PATCH 1/4] add trace_state module --- src/core/trace_state.ml | 104 +++++++++++++++++++++++++++++++++++++++ src/core/trace_state.mli | 42 ++++++++++++++++ src/lib/opentelemetry.ml | 1 + 3 files changed, 147 insertions(+) create mode 100644 src/core/trace_state.ml create mode 100644 src/core/trace_state.mli diff --git a/src/core/trace_state.ml b/src/core/trace_state.ml new file mode 100644 index 00000000..14a304b6 --- /dev/null +++ b/src/core/trace_state.ml @@ -0,0 +1,104 @@ +(** W3C Trace State - https://www.w3.org/TR/trace-context/#tracestate-header *) + +type t = (string * string) list + +let empty : t = [] + +let is_valid_key (k : string) : bool = + let n = String.length k in + if n < 1 || n > 256 then + false + else ( + let ok = + ref + (match k.[0] with + | 'a' .. 'z' -> true + | _ -> false) + in + let i = ref 1 in + while !ok && !i < n do + (match k.[!i] with + | 'a' .. 'z' | '0' .. '9' | '_' | '-' | '*' | '/' -> () + | _ -> ok := false); + incr i + done; + !ok + ) + +let is_valid_value (v : string) : bool = + let n = String.length v in + if n < 1 || n > 256 then + false + else ( + let ok = ref (v.[0] <> ' ' && v.[n - 1] <> ' ') in + let i = ref 0 in + while !ok && !i < n do + let code = Char.code v.[!i] in + if code < 0x20 || code > 0x7e || v.[!i] = ',' || v.[!i] = '=' then + ok := false; + incr i + done; + !ok + ) + +let get (self : t) (key : string) : string option = List.assoc_opt key self + +let set (self : t) (key : string) (value : string) : t = + if not (is_valid_key key) then + invalid_arg (Printf.sprintf "Trace_state.set: invalid key %S" key); + if not (is_valid_value value) then + invalid_arg (Printf.sprintf "Trace_state.set: invalid value %S" value); + let rest = List.filter (fun (k, _) -> k <> key) self in + (key, value) :: rest + +let delete (self : t) (key : string) : t = + List.filter (fun (k, _) -> k <> key) self + +let encoded_length (self : t) : int = + match self with + | [] -> 0 + | _ -> + let n = List.length self in + let sum = + List.fold_left + (fun acc (k, v) -> acc + String.length k + 1 + String.length v) + 0 self + in + sum + n - 1 + +let to_w3c_string (self : t) : string = + match self with + | [] -> "" + | _ -> + let buf = Buffer.create (encoded_length self) in + List.iteri + (fun i (k, v) -> + if i > 0 then Buffer.add_char buf ','; + Buffer.add_string buf k; + Buffer.add_char buf '='; + Buffer.add_string buf v) + self; + Buffer.contents buf + +let of_w3c_string (s : string) : (t, string) result = + if s = "" then + Ok [] + else ( + let parts = String.split_on_char ',' s in + let pairs = + List.filter_map + (fun part -> + let part = String.trim part in + match String.index_opt part '=' with + | None -> None + | Some i -> + let k = String.sub part 0 i in + let v = String.sub part (i + 1) (String.length part - i - 1) in + if is_valid_key k && is_valid_value v then + Some (k, v) + else + None) + parts + in + Ok pairs + ) diff --git a/src/core/trace_state.mli b/src/core/trace_state.mli new file mode 100644 index 00000000..1b350fdd --- /dev/null +++ b/src/core/trace_state.mli @@ -0,0 +1,42 @@ +(** W3C Trace State. + + A list of vendor-specific key/value pairs propagated across distributed + tracing systems. + + @since NEXT_RELEASE + + https://www.w3.org/TR/trace-context/#tracestate-header *) + +type t = (string * string) list + +val empty : t + +val is_valid_key : string -> bool +(** [is_valid_key k] is true if [k] is a valid W3C tracestate key. Keys must + start with [a-z], followed by [a-z0-9_-*/], and be at most 256 chars. *) + +val is_valid_value : string -> bool +(** [is_valid_value v] is true if [v] is a valid W3C tracestate value. Values + must be printable ASCII (0x20–0x7E), excluding [,] and [=], with no + leading/trailing space, and at most 256 chars. *) + +val get : t -> string -> string option + +val set : t -> string -> string -> t +(** [set ts key value] adds or replaces [key] in [ts], placing it at the front + (most-recently-updated), per the W3C spec. + @raise Invalid_argument + if [key] or [value] fail their respective validators. *) + +val delete : t -> string -> t + +val encoded_length : t -> int +(** Length of the string produced by {!to_w3c_string}. *) + +val to_w3c_string : t -> string +(** Encodes as a W3C tracestate header value ([k1=v1,k2=v2,...]). Returns [""] + for an empty list. *) + +val of_w3c_string : string -> (t, string) result +(** Parses a W3C tracestate header value. Malformed or invalid entries are + silently skipped rather than returning an error. *) diff --git a/src/lib/opentelemetry.ml b/src/lib/opentelemetry.ml index 60007126..3ed36b61 100644 --- a/src/lib/opentelemetry.ml +++ b/src/lib/opentelemetry.ml @@ -83,6 +83,7 @@ let k_trace_id = Trace_id.k_trace_id module Span_id = Span_id module Span_ctx = Span_ctx +module Trace_state = Trace_state let k_ambient = Span_ctx.k_ambient From dbf459996ab424ce0116f5fc9eda5178d302ba90 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Fri, 3 Apr 2026 21:19:27 -0400 Subject: [PATCH 2/4] add trace state to span and span_ctx --- src/core/span.ml | 30 +++++++++++++++++++++++++++++- src/core/span.mli | 11 +++++++++++ src/core/span_ctx.ml | 18 +++++++++++++----- src/core/span_ctx.mli | 3 +++ src/core/trace_context.ml | 11 +++++++++++ 5 files changed, 67 insertions(+), 6 deletions(-) diff --git a/src/core/span.ml b/src/core/span.ml index 21b8de84..d045a2a0 100644 --- a/src/core/span.ml +++ b/src/core/span.ml @@ -89,8 +89,36 @@ let to_span_link (self : t) : Span_link.t = None) ~trace_id:self.trace_id ~span_id:self.span_id () +let[@inline] trace_state (self : t) : Trace_state.t = + if span_has_trace_state self then + Trace_state.of_w3c_string self.trace_state |> Result.value ~default:[] + else + [] + let[@inline] to_span_ctx (self : t) : Span_ctx.t = - Span_ctx.make ~trace_id:(trace_id self) ~parent_id:(id self) () + Span_ctx.make ~trace_id:(trace_id self) ~parent_id:(id self) + ~trace_state:(trace_state self) () + +let add_trace_state_attr (self : t) (key : string) (value : string) : unit = + if not (Trace_state.is_valid_key key) then + invalid_arg (Printf.sprintf "Span.add_trace_state_attr: invalid key %S" key); + if not (Trace_state.is_valid_value value) then + invalid_arg + (Printf.sprintf "Span.add_trace_state_attr: invalid value %S" value); + let cur = + if span_has_trace_state self then + self.trace_state + else + "" + in + let entry = key ^ "=" ^ value in + let new_ts = + if cur = "" then + entry + else + entry ^ "," ^ cur + in + span_set_trace_state self new_ts (* Note: a span must not be concurrently modified from multiple threads or domains. *) diff --git a/src/core/span.mli b/src/core/span.mli index 15f34e77..708b0fea 100644 --- a/src/core/span.mli +++ b/src/core/span.mli @@ -79,6 +79,17 @@ val status : t -> Span_status.t option val kind : t -> Span_kind.t option +val trace_state : t -> Trace_state.t +(** Returns the decoded trace state, or [[]] if absent or invalid. *) + +val add_trace_state_attr : t -> string -> string -> unit +(** [add_trace_state_attr span key value] prepends/replaces the [key=value] + entry in the span's trace state. + + This is not the most efficient, as it'll copy the whole string to append to + it. + @raise Invalid_argument if [key] or [value] are invalid per W3C rules. *) + val to_span_link : t -> Span_link.t (** Turn the scope into a span link *) diff --git a/src/core/span_ctx.ml b/src/core/span_ctx.ml index 3f2c73e1..022efddb 100644 --- a/src/core/span_ctx.ml +++ b/src/core/span_ctx.ml @@ -2,8 +2,6 @@ open Common_ (* see: https://opentelemetry.io/docs/specs/otel/trace/api/#spancontext *) -(* TODO: trace state *) - external int_of_bool : bool -> int = "%identity" module Flags = struct @@ -16,17 +14,25 @@ type t = { trace_id: Trace_id.t; parent_id: Span_id.t; flags: int; + trace_state: Trace_state.t; (** W3C trace state for distributed tracing *) } -let dummy = { trace_id = Trace_id.dummy; parent_id = Span_id.dummy; flags = 0 } +let dummy = + { + trace_id = Trace_id.dummy; + parent_id = Span_id.dummy; + flags = 0; + trace_state = []; + } -let make ?(remote = false) ?(sampled = false) ~trace_id ~parent_id () : t = +let make ?(remote = false) ?(sampled = false) ?(trace_state = Trace_state.empty) + ~trace_id ~parent_id () : t = let flags = 0 lor (int_of_bool remote lsl Flags.remote) lor (int_of_bool sampled lsl Flags.sampled) in - { trace_id; parent_id; flags } + { trace_id; parent_id; flags; trace_state } let[@inline] is_valid self = Trace_id.is_valid self.trace_id && Span_id.is_valid self.parent_id @@ -39,6 +45,8 @@ let[@inline] trace_id self = self.trace_id let[@inline] parent_id self = self.parent_id +let[@inline] trace_state self = self.trace_state + let to_w3c_trace_context (self : t) : bytes = let bs = Bytes.create 55 in Bytes.set bs 0 '0'; diff --git a/src/core/span_ctx.mli b/src/core/span_ctx.mli index 2970daab..355dd43d 100644 --- a/src/core/span_ctx.mli +++ b/src/core/span_ctx.mli @@ -9,6 +9,7 @@ type t val make : ?remote:bool -> ?sampled:bool -> + ?trace_state:Trace_state.t -> trace_id:Trace_id.t -> parent_id:Span_id.t -> unit -> @@ -29,6 +30,8 @@ val parent_id : t -> Span_id.t val sampled : t -> bool +val trace_state : t -> Trace_state.t + val to_w3c_trace_context : t -> bytes val of_w3c_trace_context : bytes -> (t, string) result diff --git a/src/core/trace_context.ml b/src/core/trace_context.ml index 9c8b141d..ce831914 100644 --- a/src/core/trace_context.ml +++ b/src/core/trace_context.ml @@ -32,3 +32,14 @@ module Traceparent = struct let span_ctx = Span_ctx.make ?sampled ~trace_id ~parent_id () in Bytes.unsafe_to_string @@ Span_ctx.to_w3c_trace_context span_ctx end + +(** The tracestate header https://www.w3.org/TR/trace-context/#tracestate-header +*) +module Tracestate = struct + let name = "tracestate" + + let of_w3c_string (s : string) : (Trace_state.t, string) result = + Trace_state.of_w3c_string s + + let to_w3c_string (ts : Trace_state.t) : string = Trace_state.to_w3c_string ts +end From 3a7e753348f446f37a8c4887f299770e1ef48645 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sat, 4 Apr 2026 03:11:04 +0000 Subject: [PATCH 3/4] trace state in cohttp-lwt integration --- .../cohttp/opentelemetry_cohttp_lwt.ml | 33 ++++++++++++++++--- 1 file changed, 28 insertions(+), 5 deletions(-) diff --git a/src/integrations/cohttp/opentelemetry_cohttp_lwt.ml b/src/integrations/cohttp/opentelemetry_cohttp_lwt.ml index 10be34c7..1a19fe73 100644 --- a/src/integrations/cohttp/opentelemetry_cohttp_lwt.ml +++ b/src/integrations/cohttp/opentelemetry_cohttp_lwt.ml @@ -87,11 +87,17 @@ end = struct let set_trace_context (span : Otel.Span.t) req = let module Traceparent = Otel.Trace_context.Traceparent in + let module Tracestate = Otel.Trace_context.Tracestate in let headers = Header.add (Request.headers req) header_x_ocaml_otel_traceparent (Traceparent.to_value ~trace_id:(Otel.Span.trace_id span) ~parent_id:(Otel.Span.id span) ()) in + let headers = + match Otel.Span.trace_state span with + | [] -> headers + | ts -> Header.add headers Tracestate.name (Tracestate.to_w3c_string ts) + in { req with headers } let get_trace_context ?(from = `Internal) req : Otel.Span.t option = @@ -106,9 +112,20 @@ end = struct | Some v -> (match Traceparent.of_value v with | Ok (trace_id, parent_id) -> - (* TODO: we need a span_ctx here actually *) + let trace_state = + match from with + | `External -> + (match + Header.get (Request.headers req) + Otel.Trace_context.Tracestate.name + with + | None -> "" + | Some ts -> ts) + | `Internal -> "" + in Some - (Otel.Span.make ~trace_id ~id:parent_id ~start_time:0L ~end_time:0L "") + (Otel.Span.make ~trace_id ~id:parent_id ~trace_state ~start_time:0L + ~end_time:0L "") | Error _ -> None) let remove_trace_context req = @@ -169,14 +186,20 @@ let client ?(tracer = Otel.Tracer.default) ?(span : Otel.Span.t option) let add_traceparent (span : Otel.Span.t) headers = let module Traceparent = Otel.Trace_context.Traceparent in + let module Tracestate = Otel.Trace_context.Tracestate in let headers = match headers with | None -> Header.init () | Some headers -> headers in - Header.add headers Traceparent.name - (Traceparent.to_value ~trace_id:(Otel.Span.trace_id span) - ~parent_id:(Otel.Span.id span) ()) + let headers = + Header.add headers Traceparent.name + (Traceparent.to_value ~trace_id:(Otel.Span.trace_id span) + ~parent_id:(Otel.Span.id span) ()) + in + match Otel.Span.trace_state span with + | [] -> headers + | ts -> Header.add headers Tracestate.name (Tracestate.to_w3c_string ts) let call ?ctx ?headers ?body ?chunked meth (uri : Uri.t) : (Response.t * Cohttp_lwt.Body.t) Lwt.t = From 9b327a9bba0c95119c400cbd53f14804905b906d Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sat, 4 Apr 2026 03:11:16 +0000 Subject: [PATCH 4/4] tests for trace-state --- tests/core/test_trace_context.expected | 15 +++++++ tests/core/test_trace_context.ml | 56 ++++++++++++++++++++++++++ 2 files changed, 71 insertions(+) diff --git a/tests/core/test_trace_context.expected b/tests/core/test_trace_context.expected index 21b56778..b6741695 100644 --- a/tests/core/test_trace_context.expected +++ b/tests/core/test_trace_context.expected @@ -29,3 +29,18 @@ Trace_context.Traceparent.of_value "00-4bf92f3577b34da6a3ce929d0e0e4736-00f067aa Trace_context.Traceparent.to_value trace_id:"4bf92f3577b34da6a3ce929d0e0e4736" parent_id:"00f067aa0ba902b7": "00-4bf92f3577b34da6a3ce929d0e0e4736-00f067aa0ba902b7-00" + +of_w3c_string "" -> Ok "" (len=0) +of_w3c_string "congo=t61rcwkgmze" -> Ok "congo=t61rcwkgmze" (len=17) +of_w3c_string "congo=t61rcwkgmze,rojo=00f067aa0ba902b7" -> Ok "congo=t61rcwkgmze,rojo=00f067aa0ba902b7" (len=39) +of_w3c_string " vendor=value " -> Ok "vendor=value" (len=12) +of_w3c_string "bad key=value" -> Ok "" (len=0) +of_w3c_string "key=val,=bad,other=fine" -> Ok "key=val,other=fine" (len=18) + +set/replace: "vendor=new,other=xyz" +after delete: "vendor=new" +get vendor: "new" + +Tracestate.name = "tracestate" +of_w3c_string round-trip: "a=b,c=d" +of_w3c_string empty: "" diff --git a/tests/core/test_trace_context.ml b/tests/core/test_trace_context.ml index 18cca5a5..98c8257f 100644 --- a/tests/core/test_trace_context.ml +++ b/tests/core/test_trace_context.ml @@ -54,3 +54,59 @@ let () = test_to_value (Trace_id.of_hex "4bf92f3577b34da6a3ce929d0e0e4736") (Span_id.of_hex "00f067aa0ba902b7") + +let () = print_endline "" + +(* Trace_state tests *) + +let test_trace_state_rt str = + let open Format in + let result = Trace_state.of_w3c_string str in + match result with + | Ok ts -> + printf "of_w3c_string %S -> Ok %S (len=%d)@." str + (Trace_state.to_w3c_string ts) + (Trace_state.encoded_length ts) + | Error e -> printf "of_w3c_string %S -> Error %S@." str e + +let () = test_trace_state_rt "" + +let () = test_trace_state_rt "congo=t61rcwkgmze" + +let () = test_trace_state_rt "congo=t61rcwkgmze,rojo=00f067aa0ba902b7" + +let () = test_trace_state_rt " vendor=value " + +let () = test_trace_state_rt "bad key=value" + +let () = test_trace_state_rt "key=val,=bad,other=fine" + +let () = print_endline "" + +let test_trace_state_set () = + let ts = Trace_state.empty in + let ts = Trace_state.set ts "vendor" "abc" in + let ts = Trace_state.set ts "other" "xyz" in + let ts = Trace_state.set ts "vendor" "new" in + Format.printf "set/replace: %S@." (Trace_state.to_w3c_string ts); + let ts = Trace_state.delete ts "other" in + Format.printf "after delete: %S@." (Trace_state.to_w3c_string ts); + Format.printf "get vendor: %S@." + (Option.value ~default:"(none)" (Trace_state.get ts "vendor")) + +let () = test_trace_state_set () + +let () = print_endline "" + +let test_tracestate_header () = + let module TS = Trace_context.Tracestate in + Format.printf "Tracestate.name = %S@." TS.name; + (match TS.of_w3c_string "a=b,c=d" with + | Ok ts -> + Format.printf "of_w3c_string round-trip: %S@." (TS.to_w3c_string ts) + | Error e -> Format.printf "of_w3c_string error: %S@." e); + match TS.of_w3c_string "" with + | Ok ts -> Format.printf "of_w3c_string empty: %S@." (TS.to_w3c_string ts) + | Error e -> Format.printf "of_w3c_string error: %S@." e + +let () = test_tracestate_header ()