diff --git a/dune-project b/dune-project index 651c039bc22..a21217568fe 100644 --- a/dune-project +++ b/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)) diff --git a/ocaml/libs/tracing/dune b/ocaml/libs/tracing/dune index 71e5c7b7473..98d1d2fe002 100644 --- a/ocaml/libs/tracing/dune +++ b/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 diff --git a/ocaml/libs/tracing/tracing.ml b/ocaml/libs/tracing/tracing.ml index 8beff835cec..0a70fd8ad47 100644 --- a/ocaml/libs/tracing/tracing.ml +++ b/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 diff --git a/ocaml/libs/tracing/tracing.mli b/ocaml/libs/tracing/tracing.mli index d20fda8c2e1..d80f70c74fc 100644 --- a/ocaml/libs/tracing/tracing.mli +++ b/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 diff --git a/ocaml/xapi-idl/lib/debug_info.ml b/ocaml/xapi-idl/lib/debug_info.ml index 599537ff5b1..ece80acb6b5 100644 --- a/ocaml/xapi-idl/lib/debug_info.ml +++ b/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 diff --git a/xapi-tracing.opam b/xapi-tracing.opam index b9cac8ba0dd..3c401a8d0c3 100644 --- a/xapi-tracing.opam +++ b/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}