CP-52744: Thread TraceContext as JSON inside debug_info

dune-project

@@ -103,7 +103,11 @@
    dune
    (alcotest :with-test)
    (fmt :with-test)
+   ppx_deriving_rpc
    re
+   rpclib
+   result
+   rresult
    uri
    (uuid :with-test)
    (xapi-log (= :version))

ocaml/libs/tracing/dune

@@ -1,7 +1,18 @@
 (library
  (name tracing)
  (modules tracing)
- (libraries re uri xapi-log xapi-stdext-threads threads.posix)
+ (libraries
+  re
+  rpclib.core
+  rpclib.json
+  result
+  rresult
+  uri
+  xapi-log
+  xapi-stdext-threads
+  threads.posix)
+ (preprocess
+  (pps ppx_deriving_rpc))
  (public_name xapi-tracing))
 
 (library

ocaml/libs/tracing/tracing.ml

@@ -211,11 +211,12 @@ end
 
 (* The context of a trace that can be propagated across service boundaries. *)
 module TraceContext = struct
-  type traceparent = string
+  type traceparent = string [@@deriving rpcty]
 
-  type baggage = (string * string) list
+  type baggage = (string * string) list [@@deriving rpcty]
 
   type t = {traceparent: traceparent option; baggage: baggage option}
+  [@@deriving rpcty]
 
   let empty = {traceparent= None; baggage= None}
 
@@ -226,6 +227,15 @@ module TraceContext = struct
   let traceparent_of ctx = ctx.traceparent
 
   let baggage_of ctx = ctx.baggage
+
+  let to_json_string trace_context =
+    Rpcmarshal.marshal t.Rpc.Types.ty trace_context |> Jsonrpc.to_string
+
+  let of_json_string s =
+    s
+    |> Jsonrpc.of_string
+    |> Rpcmarshal.unmarshal t.Rpc.Types.ty
+    |> Rresult.R.get_ok
 end
 
 module SpanContext = struct
@@ -297,6 +307,8 @@ module Span = struct
 
   let get_context t = t.context
 
+  let get_trace_context t = t.context |> SpanContext.context_of_span_context
+
   let start ?(attributes = Attributes.empty)
       ?(trace_context : TraceContext.t option) ~name ~parent ~span_kind () =
     let trace_id, extra_context =
@@ -310,11 +322,13 @@ module Span = struct
     let context : SpanContext.t =
       {trace_id; span_id; trace_context= extra_context}
     in
+    let traceparent = context |> SpanContext.to_traceparent in
     let context =
       (* If trace_context is provided to the call, override any inherited trace context. *)
-      Option.fold ~none:context
-        ~some:(Fun.flip SpanContext.with_trace_context context)
-        trace_context
+      trace_context
+      |> Option.map (TraceContext.with_traceparent (Some traceparent))
+      |> Option.fold ~none:context
+           ~some:(Fun.flip SpanContext.with_trace_context context)
     in
     (* Using gettimeofday over Mtime as it is better for sharing timestamps between the systems *)
     let begin_time = Unix.gettimeofday () in

ocaml/libs/tracing/tracing.mli

@@ -94,6 +94,10 @@ module TraceContext : sig
   val traceparent_of : t -> traceparent option
 
   val baggage_of : t -> baggage option
+
+  val to_json_string : t -> string
+
+  val of_json_string : string -> t
 end
 
 module SpanContext : sig
@@ -119,6 +123,8 @@ module Span : sig
 
   val get_context : t -> SpanContext.t
 
+  val get_trace_context : t -> TraceContext.t
+
   val add_link : t -> SpanContext.t -> (string * string) list -> t
 
   val add_event : t -> string -> (string * string) list -> t

ocaml/xapi-idl/lib/debug_info.ml

@@ -23,9 +23,14 @@ let of_string s =
   let open Tracing in
   match String.split_on_char separator s with
   | [log; traceparent] ->
-      let spancontext = SpanContext.of_traceparent traceparent in
+      let trace_context =
+        try Tracing.TraceContext.of_json_string traceparent
+        with _ ->
+          TraceContext.empty |> TraceContext.with_traceparent (Some traceparent)
+      in
+      let spancontext = Tracing.SpanContext.of_trace_context trace_context in
       let tracing =
-        Option.map (fun tp -> Tracer.span_of_span_context tp log) spancontext
+        Option.map (Fun.flip Tracer.span_of_span_context log) spancontext
       in
       {log; tracing}
   | _ ->
@@ -37,11 +42,18 @@ let filter_separator = Astring.String.filter (( <> ) separator)
 let to_string t =
   Option.fold ~none:t.log
     ~some:(fun span ->
-      let traceparent =
-        Tracing.Span.get_context span |> Tracing.SpanContext.to_traceparent
+      let trace_context =
+        let traceparent =
+          span |> Tracing.Span.get_context |> Tracing.SpanContext.to_traceparent
+        in
+        span
+        |> Tracing.Span.get_context
+        |> Tracing.SpanContext.context_of_span_context
+        |> Tracing.TraceContext.with_traceparent (Some traceparent)
+        |> Tracing.TraceContext.to_json_string
       in
       Printf.sprintf "%s%c%s" (filter_separator t.log) separator
-        (filter_separator traceparent)
+        (filter_separator trace_context)
     )
     t.tracing
 
@@ -68,7 +80,12 @@ let with_dbg ?(with_thread = false) ~module_name ~name ~dbg f =
 
 let traceparent_of_dbg dbg =
   match String.split_on_char separator dbg with
-  | [_; traceparent] ->
-      Some traceparent
+  | [_; traceparent] -> (
+    try
+      traceparent
+      |> Tracing.TraceContext.of_json_string
+      |> Tracing.TraceContext.traceparent_of
+    with _ -> Some traceparent
+  )
   | _ ->
       None

xapi-tracing.opam

@@ -13,7 +13,11 @@ depends: [
   "dune" {>= "3.15"}
   "alcotest" {with-test}
   "fmt" {with-test}
+  "ppx_deriving_rpc"
   "re"
+  "rpclib"
+  "result"
+  "rresult"
   "uri"
   "uuid" {with-test}
   "xapi-log" {= version}