fixup! CP-52744: Thread TraceContext as json inside debug_info

dune-project

@@ -103,13 +103,15 @@
    dune
    (alcotest :with-test)
    (fmt :with-test)
-   ppx_deriving_yojson
+   ppx_deriving_rpc
    re
+   rpclib
+   result
+   rresult
    uri
    (uuid :with-test)
    (xapi-log (= :version))
    (xapi-stdext-threads (= :version))
-   yojson
   )
   (synopsis "Allows to instrument code to generate tracing information")
   (description "This library provides modules to allow gathering runtime traces.")

ocaml/libs/tracing/dune

@@ -1,9 +1,18 @@
 (library
  (name tracing)
  (modules tracing)
- (libraries re uri yojson 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_yojson))
+  (pps ppx_deriving_rpc))
  (public_name xapi-tracing))
 
 (library

ocaml/libs/tracing/tracing.ml

@@ -211,12 +211,12 @@ end
 
 (* The context of a trace that can be propagated across service boundaries. *)
 module TraceContext = struct
-  type traceparent = string [@@deriving yojson]
+  type traceparent = string [@@deriving rpcty]
 
-  type baggage = (string * string) list [@@deriving yojson]
+  type baggage = (string * string) list [@@deriving rpcty]
 
   type t = {traceparent: traceparent option; baggage: baggage option}
-  [@@deriving yojson]
+  [@@deriving rpcty]
 
   let empty = {traceparent= None; baggage= None}
 
@@ -228,9 +228,14 @@ module TraceContext = struct
 
   let baggage_of ctx = ctx.baggage
 
-  let to_json_string t = Yojson.Safe.to_string (to_yojson t)
+  let to_json_string trace_context =
+    Rpcmarshal.marshal t.Rpc.Types.ty trace_context |> Jsonrpc.to_string
 
-  let of_json_string s = of_yojson (Yojson.Safe.from_string s)
+  let of_json_string s =
+    s
+    |> Jsonrpc.of_string
+    |> Rpcmarshal.unmarshal t.Rpc.Types.ty
+    |> Rresult.R.get_ok
 end
 
 module SpanContext = struct

ocaml/libs/tracing/tracing.mli

@@ -97,7 +97,7 @@ module TraceContext : sig
 
   val to_json_string : t -> string
 
-  val of_json_string : string -> (t, string) result
+  val of_json_string : string -> t
 end
 
 module SpanContext : sig

ocaml/xapi-idl/lib/debug_info.ml

@@ -24,22 +24,11 @@ let of_string s =
   match String.split_on_char separator s with
   | [log; traceparent] ->
       let trace_context =
-        try
-          let trace_context = Tracing.TraceContext.of_json_string traceparent in
-          match trace_context with
-          | Ok trace_context ->
-              Some trace_context
-          | Error _ ->
-              None
+        try Tracing.TraceContext.of_json_string traceparent
         with _ ->
-          Some
-            (TraceContext.empty
-            |> TraceContext.with_traceparent (Some traceparent)
-            )
-      in
-      let spancontext =
-        Option.(join (map Tracing.SpanContext.of_trace_context trace_context))
+          TraceContext.empty |> TraceContext.with_traceparent (Some traceparent)
       in
+      let spancontext = Tracing.SpanContext.of_trace_context trace_context in
       let tracing =
         Option.map (Fun.flip Tracer.span_of_span_context log) spancontext
       in
@@ -93,12 +82,9 @@ let traceparent_of_dbg dbg =
   match String.split_on_char separator dbg with
   | [_; traceparent] -> (
     try
-      let trace_context = Tracing.TraceContext.of_json_string traceparent in
-      match trace_context with
-      | Ok trace_context ->
-          Tracing.TraceContext.traceparent_of trace_context
-      | Error _ ->
-          None
+      traceparent
+      |> Tracing.TraceContext.of_json_string
+      |> Tracing.TraceContext.traceparent_of
     with _ -> Some traceparent
   )
   | _ ->

xapi-tracing.opam

@@ -13,13 +13,15 @@ depends: [
   "dune" {>= "3.15"}
   "alcotest" {with-test}
   "fmt" {with-test}
-  "ppx_deriving_yojson"
+  "ppx_deriving_rpc"
   "re"
+  "rpclib"
+  "result"
+  "rresult"
   "uri"
   "uuid" {with-test}
   "xapi-log" {= version}
   "xapi-stdext-threads" {= version}
-  "yojson"
   "odoc" {with-doc}
 ]
 build: [