Merge 9b327a9bba into 5065cdd985

CHANGES.md

@@ -1,4 +1,14 @@
 
+## 0.91
+
+- expose Self_debug.level_above
+- config: better defaults in Sdk, have batching enabled by default
+
+- better error message for otlp http failures
+- bounded queue: provide a per-item measure function for better errors/metrics
+- fix: retries are self_debug logged at warning level
+- move from ocurl to curl as a dep
+
 ## 0.90
 
 - major refactor: split library into `opentelemetry.core`, `opentelemetry`,

dune-project

@@ -7,7 +7,7 @@
 (source
  (github ocaml-tracing/ocaml-opentelemetry))
 
-(version 0.90)
+(version 0.91)
 
 (implicit_transitive_deps false)
 
@@ -205,11 +205,7 @@
   cohttp-lwt
   cohttp-lwt-unix
   (alcotest :with-test)
-  (containers :with-test)
-  (opentelemetry-lwt
-   (and
-    :with-test
-    (= :version))))
+  (containers :with-test))
  (synopsis "Collector client for opentelemetry, using cohttp + lwt"))
 
 (package

opentelemetry-client-cohttp-eio.opam

@@ -1,6 +1,6 @@
 # This file is generated by dune, edit dune-project instead
 opam-version: "2.0"
-version: "0.90"
+version: "0.91"
 synopsis: "Collector client for opentelemetry, using cohttp + eio"
 maintainer: ["ocaml-tracing"]
 authors: ["ocaml-tracing" "ELLIOTTCABLE <opam@ell.io>" "the imandra team"]

opentelemetry-client-cohttp-lwt.opam

@@ -1,6 +1,6 @@
 # This file is generated by dune, edit dune-project instead
 opam-version: "2.0"
-version: "0.90"
+version: "0.91"
 synopsis: "Collector client for opentelemetry, using cohttp + lwt"
 maintainer: ["ocaml-tracing"]
 authors: ["ocaml-tracing" "ELLIOTTCABLE <opam@ell.io>" "the imandra team"]
@@ -22,7 +22,6 @@ depends: [
   "cohttp-lwt-unix"
   "alcotest" {with-test}
   "containers" {with-test}
-  "opentelemetry-lwt" {with-test & = version}
 ]
 build: [
   ["dune" "subst"] {dev}

opentelemetry-client-ocurl-lwt.opam

@@ -1,6 +1,6 @@
 # This file is generated by dune, edit dune-project instead
 opam-version: "2.0"
-version: "0.90"
+version: "0.91"
 synopsis: "Collector client for opentelemetry, using ezcurl-lwt"
 maintainer: ["ocaml-tracing"]
 authors: ["ocaml-tracing" "ELLIOTTCABLE <opam@ell.io>" "the imandra team"]

opentelemetry-client-ocurl.opam

@@ -1,6 +1,6 @@
 # This file is generated by dune, edit dune-project instead
 opam-version: "2.0"
-version: "0.90"
+version: "0.91"
 synopsis: "Collector client for opentelemetry, using http + ezcurl"
 maintainer: ["ocaml-tracing"]
 authors: ["ocaml-tracing" "ELLIOTTCABLE <opam@ell.io>" "the imandra team"]

opentelemetry-client.opam

@@ -1,6 +1,6 @@
 # This file is generated by dune, edit dune-project instead
 opam-version: "2.0"
-version: "0.90"
+version: "0.91"
 synopsis: "Client SDK for https://opentelemetry.io"
 maintainer: ["ocaml-tracing"]
 authors: ["ocaml-tracing" "ELLIOTTCABLE <opam@ell.io>" "the imandra team"]

opentelemetry-cohttp-lwt.opam

@@ -1,6 +1,6 @@
 # This file is generated by dune, edit dune-project instead
 opam-version: "2.0"
-version: "0.90"
+version: "0.91"
 synopsis: "Opentelemetry tracing for Cohttp HTTP servers"
 maintainer: ["ocaml-tracing"]
 authors: ["ocaml-tracing" "ELLIOTTCABLE <opam@ell.io>" "the imandra team"]

opentelemetry-logs.opam

@@ -1,6 +1,6 @@
 # This file is generated by dune, edit dune-project instead
 opam-version: "2.0"
-version: "0.90"
+version: "0.91"
 synopsis: "Opentelemetry-based reporter for Logs"
 maintainer: ["ocaml-tracing"]
 authors: ["ocaml-tracing" "ELLIOTTCABLE <opam@ell.io>" "the imandra team"]

opentelemetry-lwt.opam

@@ -1,6 +1,6 @@
 # This file is generated by dune, edit dune-project instead
 opam-version: "2.0"
-version: "0.90"
+version: "0.91"
 synopsis: "Lwt-compatible instrumentation for https://opentelemetry.io"
 maintainer: ["ocaml-tracing"]
 authors: ["ocaml-tracing" "ELLIOTTCABLE <opam@ell.io>" "the imandra team"]

opentelemetry.opam

@@ -1,6 +1,6 @@
 # This file is generated by dune, edit dune-project instead
 opam-version: "2.0"
-version: "0.90"
+version: "0.91"
 synopsis:
   "Core library for instrumentation and serialization for https://opentelemetry.io"
 maintainer: ["ocaml-tracing"]

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. *)

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 *)
 

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';

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

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

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
+  )

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. *)

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
+      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 =

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
 

tests/client/dune

@@ -1,4 +1,4 @@
 (tests
  (names test_client_lib)
- (package opentelemetry)
+ (package opentelemetry-client)
  (libraries alcotest opentelemetry-client))

tests/core/dune

@@ -1,4 +1,4 @@
 (tests
  (names test_trace_context t_size t_histogram test_span_dummy)
  (package opentelemetry)
- (libraries pbrt opentelemetry opentelemetry-client))
+ (libraries pbrt opentelemetry))

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: ""

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 ()