From fc6919e193ffbd2456e030d6eff89441a24e7d43 Mon Sep 17 00:00:00 2001 From: Colin James Date: Wed, 16 Oct 2024 13:58:51 +0100 Subject: [PATCH 01/12] CP-51772: Remove traceparent from Http.Request This is a breaking change to http-lib that removes the special treatment of traceparent from the Http.Request module record. In order to more easily include other tracing-related headers in future we propose that we create an aggregate data structure (named something like "trace context") which can (optionally) contain traceparent, baggage, tracestate, etc. and then we "inject" those into the additional_headers of the request we wish to endow with tracing-related information. On the receiving end, a similar "extract" function will perform the dual operation, extracting tracing context from the request: Generally, for some carrier, we intend to provide two operations: val inject : context -> carrier -> carrier val extract : carrier -> context The "carrier" is whatever transport is being used to propagate tracing across service boundaries. In our case, HTTP requests. Signed-off-by: Colin James --- ocaml/libs/http-lib/http.ml | 67 +++++++++++++--------------- ocaml/libs/http-lib/http.mli | 4 -- ocaml/libs/http-lib/http_svr.ml | 2 - ocaml/libs/http-lib/xmlrpc_client.ml | 15 ++++--- 4 files changed, 38 insertions(+), 50 deletions(-) diff --git a/ocaml/libs/http-lib/http.ml b/ocaml/libs/http-lib/http.ml index a19745576ce..75f8a5880b7 100644 --- a/ocaml/libs/http-lib/http.ml +++ b/ocaml/libs/http-lib/http.ml @@ -132,8 +132,6 @@ module Hdr = struct let location = "location" - let traceparent = "traceparent" - let hsts = "strict-transport-security" end @@ -522,7 +520,6 @@ module Request = struct ; mutable close: bool ; additional_headers: (string * string) list ; body: string option - ; traceparent: string option } [@@deriving rpc] @@ -546,12 +543,11 @@ module Request = struct ; close= true ; additional_headers= [] ; body= None - ; traceparent= None } let make ?(frame = false) ?(version = "1.1") ?(keep_alive = true) ?accept ?cookie ?length ?auth ?subtask_of ?body ?(headers = []) ?content_type - ?host ?(query = []) ?traceparent ~user_agent meth path = + ?host ?(query = []) ~user_agent meth path = { empty with version @@ -570,7 +566,6 @@ module Request = struct ; body ; accept ; query - ; traceparent } let get_version x = x.version @@ -582,8 +577,7 @@ module Request = struct Printf.sprintf "{ frame = %b; method = %s; uri = %s; query = [ %s ]; content_length = [ \ %s ]; transfer encoding = %s; version = %s; cookie = [ %s ]; task = %s; \ - subtask_of = %s; content-type = %s; host = %s; user_agent = %s; \ - traceparent = %s }" + subtask_of = %s; content-type = %s; host = %s; user_agent = %s; }" x.frame (string_of_method_t x.m) x.uri (kvpairs x.query) (Option.fold ~none:"" ~some:Int64.to_string x.content_length) (Option.value ~default:"" x.transfer_encoding) @@ -593,7 +587,6 @@ module Request = struct (Option.value ~default:"" x.content_type) (Option.value ~default:"" x.host) (Option.value ~default:"" x.user_agent) - (Option.value ~default:"" x.traceparent) let to_header_list x = let kvpairs x = @@ -643,11 +636,6 @@ module Request = struct ~some:(fun x -> [Hdr.user_agent ^ ": " ^ x]) x.user_agent in - let traceparent = - Option.fold ~none:[] - ~some:(fun x -> [Hdr.traceparent ^ ": " ^ x]) - x.traceparent - in let close = [(Hdr.connection ^ ": " ^ if x.close then "close" else "keep-alive")] in @@ -665,7 +653,6 @@ module Request = struct @ content_type @ host @ user_agent - @ traceparent @ close @ List.map (fun (k, v) -> k ^ ": " ^ v) x.additional_headers @@ -688,28 +675,34 @@ module Request = struct let frame_header = if x.frame then make_frame_header headers else "" in frame_header ^ headers ^ body - let traceparent_of req = - let open Tracing in - let ( let* ) = Option.bind in - let* traceparent = req.traceparent in - let* span_context = SpanContext.of_traceparent traceparent in - let span = Tracer.span_of_span_context span_context req.uri in - Some span - - let with_tracing ?attributes ~name req f = - let open Tracing in - let parent = traceparent_of req in - with_child_trace ?attributes parent ~name (fun (span : Span.t option) -> - match span with - | Some span -> - let traceparent = - Some (span |> Span.get_context |> SpanContext.to_traceparent) - in - let req = {req with traceparent} in - f req - | None -> - f req - ) + (* let traceparent_of req = *) + (* let open Tracing in *) + (* let ( let* ) = Option.bind in *) + (* let* traceparent = req.traceparent in *) + (* let* span_context = SpanContext.of_traceparent traceparent in *) + (* let span = Tracer.span_of_span_context span_context req.uri in *) + (* Some span *) + + (* let with_tracing ?attributes ~name req f = *) + (* let open Tracing in *) + (* let parent = traceparent_of req in *) + (* with_child_trace ?attributes parent ~name (fun (span : Span.t option) -> *) + (* match span with *) + (* | Some span -> *) + (* let traceparent = *) + (* Some (span |> Span.get_context |> SpanContext.to_traceparent) *) + (* in *) + (* let req = {req with traceparent} in *) + (* f req *) + (* | None -> *) + (* f req *) + (* ) *) + + let traceparent_of _ = None + + let with_tracing ?attributes ~name = + ignore (attributes, name) ; + Fun.flip ( @@ ) end module Response = struct diff --git a/ocaml/libs/http-lib/http.mli b/ocaml/libs/http-lib/http.mli index 3fbae8e4c6f..66557a76fe9 100644 --- a/ocaml/libs/http-lib/http.mli +++ b/ocaml/libs/http-lib/http.mli @@ -86,7 +86,6 @@ module Request : sig ; mutable close: bool ; additional_headers: (string * string) list ; body: string option - ; traceparent: string option } val rpc_of_t : t -> Rpc.t @@ -109,7 +108,6 @@ module Request : sig -> ?content_type:string -> ?host:string -> ?query:(string * string) list - -> ?traceparent:string -> user_agent:string -> method_t -> string @@ -229,8 +227,6 @@ module Hdr : sig val location : string - val traceparent : string - val hsts : string (** Header used for HTTP Strict Transport Security *) end diff --git a/ocaml/libs/http-lib/http_svr.ml b/ocaml/libs/http-lib/http_svr.ml index 54a8b96ba73..2240d811797 100644 --- a/ocaml/libs/http-lib/http_svr.ml +++ b/ocaml/libs/http-lib/http_svr.ml @@ -409,8 +409,6 @@ let read_request_exn ~proxy_seen ~read_timeout ~total_timeout ~max_length fd = {req with host= Some v} | k when k = Http.Hdr.user_agent -> {req with user_agent= Some v} - | k when k = Http.Hdr.traceparent -> - {req with traceparent= Some v} | k when k = Http.Hdr.connection && lowercase v = "close" -> {req with close= true} | k diff --git a/ocaml/libs/http-lib/xmlrpc_client.ml b/ocaml/libs/http-lib/xmlrpc_client.ml index 5bf43b0268c..f7390f8fb46 100644 --- a/ocaml/libs/http-lib/xmlrpc_client.ml +++ b/ocaml/libs/http-lib/xmlrpc_client.ml @@ -50,15 +50,16 @@ let connect ?session_id ?task_id ?subtask_of path = let xmlrpc ?frame ?version ?keep_alive ?task_id ?cookie ?length ?auth ?subtask_of ?query ?body ?(tracing = None) path = - let traceparent = - let open Tracing in - Option.map - (fun span -> Span.get_context span |> SpanContext.to_traceparent) - tracing - in + (* let traceparent = *) + (* let open Tracing in *) + (* Option.map *) + (* (fun span -> Span.get_context span |> SpanContext.to_traceparent) *) + (* tracing *) + (* in *) + ignore tracing ; let headers = Option.map (fun x -> [(Http.Hdr.task_id, x)]) task_id in Http.Request.make ~user_agent ?frame ?version ?keep_alive ?cookie ?headers - ?length ?auth ?subtask_of ?query ?body ?traceparent Http.Post path + ?length ?auth ?subtask_of ?query ?body Http.Post path (** Thrown when ECONNRESET is caught which suggests the remote crashed or restarted *) exception Connection_reset From fe66bc4f8e5f207c05603b5a711866361db76468 Mon Sep 17 00:00:00 2001 From: Colin James Date: Wed, 16 Oct 2024 14:13:32 +0100 Subject: [PATCH 02/12] CP-51772: Remove external usage of traceparent Temporarily remove parts of the code that worked with requests directly, manipulating (or using) traceparents. Signed-off-by: Colin James --- ocaml/xapi-cli-server/xapi_cli.ml | 13 +++++++------ ocaml/xapi/context.ml | 4 ++-- 2 files changed, 9 insertions(+), 8 deletions(-) diff --git a/ocaml/xapi-cli-server/xapi_cli.ml b/ocaml/xapi-cli-server/xapi_cli.ml index bc2389d4c44..57f09e4aafc 100644 --- a/ocaml/xapi-cli-server/xapi_cli.ml +++ b/ocaml/xapi-cli-server/xapi_cli.ml @@ -190,12 +190,13 @@ let uninteresting_cmd_postfixes = ["help"; "-get"; "-list"] let exec_command req cmd s session args = let params = get_params cmd in let tracing = - Option.bind - Http.Request.(req.traceparent) - Tracing.SpanContext.of_traceparent - |> Option.map (fun span_context -> - Tracing.Tracer.span_of_span_context span_context (get_cmdname cmd) - ) + (* Option.bind *) + (* Http.Request.(req.traceparent) *) + (* Tracing.SpanContext.of_traceparent *) + (* |> Option.map (fun span_context -> *) + (* Tracing.Tracer.span_of_span_context span_context (get_cmdname cmd) *) + (* ) *) + None in let minimal = if List.mem_assoc "minimal" params then diff --git a/ocaml/xapi/context.ml b/ocaml/xapi/context.ml index 41faa238bd5..f2cb485e770 100644 --- a/ocaml/xapi/context.ml +++ b/ocaml/xapi/context.ml @@ -221,8 +221,8 @@ let parent_of_origin (origin : origin) span_name = let open Tracing in let ( let* ) = Option.bind in match origin with - | Http (req, _) -> - let* traceparent = req.Http.Request.traceparent in + | Http (_req, _) -> + let* traceparent = (* req.Http.Request.traceparent *) None in let* span_context = SpanContext.of_traceparent traceparent in let span = Tracer.span_of_span_context span_context span_name in Some span From 7b95bd6725a267833e142a528c3401db8e6ad88b Mon Sep 17 00:00:00 2001 From: Colin James Date: Wed, 16 Oct 2024 15:56:41 +0100 Subject: [PATCH 03/12] CP-51772: Add TraceContext to Tracing Introduces a more general trace context record that will encapsulate the metadata of tracing that can be propagated across service boundaries. Signed-off-by: Colin James --- ocaml/libs/tracing/tracing.ml | 25 ++++++++++++++++++++++--- ocaml/libs/tracing/tracing.mli | 18 ++++++++++++++++++ 2 files changed, 40 insertions(+), 3 deletions(-) diff --git a/ocaml/libs/tracing/tracing.ml b/ocaml/libs/tracing/tracing.ml index 3f521f6f29c..cad2a8b2069 100644 --- a/ocaml/libs/tracing/tracing.ml +++ b/ocaml/libs/tracing/tracing.ml @@ -209,15 +209,34 @@ end = struct let compare = Int64.compare end +(* The context of a trace that can be propagated across service boundaries. *) +module TraceContext = struct + type traceparent = string + + type baggage = (string * string) list + + type t = {traceparent: traceparent option; baggage: baggage option} + + let empty = {traceparent= None; baggage= None} + + let with_traceparent traceparent ctx = {ctx with traceparent} + + let with_baggage baggage ctx = {ctx with baggage} + + let traceparent_of ctx = ctx.traceparent + + let baggage_of ctx = ctx.baggage +end + module SpanContext = struct type t = {trace_id: Trace_id.t; span_id: Span_id.t} [@@deriving rpcty] let context trace_id span_id = {trace_id; span_id} let to_traceparent t = - Printf.sprintf "00-%s-%s-01" - (Trace_id.to_string t.trace_id) - (Span_id.to_string t.span_id) + let tid = Trace_id.to_string t.trace_id in + let sid = Span_id.to_string t.span_id in + Printf.sprintf "00-%s-%s-01" tid sid let of_traceparent traceparent = let elements = String.split_on_char '-' traceparent in diff --git a/ocaml/libs/tracing/tracing.mli b/ocaml/libs/tracing/tracing.mli index 18b248cc881..5163a166002 100644 --- a/ocaml/libs/tracing/tracing.mli +++ b/ocaml/libs/tracing/tracing.mli @@ -78,6 +78,24 @@ module Trace_id : sig val to_string : t -> string end +module TraceContext : sig + type t + + val empty : t + + type traceparent = string + + type baggage = (string * string) list + + val with_traceparent : traceparent option -> t -> t + + val with_baggage : baggage option -> t -> t + + val traceparent_of : t -> traceparent option + + val baggage_of : t -> baggage option +end + module SpanContext : sig type t From e14981737948416c872caf6c99abf0959881f1cb Mon Sep 17 00:00:00 2001 From: Colin James Date: Wed, 16 Oct 2024 15:58:10 +0100 Subject: [PATCH 04/12] CP-51772: Add Http Request Propagator In a new library, tracing_propagator, simple injection and extraction routines are provided for rewriting HTTP requests (Http.Request) to have trace-related information. It must be a new library as a cycle would be introduced if we attempted to make tracing depend on http-lib (as http-lib depends on tracing). Signed-off-by: Colin James --- ocaml/libs/tracing/dune | 5 ++ ocaml/libs/tracing/propagator.ml | 108 ++++++++++++++++++++++++++++++ ocaml/libs/tracing/propagator.mli | 23 +++++++ 3 files changed, 136 insertions(+) create mode 100644 ocaml/libs/tracing/propagator.ml create mode 100644 ocaml/libs/tracing/propagator.mli diff --git a/ocaml/libs/tracing/dune b/ocaml/libs/tracing/dune index 8c53962c579..71e5c7b7473 100644 --- a/ocaml/libs/tracing/dune +++ b/ocaml/libs/tracing/dune @@ -28,6 +28,11 @@ (preprocess (pps ppx_deriving_rpc))) +(library + (name tracing_propagator) + (modules propagator) + (libraries astring http-lib tracing)) + (test (name test_tracing) (modules test_tracing) diff --git a/ocaml/libs/tracing/propagator.ml b/ocaml/libs/tracing/propagator.ml new file mode 100644 index 00000000000..13c48bafce3 --- /dev/null +++ b/ocaml/libs/tracing/propagator.ml @@ -0,0 +1,108 @@ +(* + * Copyright (c) Cloud Software Group, Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +module type S = sig + type carrier + + val inject_into : Tracing.TraceContext.t -> carrier -> carrier + + val extract_from : carrier -> Tracing.TraceContext.t +end + +let ( let* ) = Option.bind + +let ( >> ) f g x = g (f x) + +let maybe f = function Some _ as o -> f o | _ -> Fun.id + +let[@tail_mod_cons] rec filter_append p xs ys = + match xs with + | [] -> + ys + | x :: xs when p x -> + x :: filter_append p xs ys + | _ :: xs -> + filter_append p xs ys + +module Http = struct + type carrier = Http.Request.t + + open struct + let hdr_traceparent = "traceparent" + + let hdr_baggage = "baggage" + end + + let alloc_assoc k kvs = + List.filter_map + (fun (key, value) -> if key = k then Some value else None) + kvs + |> function + | [] -> + None + | xs -> + Some xs + + let parse = + let open Astring.String in + let trim_pair (key, value) = (trim key, trim value) in + cuts ~sep:";" + >> List.map (cut ~sep:"=" >> Option.map trim_pair) + >> List.filter_map Fun.id + + let inject_into ctx req = + let open Tracing in + let traceparent = (hdr_traceparent, TraceContext.traceparent_of ctx) in + let baggage = + let encoded = + let encode = + List.map (fun (k, v) -> Printf.sprintf "%s=%s" k v) + >> String.concat ";" + in + TraceContext.baggage_of ctx |> Option.map encode + in + (hdr_baggage, encoded) + in + let entries = [traceparent; baggage] in + let filter_entries entries = + let tbl = Hashtbl.create 47 in + let record (k, v) = + match v with + | Some v -> + Hashtbl.replace tbl k () ; + Some (k, v) + | _ -> + None + in + let entries = List.filter_map record entries in + (entries, fst >> Hashtbl.mem tbl) + in + let entries, to_replace = filter_entries entries in + let headers = req.Http.Request.additional_headers in + let additional_headers = + filter_append (Fun.negate to_replace) headers entries + in + {req with additional_headers} + + let extract_from req = + let open Tracing in + let headers = req.Http.Request.additional_headers in + let traceparent = List.assoc_opt hdr_traceparent headers in + let baggage = + let* all = alloc_assoc hdr_baggage headers in + Some (List.concat_map parse all) + in + let open TraceContext in + empty |> maybe with_traceparent traceparent |> maybe with_baggage baggage +end diff --git a/ocaml/libs/tracing/propagator.mli b/ocaml/libs/tracing/propagator.mli new file mode 100644 index 00000000000..36780d14c86 --- /dev/null +++ b/ocaml/libs/tracing/propagator.mli @@ -0,0 +1,23 @@ +(* + * Copyright (c) Cloud Software Group, Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +module type S = sig + type carrier + + val inject_into : Tracing.TraceContext.t -> carrier -> carrier + + val extract_from : carrier -> Tracing.TraceContext.t +end + +module Http : S with type carrier = Http.Request.t From 0d996b3e079d7affc9875ae352816e11e22309dd Mon Sep 17 00:00:00 2001 From: Colin James Date: Wed, 16 Oct 2024 16:24:10 +0100 Subject: [PATCH 05/12] CP-51772: Extract traceparent back out Restore code that was previously disabled. Signed-off-by: Colin James --- ocaml/libs/tracing/dune | 1 + ocaml/xapi-cli-server/dune | 1 + ocaml/xapi-cli-server/xapi_cli.ml | 20 +++++++++----------- ocaml/xapi/context.ml | 5 +++-- ocaml/xapi/dune | 1 + 5 files changed, 15 insertions(+), 13 deletions(-) diff --git a/ocaml/libs/tracing/dune b/ocaml/libs/tracing/dune index 71e5c7b7473..cf28881793a 100644 --- a/ocaml/libs/tracing/dune +++ b/ocaml/libs/tracing/dune @@ -31,6 +31,7 @@ (library (name tracing_propagator) (modules propagator) + (wrapped false) (libraries astring http-lib tracing)) (test diff --git a/ocaml/xapi-cli-server/dune b/ocaml/xapi-cli-server/dune index c1a8269dbb6..2c297d1da9f 100644 --- a/ocaml/xapi-cli-server/dune +++ b/ocaml/xapi-cli-server/dune @@ -42,6 +42,7 @@ xapi-stdext-threads xapi-stdext-unix xapi-tracing + tracing_propagator xmlm xml-light2 ) diff --git a/ocaml/xapi-cli-server/xapi_cli.ml b/ocaml/xapi-cli-server/xapi_cli.ml index 57f09e4aafc..5ea0f949210 100644 --- a/ocaml/xapi-cli-server/xapi_cli.ml +++ b/ocaml/xapi-cli-server/xapi_cli.ml @@ -190,19 +190,17 @@ let uninteresting_cmd_postfixes = ["help"; "-get"; "-list"] let exec_command req cmd s session args = let params = get_params cmd in let tracing = - (* Option.bind *) - (* Http.Request.(req.traceparent) *) - (* Tracing.SpanContext.of_traceparent *) - (* |> Option.map (fun span_context -> *) - (* Tracing.Tracer.span_of_span_context span_context (get_cmdname cmd) *) - (* ) *) - None + let open Tracing in + let ( let* ) = Option.bind in + let context = Propagator.Http.extract_from req in + let* traceparent = TraceContext.traceparent_of context in + let* span_context = SpanContext.of_traceparent traceparent in + let span = Tracer.span_of_span_context span_context (get_cmdname cmd) in + Some span in let minimal = - if List.mem_assoc "minimal" params then - bool_of_string (List.assoc "minimal" params) - else - false + List.assoc_opt "minimal" params + |> Option.fold ~none:false ~some:bool_of_string in let u = try List.assoc "username" params with _ -> "" in let p = try List.assoc "password" params with _ -> "" in diff --git a/ocaml/xapi/context.ml b/ocaml/xapi/context.ml index f2cb485e770..efb6ee61318 100644 --- a/ocaml/xapi/context.ml +++ b/ocaml/xapi/context.ml @@ -221,8 +221,9 @@ let parent_of_origin (origin : origin) span_name = let open Tracing in let ( let* ) = Option.bind in match origin with - | Http (_req, _) -> - let* traceparent = (* req.Http.Request.traceparent *) None in + | Http (req, _) -> + let context = Propagator.Http.extract_from req in + let* traceparent = TraceContext.traceparent_of context in let* span_context = SpanContext.of_traceparent traceparent in let span = Tracer.span_of_span_context span_context span_name in Some span diff --git a/ocaml/xapi/dune b/ocaml/xapi/dune index 9f3e5f825fa..dbcb9eb284f 100644 --- a/ocaml/xapi/dune +++ b/ocaml/xapi/dune @@ -68,6 +68,7 @@ xapi_database mtime tracing + tracing_propagator uuid rpclib.core threads.posix From 069ca95e9ee84031666c2d9c679e80553e4b7ad1 Mon Sep 17 00:00:00 2001 From: Colin James Date: Wed, 16 Oct 2024 17:34:43 +0100 Subject: [PATCH 06/12] CP-51772: Remove tracing dependency from http-lib The tracing library is removed as a dependency from http-lib. It is still a dependency of http-svr. This is currently a breaking change. The plan is to: - Factor out - and generalise - the helpers defined in place of removing the functions Http.Request.traceparent_of and Http.Request.with_tracing. The comment describes how this should be done: consolidate the impl into the tracing library itself and then provide inject and extract routines to do it for arbitrary carriers. - Rewrite xmlrpc to accept an arbitrary request rewriter function such as (Http.Request.t -> Http.Request.t) before it dispatches. Then, tracing can be injected in by the user. Signed-off-by: Colin James --- ocaml/libs/http-lib/dune | 2 +- ocaml/libs/http-lib/http.ml | 29 ---------- ocaml/libs/http-lib/http.mli | 5 -- ocaml/libs/http-lib/http_svr.ml | 81 +++++++++++++++++++++++++-- ocaml/libs/http-lib/xmlrpc_client.ml | 9 +-- ocaml/libs/http-lib/xmlrpc_client.mli | 1 - 6 files changed, 79 insertions(+), 48 deletions(-) diff --git a/ocaml/libs/http-lib/dune b/ocaml/libs/http-lib/dune index 2990fda2453..42286576aa4 100644 --- a/ocaml/libs/http-lib/dune +++ b/ocaml/libs/http-lib/dune @@ -30,7 +30,6 @@ xapi-stdext-threads xapi-stdext-unix xml-light2 - tracing ) ) @@ -46,6 +45,7 @@ polly threads.posix tracing + tracing_propagator uri xapi-log xapi-stdext-pervasives diff --git a/ocaml/libs/http-lib/http.ml b/ocaml/libs/http-lib/http.ml index 75f8a5880b7..554f3ed6217 100644 --- a/ocaml/libs/http-lib/http.ml +++ b/ocaml/libs/http-lib/http.ml @@ -674,35 +674,6 @@ module Request = struct let headers, body = to_headers_and_body x in let frame_header = if x.frame then make_frame_header headers else "" in frame_header ^ headers ^ body - - (* let traceparent_of req = *) - (* let open Tracing in *) - (* let ( let* ) = Option.bind in *) - (* let* traceparent = req.traceparent in *) - (* let* span_context = SpanContext.of_traceparent traceparent in *) - (* let span = Tracer.span_of_span_context span_context req.uri in *) - (* Some span *) - - (* let with_tracing ?attributes ~name req f = *) - (* let open Tracing in *) - (* let parent = traceparent_of req in *) - (* with_child_trace ?attributes parent ~name (fun (span : Span.t option) -> *) - (* match span with *) - (* | Some span -> *) - (* let traceparent = *) - (* Some (span |> Span.get_context |> SpanContext.to_traceparent) *) - (* in *) - (* let req = {req with traceparent} in *) - (* f req *) - (* | None -> *) - (* f req *) - (* ) *) - - let traceparent_of _ = None - - let with_tracing ?attributes ~name = - ignore (attributes, name) ; - Fun.flip ( @@ ) end module Response = struct diff --git a/ocaml/libs/http-lib/http.mli b/ocaml/libs/http-lib/http.mli index 66557a76fe9..13b8bcaa4fa 100644 --- a/ocaml/libs/http-lib/http.mli +++ b/ocaml/libs/http-lib/http.mli @@ -126,11 +126,6 @@ module Request : sig val to_wire_string : t -> string (** [to_wire_string t] returns a string which could be sent to a server *) - - val traceparent_of : t -> Tracing.Span.t option - - val with_tracing : - ?attributes:(string * string) list -> name:string -> t -> (t -> 'a) -> 'a end (** Parsed form of the HTTP response *) diff --git a/ocaml/libs/http-lib/http_svr.ml b/ocaml/libs/http-lib/http_svr.ml index 2240d811797..68ef0197d54 100644 --- a/ocaml/libs/http-lib/http_svr.ml +++ b/ocaml/libs/http-lib/http_svr.ml @@ -99,9 +99,82 @@ let response_of_request req hdrs = ~headers:(connection :: cache :: hdrs) "200" "OK" +(* These functions have been factored out of Http.Request. + The carrier protocol should generally have no knowledge of tracing. *) +module type HelperS = sig + val traceparent_of : Http.Request.t -> Tracing.Span.t option + + val with_tracing : + ?attributes:(string * string) list + -> name:string + -> Http.Request.t + -> (Http.Request.t -> 'a) + -> 'a +end + +module Helper : HelperS = struct + (* This code can probably be relocated into the tracing library + with the following generalisation: + + val with_tracing : + ?attributes:(string * string) list + -> name:string + -> Http.Request.t + -> (Http.Request.t -> 'a) + -> 'a + + can become: + + val with_tracing : + ?attributes:(string * string) list + -> inject: (TraceContext.t -> 'carrier -> 'carrier) + -> extract: ('carrier -> TraceContext.t) + -> name:string + -> 'carrier + -> ('carrier -> 'a) + -> 'a + + Can possibly pass a first-class module, but there may be a dependency cycle, + so functions are a more universal interface. + *) + + let traceparent_of req = + (* TODO: The extracted TraceContext must be propagated through the + spans. Simple approach is to add it to the SpanContext, and then + inherit it properly (substituting/creating only identity-related). *) + let open Tracing in + let ( let* ) = Option.bind in + let trace_context = Propagator.Http.extract_from req in + let* parent = TraceContext.traceparent_of trace_context in + let* span_context = SpanContext.of_traceparent parent in + Some (Tracer.span_of_span_context span_context req.uri) + + let with_tracing ?attributes ~name req f = + ignore (attributes, name) ; + let open Tracing in + let trace_context = Propagator.Http.extract_from req in + let parent = traceparent_of req in + let continue_with_child = function + | Some child -> + (* Here, "traceparent" is terminology for the [version-trace_id-span_id-flags] structure. + Therefore, the purpose of the code below is to decorate the request with the derived (child) span's ID. + This function only gets called if parent is not None. *) + let span_context = Span.get_context child in + let traceparent = SpanContext.to_traceparent span_context in + let trace_context' = + TraceContext.with_traceparent (Some traceparent) trace_context + in + let req' = Propagator.Http.inject_into trace_context' req in + f req' + | _ -> + f req + in + with_child_trace ?attributes parent ~name continue_with_child +end + let response_fct req ?(hdrs = []) s (response_length : int64) (write_response_to_fd_fn : Unix.file_descr -> unit) = - let@ req = Http.Request.with_tracing ~name:__FUNCTION__ req in + let@ req = Helper.with_tracing ~name:__FUNCTION__ req in let res = { (response_of_request req hdrs) with @@ -445,7 +518,7 @@ let read_request ?proxy_seen ~read_timeout ~total_timeout ~max_length fd = let r, proxy = read_request_exn ~proxy_seen ~read_timeout ~total_timeout ~max_length fd in - let parent_span = Http.Request.traceparent_of r in + let parent_span = Helper.traceparent_of r in let loop_span = Option.fold ~none:None ~some:(fun span -> @@ -489,8 +562,8 @@ let read_request ?proxy_seen ~read_timeout ~total_timeout ~max_length fd = (None, None) let handle_one (x : 'a Server.t) ss context req = - let@ req = Http.Request.with_tracing ~name:__FUNCTION__ req in - let span = Http.Request.traceparent_of req in + let@ req = Helper.with_tracing ~name:__FUNCTION__ req in + let span = Helper.traceparent_of req in let finished = ref false in try D.debug "Request %s" (Http.Request.to_string req) ; diff --git a/ocaml/libs/http-lib/xmlrpc_client.ml b/ocaml/libs/http-lib/xmlrpc_client.ml index f7390f8fb46..e23ccd69f73 100644 --- a/ocaml/libs/http-lib/xmlrpc_client.ml +++ b/ocaml/libs/http-lib/xmlrpc_client.ml @@ -49,14 +49,7 @@ let connect ?session_id ?task_id ?subtask_of path = ?subtask_of Http.Connect path let xmlrpc ?frame ?version ?keep_alive ?task_id ?cookie ?length ?auth - ?subtask_of ?query ?body ?(tracing = None) path = - (* let traceparent = *) - (* let open Tracing in *) - (* Option.map *) - (* (fun span -> Span.get_context span |> SpanContext.to_traceparent) *) - (* tracing *) - (* in *) - ignore tracing ; + ?subtask_of ?query ?body path = let headers = Option.map (fun x -> [(Http.Hdr.task_id, x)]) task_id in Http.Request.make ~user_agent ?frame ?version ?keep_alive ?cookie ?headers ?length ?auth ?subtask_of ?query ?body Http.Post path diff --git a/ocaml/libs/http-lib/xmlrpc_client.mli b/ocaml/libs/http-lib/xmlrpc_client.mli index 00d77b45937..52fb074db50 100644 --- a/ocaml/libs/http-lib/xmlrpc_client.mli +++ b/ocaml/libs/http-lib/xmlrpc_client.mli @@ -72,7 +72,6 @@ val xmlrpc : -> ?subtask_of:string -> ?query:(string * string) list -> ?body:string - -> ?tracing:Tracing.Span.t option -> string -> Http.Request.t (** Returns an HTTP.Request.t representing an XMLRPC request *) From c4962a31874b9009c57e3344354e31339aa078ee Mon Sep 17 00:00:00 2001 From: Colin James Date: Thu, 17 Oct 2024 09:20:51 +0100 Subject: [PATCH 07/12] CP-51772: Consolidate propagation into tracing lib Generalise the pattern used in http_svr.ml into a functor in the tracing library. In particular, so long as you can provide a way to name a carrier (to endow its child trace with), inject tracing context into a carrier, and extract trace context into a carrier, you can use this generic pattern to propagate tracing across arbitrary carriers (where the derived span is exported, but the incoming one is not). To this end, we factor it out of http_svr.ml and redefine the helper module used there in terms of one constructed from the new tracing propagator functor. The tracing_propagator library is used to provide definitions in the input module for defining trace propagation across HTTP headers. Signed-off-by: Colin James --- ocaml/libs/http-lib/http_svr.ml | 75 +++------------------------------ ocaml/libs/tracing/tracing.ml | 60 ++++++++++++++++++++++++++ ocaml/libs/tracing/tracing.mli | 30 +++++++++++++ 3 files changed, 95 insertions(+), 70 deletions(-) diff --git a/ocaml/libs/http-lib/http_svr.ml b/ocaml/libs/http-lib/http_svr.ml index 68ef0197d54..c4f7be5460c 100644 --- a/ocaml/libs/http-lib/http_svr.ml +++ b/ocaml/libs/http-lib/http_svr.ml @@ -99,77 +99,12 @@ let response_of_request req hdrs = ~headers:(connection :: cache :: hdrs) "200" "OK" -(* These functions have been factored out of Http.Request. - The carrier protocol should generally have no knowledge of tracing. *) -module type HelperS = sig - val traceparent_of : Http.Request.t -> Tracing.Span.t option - - val with_tracing : - ?attributes:(string * string) list - -> name:string - -> Http.Request.t - -> (Http.Request.t -> 'a) - -> 'a -end +module Helper = struct + include Tracing.Propagator.Make (struct + include Propagator.Http -module Helper : HelperS = struct - (* This code can probably be relocated into the tracing library - with the following generalisation: - - val with_tracing : - ?attributes:(string * string) list - -> name:string - -> Http.Request.t - -> (Http.Request.t -> 'a) - -> 'a - - can become: - - val with_tracing : - ?attributes:(string * string) list - -> inject: (TraceContext.t -> 'carrier -> 'carrier) - -> extract: ('carrier -> TraceContext.t) - -> name:string - -> 'carrier - -> ('carrier -> 'a) - -> 'a - - Can possibly pass a first-class module, but there may be a dependency cycle, - so functions are a more universal interface. - *) - - let traceparent_of req = - (* TODO: The extracted TraceContext must be propagated through the - spans. Simple approach is to add it to the SpanContext, and then - inherit it properly (substituting/creating only identity-related). *) - let open Tracing in - let ( let* ) = Option.bind in - let trace_context = Propagator.Http.extract_from req in - let* parent = TraceContext.traceparent_of trace_context in - let* span_context = SpanContext.of_traceparent parent in - Some (Tracer.span_of_span_context span_context req.uri) - - let with_tracing ?attributes ~name req f = - ignore (attributes, name) ; - let open Tracing in - let trace_context = Propagator.Http.extract_from req in - let parent = traceparent_of req in - let continue_with_child = function - | Some child -> - (* Here, "traceparent" is terminology for the [version-trace_id-span_id-flags] structure. - Therefore, the purpose of the code below is to decorate the request with the derived (child) span's ID. - This function only gets called if parent is not None. *) - let span_context = Span.get_context child in - let traceparent = SpanContext.to_traceparent span_context in - let trace_context' = - TraceContext.with_traceparent (Some traceparent) trace_context - in - let req' = Propagator.Http.inject_into trace_context' req in - f req' - | _ -> - f req - in - with_child_trace ?attributes parent ~name continue_with_child + let name_span req = req.Http.Request.uri + end) end let response_fct req ?(hdrs = []) s (response_length : int64) diff --git a/ocaml/libs/tracing/tracing.ml b/ocaml/libs/tracing/tracing.ml index cad2a8b2069..d0adde3e776 100644 --- a/ocaml/libs/tracing/tracing.ml +++ b/ocaml/libs/tracing/tracing.ml @@ -788,3 +788,63 @@ module EnvHelpers = struct Some (span |> Span.get_context |> SpanContext.to_traceparent) |> of_traceparent end + +module Propagator = struct + module type S = sig + type carrier + + val traceparent_of : carrier -> Span.t option + + val with_tracing : + ?attributes:(string * string) list + -> name:string + -> carrier + -> (carrier -> 'a) + -> 'a + end + + module type PropS = sig + type carrier + + val inject_into : TraceContext.t -> carrier -> carrier + + val extract_from : carrier -> TraceContext.t + + val name_span : carrier -> string + end + + module Make (P : PropS) : S with type carrier = P.carrier = struct + type carrier = P.carrier + + let traceparent_of carrier = + (* TODO: The extracted TraceContext must be propagated through the + spans. Simple approach is to add it to the SpanContext, and then + inherit it properly (substituting/creating only identity-related). *) + let ( let* ) = Option.bind in + let trace_context = P.extract_from carrier in + let* parent = TraceContext.traceparent_of trace_context in + let* span_context = SpanContext.of_traceparent parent in + let name = P.name_span carrier in + Some (Tracer.span_of_span_context span_context name) + + let with_tracing ?attributes ~name carrier f = + let trace_context = P.extract_from carrier in + let parent = traceparent_of carrier in + let continue_with_child = function + | Some child -> + (* Here, "traceparent" is terminology for the [version-trace_id-span_id-flags] structure. + Therefore, the purpose of the code below is to decorate the request with the derived (child) span's ID. + This function only gets called if parent is not None. *) + let span_context = Span.get_context child in + let traceparent = SpanContext.to_traceparent span_context in + let trace_context' = + TraceContext.with_traceparent (Some traceparent) trace_context + in + let carrier' = P.inject_into trace_context' carrier in + f carrier' + | _ -> + f carrier + in + with_child_trace ?attributes parent ~name continue_with_child + end +end diff --git a/ocaml/libs/tracing/tracing.mli b/ocaml/libs/tracing/tracing.mli index 5163a166002..e2d8c8d947d 100644 --- a/ocaml/libs/tracing/tracing.mli +++ b/ocaml/libs/tracing/tracing.mli @@ -297,3 +297,33 @@ module EnvHelpers : sig If [span] is [None], it returns an empty list. *) end + +(** [Propagator] is a utility module for creating trace propagators over arbitrary carriers. *) +module Propagator : sig + module type S = sig + type carrier + + val traceparent_of : carrier -> Span.t option + (** [traceparent_of carrier] creates a span whose context is that encoded within the [carrier] input. + If there is no traceparent encoded within the carrier, the function returns [None]. *) + + val with_tracing : + ?attributes:(string * string) list + -> name:string + -> carrier + -> (carrier -> 'a) + -> 'a + end + + module type PropS = sig + type carrier + + val inject_into : TraceContext.t -> carrier -> carrier + + val extract_from : carrier -> TraceContext.t + + val name_span : carrier -> string + end + + module Make : functor (P : PropS) -> S with type carrier = P.carrier +end From 6dad697a21691e258815f86840609b7a4f672b58 Mon Sep 17 00:00:00 2001 From: Colin James Date: Thu, 17 Oct 2024 09:47:38 +0100 Subject: [PATCH 08/12] CP-51772: Repair xapi-cli-server's tracing Use trace propagators to endow the Http.Request.t used for XML-RPC requests with in-service information, in order to propagate it. As before, the parent span is named "xe " and its span-id is what makes its way into the request. If the endpoint receiving the request wishes to, they can derive subsequent in-service tracing, rooted from this, by using with_tracing as define in Tracing's Propagator. Signed-off-by: Colin James --- ocaml/xapi-cli-server/xapi_cli.ml | 23 +++++++++++++++++++---- 1 file changed, 19 insertions(+), 4 deletions(-) diff --git a/ocaml/xapi-cli-server/xapi_cli.ml b/ocaml/xapi-cli-server/xapi_cli.ml index 5ea0f949210..21950bd2618 100644 --- a/ocaml/xapi-cli-server/xapi_cli.ml +++ b/ocaml/xapi-cli-server/xapi_cli.ml @@ -121,6 +121,21 @@ let with_session ~local rpc u p session f = (fun () -> f session) (fun () -> do_logout ()) +module TraceHelper = struct + include Tracing.Propagator.Make (struct + include Propagator.Http + + let name_span req = req.Http.Request.uri + end) + + let inject_span_into_req (span : Tracing.Span.t option) = + let module T = Tracing in + let span_context = Option.map T.Span.get_context span in + let traceparent = Option.map T.SpanContext.to_traceparent span_context in + let trace_context = T.TraceContext.(with_traceparent traceparent empty) in + Propagator.Http.inject_into trace_context +end + let do_rpcs _req s username password minimal cmd session args tracing = let cmdname = get_cmdname cmd in let cspec = @@ -137,9 +152,9 @@ let do_rpcs _req s username password minimal cmd session args tracing = try let generic_rpc = get_rpc () in (* NB the request we've received is for the /cli. We need an XMLRPC request for the API *) - Tracing.with_tracing ~parent:tracing ~name:("xe " ^ cmdname) - @@ fun tracing -> - let req = Xmlrpc_client.xmlrpc ~version:"1.1" ~tracing "/" in + Tracing.with_tracing ~parent:tracing ~name:("xe " ^ cmdname) @@ fun span -> + let req = Xmlrpc_client.xmlrpc ~version:"1.1" "/" in + let req = TraceHelper.inject_span_into_req span req in let rpc = generic_rpc req s in if do_forward then with_session ~local:false rpc username password session (fun sess -> @@ -190,9 +205,9 @@ let uninteresting_cmd_postfixes = ["help"; "-get"; "-list"] let exec_command req cmd s session args = let params = get_params cmd in let tracing = - let open Tracing in let ( let* ) = Option.bind in let context = Propagator.Http.extract_from req in + let open Tracing in let* traceparent = TraceContext.traceparent_of context in let* span_context = SpanContext.of_traceparent traceparent in let span = Tracer.span_of_span_context span_context (get_cmdname cmd) in From 673525e2945416c4da10279b18bd0fa3be1e2546 Mon Sep 17 00:00:00 2001 From: Colin James Date: Thu, 17 Oct 2024 12:34:36 +0100 Subject: [PATCH 09/12] CP-51772: Repair tracing in xapi Signed-off-by: Colin James --- ocaml/xapi/api_server.ml | 18 +++++++++++++----- ocaml/xapi/context.ml | 2 +- ocaml/xapi/dune | 2 ++ ocaml/xapi/helpers.ml | 18 +++++++++++++++--- ocaml/xapi/message_forwarding.ml | 10 ++++------ ocaml/xapi/server_helpers.ml | 10 +++++++++- ocaml/xapi/system_domains.ml | 3 ++- ocaml/xapi/xapi_pool.ml | 3 ++- 8 files changed, 48 insertions(+), 18 deletions(-) diff --git a/ocaml/xapi/api_server.ml b/ocaml/xapi/api_server.ml index 35cb14103e3..d79d2f659e7 100644 --- a/ocaml/xapi/api_server.ml +++ b/ocaml/xapi/api_server.ml @@ -3,9 +3,17 @@ module Server = Server.Make (Actions) (Forwarder) let ( let@ ) f x = f x +module Helper = struct + include Tracing.Propagator.Make (struct + include Propagator.Http + + let name_span req = req.Http.Request.uri + end) +end + (* This bit is called directly by the fake_rpc callback *) let callback1 ?(json_rpc_version = Jsonrpc.V1) is_json req fd call = - let@ req = Http.Request.with_tracing ~name:__FUNCTION__ req in + let@ req = Helper.with_tracing ~name:__FUNCTION__ req in (* We now have the body string, the xml and the call name, and can also tell *) (* if we're a master or slave and whether the call came in on the unix domain socket or the tcp socket *) (* If we're a slave, and the call is from the unix domain socket or from the HIMN, and the call *isn't* *) @@ -24,7 +32,7 @@ let callback1 ?(json_rpc_version = Jsonrpc.V1) is_json req fd call = forward req call is_json else let response = - let@ req = Http.Request.with_tracing ~name:"Server.dispatch_call" req in + let@ req = Helper.with_tracing ~name:"Server.dispatch_call" req in Server.dispatch_call req fd call in let translated = @@ -91,8 +99,8 @@ let create_thumbprint_header req response = (** HTML callback that dispatches an RPC and returns the response. *) let callback is_json req fd _ = - let@ req = Http.Request.with_tracing ~name:__FUNCTION__ req in - let span = Http.Request.traceparent_of req in + let@ req = Helper.with_tracing ~name:__FUNCTION__ req in + let span = Helper.traceparent_of req in (* fd only used for writing *) let body = Http_svr.read_body ~limit:Constants.http_limit_max_rpc_size req fd @@ -145,7 +153,7 @@ let callback is_json req fd _ = (** HTML callback that dispatches an RPC and returns the response. *) let jsoncallback req fd _ = - let@ req = Http.Request.with_tracing ~name:__FUNCTION__ req in + let@ req = Helper.with_tracing ~name:__FUNCTION__ req in (* fd only used for writing *) let body = Http_svr.read_body ~limit:Xapi_database.Db_globs.http_limit_max_rpc_size req diff --git a/ocaml/xapi/context.ml b/ocaml/xapi/context.ml index efb6ee61318..5df47bd2a57 100644 --- a/ocaml/xapi/context.ml +++ b/ocaml/xapi/context.ml @@ -218,11 +218,11 @@ let span_kind_of_parent parent = Option.fold ~none:SpanKind.Internal ~some:(fun _ -> SpanKind.Server) parent let parent_of_origin (origin : origin) span_name = - let open Tracing in let ( let* ) = Option.bind in match origin with | Http (req, _) -> let context = Propagator.Http.extract_from req in + let open Tracing in let* traceparent = TraceContext.traceparent_of context in let* span_context = SpanContext.of_traceparent traceparent in let span = Tracer.span_of_span_context span_context span_name in diff --git a/ocaml/xapi/dune b/ocaml/xapi/dune index dbcb9eb284f..5602e62d152 100644 --- a/ocaml/xapi/dune +++ b/ocaml/xapi/dune @@ -154,6 +154,7 @@ tar-unix threads.posix tracing + tracing_propagator unixpwd uri uuid @@ -240,6 +241,7 @@ stunnel threads.posix tracing + tracing_propagator xapi-backtrace xapi-client xapi-consts diff --git a/ocaml/xapi/helpers.ml b/ocaml/xapi/helpers.ml index 30965068f3f..f2f4f9747a1 100644 --- a/ocaml/xapi/helpers.ml +++ b/ocaml/xapi/helpers.ml @@ -387,6 +387,15 @@ let update_pif_addresses ~__context = Option.iter (fun (pif, bridge) -> set_DNS ~__context ~pif ~bridge) dns_if ; List.iter (fun self -> update_pif_address ~__context ~self) pifs +module TraceHelper = struct + let inject_span_into_req (span : Tracing.Span.t option) = + let module T = Tracing in + let span_context = Option.map T.Span.get_context span in + let traceparent = Option.map T.SpanContext.to_traceparent span_context in + let trace_context = T.TraceContext.(with_traceparent traceparent empty) in + Propagator.Http.inject_into trace_context +end + (* Note that both this and `make_timeboxed_rpc` are almost always * partially applied, returning a function of type 'Rpc.request -> Rpc.response'. * The body is therefore not evaluated until the RPC call is actually being @@ -395,7 +404,8 @@ let make_rpc ~__context rpc : Rpc.response = let subtask_of = Ref.string_of (Context.get_task_id __context) in let open Xmlrpc_client in let tracing = Context.set_client_span __context in - let http = xmlrpc ~subtask_of ~version:"1.1" "/" ~tracing in + let http = xmlrpc ~subtask_of ~version:"1.1" "/" in + let http = TraceHelper.inject_span_into_req tracing http in let transport = if Pool_role.is_master () then Unix Xapi_globs.unix_domain_socket @@ -418,7 +428,8 @@ let make_timeboxed_rpc ~__context timeout rpc : Rpc.response = * the task has acquired we make a new one specifically for the stunnel pid *) let open Xmlrpc_client in let tracing = Context.set_client_span __context in - let http = xmlrpc ~subtask_of ~version:"1.1" ~tracing "/" in + let http = xmlrpc ~subtask_of ~version:"1.1" "/" in + let http = TraceHelper.inject_span_into_req tracing http in let task_id = Context.get_task_id __context in let cancel () = let resources = @@ -486,7 +497,8 @@ let make_remote_rpc ?(verify_cert = Stunnel_client.pool ()) ~__context SSL (SSL.make ~verify_cert (), remote_address, !Constants.https_port) in let tracing = Context.tracing_of __context in - let http = xmlrpc ~version:"1.0" ~tracing "/" in + let http = xmlrpc ~version:"1.0" "/" in + let http = TraceHelper.inject_span_into_req tracing http in XMLRPC_protocol.rpc ~srcstr:"xapi" ~dststr:"remote_xapi" ~transport ~http xml (* Helper type for an object which may or may not be in the local database. *) diff --git a/ocaml/xapi/message_forwarding.ml b/ocaml/xapi/message_forwarding.ml index cb0b82aa7fd..6423e8d7be3 100644 --- a/ocaml/xapi/message_forwarding.ml +++ b/ocaml/xapi/message_forwarding.ml @@ -60,9 +60,8 @@ let remote_rpc_no_retry _context hostname (task_opt : API.ref_task option) xml = in let tracing = Context.set_client_span _context in let http = - xmlrpc - ?task_id:(Option.map Ref.string_of task_opt) - ~version:"1.0" ~tracing "/" + xmlrpc ?task_id:(Option.map Ref.string_of task_opt) ~version:"1.0" "/" + |> Helpers.TraceHelper.inject_span_into_req tracing in XMLRPC_protocol.rpc ~srcstr:"xapi" ~dststr:"dst_xapi" ~transport ~http xml @@ -80,9 +79,8 @@ let remote_rpc_retry _context hostname (task_opt : API.ref_task option) xml = in let tracing = Context.set_client_span _context in let http = - xmlrpc - ?task_id:(Option.map Ref.string_of task_opt) - ~version:"1.1" ~tracing "/" + xmlrpc ?task_id:(Option.map Ref.string_of task_opt) ~version:"1.1" "/" + |> Helpers.TraceHelper.inject_span_into_req tracing in XMLRPC_protocol.rpc ~srcstr:"xapi" ~dststr:"dst_xapi" ~transport ~http xml diff --git a/ocaml/xapi/server_helpers.ml b/ocaml/xapi/server_helpers.ml index e4952769c2f..ef50491c518 100644 --- a/ocaml/xapi/server_helpers.ml +++ b/ocaml/xapi/server_helpers.ml @@ -119,10 +119,18 @@ let dispatch_exn_wrapper f = let code, params = ExnHelper.error_of_exn exn in API.response_of_failure code params +module Helper = struct + include Tracing.Propagator.Make (struct + include Propagator.Http + + let name_span req = req.Http.Request.uri + end) +end + let do_dispatch ?session_id ?forward_op ?self:_ supports_async called_fn_name op_fn marshaller fd http_req label sync_ty generate_task_for = (* if the call has been forwarded to us, then they are responsible for completing the task, so we don't need to complete it *) - let@ http_req = Http.Request.with_tracing ~name:__FUNCTION__ http_req in + let@ http_req = Helper.with_tracing ~name:__FUNCTION__ http_req in let called_async = sync_ty <> `Sync in if called_async && not supports_async then API.response_of_fault diff --git a/ocaml/xapi/system_domains.ml b/ocaml/xapi/system_domains.ml index 5fb394605b1..0453c205566 100644 --- a/ocaml/xapi/system_domains.ml +++ b/ocaml/xapi/system_domains.ml @@ -181,7 +181,8 @@ let pingable ip () = let queryable ~__context transport () = let open Xmlrpc_client in let tracing = Context.set_client_span __context in - let http = xmlrpc ~version:"1.0" ~tracing "/" in + let http = xmlrpc ~version:"1.0" "/" in + let http = Helpers.TraceHelper.inject_span_into_req tracing http in let rpc = XMLRPC_protocol.rpc ~srcstr:"xapi" ~dststr:"remote_smapiv2" ~transport ~http in diff --git a/ocaml/xapi/xapi_pool.ml b/ocaml/xapi/xapi_pool.ml index 3a7dee78735..dd4bca70e26 100644 --- a/ocaml/xapi/xapi_pool.ml +++ b/ocaml/xapi/xapi_pool.ml @@ -3406,7 +3406,8 @@ let perform ~local_fn ~__context ~host op = let verify_cert = Some Stunnel.pool (* verify! *) in let task_id = Option.map Ref.string_of task_opt in let tracing = Context.set_client_span __context in - let http = xmlrpc ?task_id ~version:"1.0" ~tracing "/" in + let http = xmlrpc ?task_id ~version:"1.0" "/" in + let http = Helpers.TraceHelper.inject_span_into_req tracing http in let port = !Constants.https_port in let transport = SSL (SSL.make ~verify_cert ?task_id (), hostname, port) in XMLRPC_protocol.rpc ~srcstr:"xapi" ~dststr:"dst_xapi" ~transport ~http xml From 8e20e3e68f19e806e82e5b40872eceb8e1a6e886 Mon Sep 17 00:00:00 2001 From: Colin James Date: Mon, 21 Oct 2024 08:37:11 +0100 Subject: [PATCH 10/12] Restructuring - Wrap tracing_propagator library - Drop point-free style in parse Signed-off-by: Colin James --- ocaml/libs/http-lib/http_svr.ml | 2 +- ocaml/libs/tracing/dune | 1 - ocaml/libs/tracing/propagator.ml | 9 +++++---- ocaml/xapi-cli-server/xapi_cli.ml | 14 +++++++------- ocaml/xapi/api_server.ml | 2 +- ocaml/xapi/context.ml | 2 +- ocaml/xapi/helpers.ml | 10 +++++----- ocaml/xapi/server_helpers.ml | 2 +- 8 files changed, 21 insertions(+), 21 deletions(-) diff --git a/ocaml/libs/http-lib/http_svr.ml b/ocaml/libs/http-lib/http_svr.ml index c4f7be5460c..a7d52b23a31 100644 --- a/ocaml/libs/http-lib/http_svr.ml +++ b/ocaml/libs/http-lib/http_svr.ml @@ -101,7 +101,7 @@ let response_of_request req hdrs = module Helper = struct include Tracing.Propagator.Make (struct - include Propagator.Http + include Tracing_propagator.Propagator.Http let name_span req = req.Http.Request.uri end) diff --git a/ocaml/libs/tracing/dune b/ocaml/libs/tracing/dune index cf28881793a..71e5c7b7473 100644 --- a/ocaml/libs/tracing/dune +++ b/ocaml/libs/tracing/dune @@ -31,7 +31,6 @@ (library (name tracing_propagator) (modules propagator) - (wrapped false) (libraries astring http-lib tracing)) (test diff --git a/ocaml/libs/tracing/propagator.ml b/ocaml/libs/tracing/propagator.ml index 13c48bafce3..babd0c90476 100644 --- a/ocaml/libs/tracing/propagator.ml +++ b/ocaml/libs/tracing/propagator.ml @@ -54,12 +54,13 @@ module Http = struct | xs -> Some xs - let parse = + let parse input = let open Astring.String in let trim_pair (key, value) = (trim key, trim value) in - cuts ~sep:";" - >> List.map (cut ~sep:"=" >> Option.map trim_pair) - >> List.filter_map Fun.id + input + |> cuts ~sep:";" + |> List.map (cut ~sep:"=" >> Option.map trim_pair) + |> List.filter_map Fun.id let inject_into ctx req = let open Tracing in diff --git a/ocaml/xapi-cli-server/xapi_cli.ml b/ocaml/xapi-cli-server/xapi_cli.ml index 21950bd2618..a38115fd831 100644 --- a/ocaml/xapi-cli-server/xapi_cli.ml +++ b/ocaml/xapi-cli-server/xapi_cli.ml @@ -123,17 +123,17 @@ let with_session ~local rpc u p session f = module TraceHelper = struct include Tracing.Propagator.Make (struct - include Propagator.Http + include Tracing_propagator.Propagator.Http let name_span req = req.Http.Request.uri end) let inject_span_into_req (span : Tracing.Span.t option) = - let module T = Tracing in - let span_context = Option.map T.Span.get_context span in - let traceparent = Option.map T.SpanContext.to_traceparent span_context in - let trace_context = T.TraceContext.(with_traceparent traceparent empty) in - Propagator.Http.inject_into trace_context + let open Tracing in + let span_context = Option.map Span.get_context span in + let traceparent = Option.map SpanContext.to_traceparent span_context in + let trace_context = TraceContext.(with_traceparent traceparent empty) in + Tracing_propagator.Propagator.Http.inject_into trace_context end let do_rpcs _req s username password minimal cmd session args tracing = @@ -206,8 +206,8 @@ let exec_command req cmd s session args = let params = get_params cmd in let tracing = let ( let* ) = Option.bind in - let context = Propagator.Http.extract_from req in let open Tracing in + let context = Tracing_propagator.Propagator.Http.extract_from req in let* traceparent = TraceContext.traceparent_of context in let* span_context = SpanContext.of_traceparent traceparent in let span = Tracer.span_of_span_context span_context (get_cmdname cmd) in diff --git a/ocaml/xapi/api_server.ml b/ocaml/xapi/api_server.ml index d79d2f659e7..e6864bd80e1 100644 --- a/ocaml/xapi/api_server.ml +++ b/ocaml/xapi/api_server.ml @@ -5,7 +5,7 @@ let ( let@ ) f x = f x module Helper = struct include Tracing.Propagator.Make (struct - include Propagator.Http + include Tracing_propagator.Propagator.Http let name_span req = req.Http.Request.uri end) diff --git a/ocaml/xapi/context.ml b/ocaml/xapi/context.ml index 5df47bd2a57..56829d37d75 100644 --- a/ocaml/xapi/context.ml +++ b/ocaml/xapi/context.ml @@ -221,7 +221,7 @@ let parent_of_origin (origin : origin) span_name = let ( let* ) = Option.bind in match origin with | Http (req, _) -> - let context = Propagator.Http.extract_from req in + let context = Tracing_propagator.Propagator.Http.extract_from req in let open Tracing in let* traceparent = TraceContext.traceparent_of context in let* span_context = SpanContext.of_traceparent traceparent in diff --git a/ocaml/xapi/helpers.ml b/ocaml/xapi/helpers.ml index f2f4f9747a1..d75c4dce1c9 100644 --- a/ocaml/xapi/helpers.ml +++ b/ocaml/xapi/helpers.ml @@ -389,11 +389,11 @@ let update_pif_addresses ~__context = module TraceHelper = struct let inject_span_into_req (span : Tracing.Span.t option) = - let module T = Tracing in - let span_context = Option.map T.Span.get_context span in - let traceparent = Option.map T.SpanContext.to_traceparent span_context in - let trace_context = T.TraceContext.(with_traceparent traceparent empty) in - Propagator.Http.inject_into trace_context + let open Tracing in + let span_context = Option.map Span.get_context span in + let traceparent = Option.map SpanContext.to_traceparent span_context in + let trace_context = TraceContext.(with_traceparent traceparent empty) in + Tracing_propagator.Propagator.Http.inject_into trace_context end (* Note that both this and `make_timeboxed_rpc` are almost always diff --git a/ocaml/xapi/server_helpers.ml b/ocaml/xapi/server_helpers.ml index ef50491c518..1e8261b38f1 100644 --- a/ocaml/xapi/server_helpers.ml +++ b/ocaml/xapi/server_helpers.ml @@ -121,7 +121,7 @@ let dispatch_exn_wrapper f = module Helper = struct include Tracing.Propagator.Make (struct - include Propagator.Http + include Tracing_propagator.Propagator.Http let name_span req = req.Http.Request.uri end) From 4eb7185c0150010888f4135c3cfb7bfab06f2381 Mon Sep 17 00:00:00 2001 From: Colin James Date: Tue, 22 Oct 2024 09:05:39 +0100 Subject: [PATCH 11/12] CP-51772: Forward baggage from xe-cli If baggage is present in the environment, it will be sent to xapi-cli-server. Signed-off-by: Colin James --- ocaml/xe-cli/newcli.ml | 3 +++ 1 file changed, 3 insertions(+) diff --git a/ocaml/xe-cli/newcli.ml b/ocaml/xe-cli/newcli.ml index 56279d6a324..bb3a40d74de 100644 --- a/ocaml/xe-cli/newcli.ml +++ b/ocaml/xe-cli/newcli.ml @@ -817,6 +817,9 @@ let main () = let args = String.concat "\n" args in Printf.fprintf oc "User-agent: xe-cli/Unix/%d.%d\r\n" major minor ; Option.iter (Printf.fprintf oc "traceparent: %s\r\n") traceparent ; + Option.iter + (Printf.fprintf oc "baggage: %s\r\n") + (Sys.getenv_opt "BAGGAGE") ; Printf.fprintf oc "content-length: %d\r\n\r\n" (String.length args) ; Printf.fprintf oc "%s" args ; flush_all () ; From c5fe9baa5ad91974928639ca2454d46c215198f7 Mon Sep 17 00:00:00 2001 From: Colin James Date: Tue, 22 Oct 2024 14:34:06 +0100 Subject: [PATCH 12/12] CP-51772: Propagate trace context through spans Adds TraceContext to the SpanContext data structure and attempts to ensure its inheritance through each part of the code base. The API exposed by the tracing library is a bit problematic, it ought to be simplified and adapted to various use cases. Signed-off-by: Colin James --- ocaml/libs/http-lib/http_svr.ml | 15 +++++-- ocaml/libs/tracing/tracing.ml | 67 +++++++++++++++++++++------- ocaml/libs/tracing/tracing.mli | 7 +++ ocaml/libs/tracing/tracing_export.ml | 20 +++++++-- ocaml/xapi-cli-server/xapi_cli.ml | 36 +++++++++------ ocaml/xapi/context.ml | 3 +- ocaml/xapi/helpers.ml | 8 +++- 7 files changed, 116 insertions(+), 40 deletions(-) diff --git a/ocaml/libs/http-lib/http_svr.ml b/ocaml/libs/http-lib/http_svr.ml index a7d52b23a31..017587f3737 100644 --- a/ocaml/libs/http-lib/http_svr.ml +++ b/ocaml/libs/http-lib/http_svr.ml @@ -442,17 +442,24 @@ let read_request_exn ~proxy_seen ~read_timeout ~total_timeout ~max_length fd = already sent back a suitable error code and response to the client. *) let read_request ?proxy_seen ~read_timeout ~total_timeout ~max_length fd = try + (* TODO: Restore functionality of tracing this function. We rely on the request + to contain information we want spans to inherit. However, it is the reading of the + request that we intend to trace. *) + let r, proxy = + read_request_exn ~proxy_seen ~read_timeout ~total_timeout ~max_length fd + in + let trace_context = Tracing_propagator.Propagator.Http.extract_from r in let tracer = Tracing.Tracer.get_tracer ~name:"http_tracer" in let loop_span = - match Tracing.Tracer.start ~tracer ~name:__FUNCTION__ ~parent:None () with + match + Tracing.Tracer.start ~tracer ~trace_context ~name:__FUNCTION__ + ~parent:None () + with | Ok span -> span | Error _ -> None in - let r, proxy = - read_request_exn ~proxy_seen ~read_timeout ~total_timeout ~max_length fd - in let parent_span = Helper.traceparent_of r in let loop_span = Option.fold ~none:None diff --git a/ocaml/libs/tracing/tracing.ml b/ocaml/libs/tracing/tracing.ml index d0adde3e776..8beff835cec 100644 --- a/ocaml/libs/tracing/tracing.ml +++ b/ocaml/libs/tracing/tracing.ml @@ -95,7 +95,7 @@ let validate_attribute (key, value) = && W3CBaggage.Key.is_valid_key key module SpanKind = struct - type t = Server | Consumer | Client | Producer | Internal [@@deriving rpcty] + type t = Server | Consumer | Client | Producer | Internal let to_string = function | Server -> @@ -127,7 +127,7 @@ let endpoint_to_string = function let ok_none = Ok None module Status = struct - type status_code = Unset | Ok | Error [@@deriving rpcty] + type status_code = Unset | Ok | Error type t = {status_code: status_code; _description: string option} end @@ -229,9 +229,14 @@ module TraceContext = struct end module SpanContext = struct - type t = {trace_id: Trace_id.t; span_id: Span_id.t} [@@deriving rpcty] + type t = { + trace_id: Trace_id.t + ; span_id: Span_id.t + ; trace_context: TraceContext.t + } - let context trace_id span_id = {trace_id; span_id} + let context trace_id span_id = + {trace_id; span_id; trace_context= TraceContext.empty} let to_traceparent t = let tid = Trace_id.to_string t.trace_id in @@ -246,6 +251,7 @@ module SpanContext = struct { trace_id= Trace_id.of_string trace_id ; span_id= Span_id.of_string span_id + ; trace_context= TraceContext.empty } | _ -> None @@ -253,6 +259,15 @@ module SpanContext = struct let trace_id_of_span_context t = t.trace_id let span_id_of_span_context t = t.span_id + + let context_of_span_context t = t.trace_context + + let with_trace_context trace_context t = {t with trace_context} + + let of_trace_context trace_context = + let traceparent = TraceContext.traceparent_of trace_context in + let span_context = Option.(join (map of_traceparent traceparent)) in + Option.map (with_trace_context trace_context) span_context end module SpanLink = struct @@ -282,16 +297,25 @@ module Span = struct let get_context t = t.context - let start ?(attributes = Attributes.empty) ~name ~parent ~span_kind () = - let trace_id = + let start ?(attributes = Attributes.empty) + ?(trace_context : TraceContext.t option) ~name ~parent ~span_kind () = + let trace_id, extra_context = match parent with | None -> - Trace_id.make () + (Trace_id.make (), TraceContext.empty) | Some span_parent -> - span_parent.context.trace_id + (span_parent.context.trace_id, span_parent.context.trace_context) in let span_id = Span_id.make () in - let context : SpanContext.t = {trace_id; span_id} in + let context : SpanContext.t = + {trace_id; span_id; trace_context= extra_context} + 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 + in (* Using gettimeofday over Mtime as it is better for sharing timestamps between the systems *) let begin_time = Unix.gettimeofday () in let end_time = None in @@ -669,15 +693,18 @@ module Tracer = struct ; attributes= Attributes.empty } - let start ~tracer:t ?(attributes = []) ?(span_kind = SpanKind.Internal) ~name - ~parent () : (Span.t option, exn) result = + let start ~tracer:t ?(attributes = []) ?trace_context + ?(span_kind = SpanKind.Internal) ~name ~parent () : + (Span.t option, exn) result = let open TracerProvider in (* Do not start span if the TracerProvider is disabled*) if not t.enabled then ok_none else let attributes = Attributes.merge_into t.attributes attributes in - let span = Span.start ~attributes ~name ~parent ~span_kind () in + let span = + Span.start ~attributes ?trace_context ~name ~parent ~span_kind () + in Spans.add_to_spans ~span ; Ok (Some span) let update_span_with_parent span (parent : Span.t option) = @@ -691,9 +718,11 @@ module Tracer = struct |> Option.map (fun existing_span -> let old_context = Span.get_context existing_span in let new_context : SpanContext.t = + let trace_context = span.Span.context.trace_context in SpanContext.context (SpanContext.trace_id_of_span_context parent.context) old_context.span_id + |> SpanContext.with_trace_context trace_context in let updated_span = {existing_span with parent= Some parent} in let updated_span = {updated_span with context= new_context} in @@ -730,10 +759,10 @@ end let enable_span_garbage_collector ?(timeout = 86400.) () = Spans.GC.initialise_thread ~timeout -let with_tracing ?(attributes = []) ?(parent = None) ~name f = +let with_tracing ?(attributes = []) ?(parent = None) ?trace_context ~name f = let tracer = Tracer.get_tracer ~name in if tracer.enabled then ( - match Tracer.start ~tracer ~attributes ~name ~parent () with + match Tracer.start ~tracer ?trace_context ~attributes ~name ~parent () with | Ok span -> ( try let result = f span in @@ -751,12 +780,12 @@ let with_tracing ?(attributes = []) ?(parent = None) ~name f = ) else f None -let with_child_trace ?attributes parent ~name f = +let with_child_trace ?attributes ?trace_context parent ~name f = match parent with | None -> f None | Some _ as parent -> - with_tracing ?attributes ~parent ~name f + with_tracing ?attributes ?trace_context ~parent ~name f module EnvHelpers = struct let traceparent_key = "TRACEPARENT" @@ -824,6 +853,9 @@ module Propagator = struct let trace_context = P.extract_from carrier in let* parent = TraceContext.traceparent_of trace_context in let* span_context = SpanContext.of_traceparent parent in + let span_context = + SpanContext.with_trace_context trace_context span_context + in let name = P.name_span carrier in Some (Tracer.span_of_span_context span_context name) @@ -845,6 +877,7 @@ module Propagator = struct | _ -> f carrier in - with_child_trace ?attributes parent ~name continue_with_child + with_child_trace ?attributes ~trace_context parent ~name + continue_with_child end end diff --git a/ocaml/libs/tracing/tracing.mli b/ocaml/libs/tracing/tracing.mli index e2d8c8d947d..d20fda8c2e1 100644 --- a/ocaml/libs/tracing/tracing.mli +++ b/ocaml/libs/tracing/tracing.mli @@ -103,9 +103,13 @@ module SpanContext : sig val of_traceparent : string -> t option + val of_trace_context : TraceContext.t -> t option + val trace_id_of_span_context : t -> Trace_id.t val span_id_of_span_context : t -> Span_id.t + + val context_of_span_context : t -> TraceContext.t end module Span : sig @@ -164,6 +168,7 @@ module Tracer : sig val start : tracer:t -> ?attributes:(string * string) list + -> ?trace_context:TraceContext.t -> ?span_kind:SpanKind.t -> name:string -> parent:Span.t option @@ -250,12 +255,14 @@ val enable_span_garbage_collector : ?timeout:float -> unit -> unit val with_tracing : ?attributes:(string * string) list -> ?parent:Span.t option + -> ?trace_context:TraceContext.t -> name:string -> (Span.t option -> 'a) -> 'a val with_child_trace : ?attributes:(string * string) list + -> ?trace_context:TraceContext.t -> Span.t option -> name:string -> (Span.t option -> 'a) diff --git a/ocaml/libs/tracing/tracing_export.ml b/ocaml/libs/tracing/tracing_export.ml index 43761cdde1c..592a12bbb26 100644 --- a/ocaml/libs/tracing/tracing_export.ml +++ b/ocaml/libs/tracing/tracing_export.ml @@ -82,6 +82,16 @@ module Content = struct {timestamp; value} ) in + let tags = + let span_context = Span.get_context s in + let trace_context = + SpanContext.context_of_span_context span_context + in + let baggage = + TraceContext.baggage_of trace_context |> Option.value ~default:[] + in + Span.get_attributes s @ baggage + in { id= s @@ -117,7 +127,7 @@ module Content = struct |> Option.map SpanKind.to_string ; localEndpoint= {serviceName} ; annotations - ; tags= Span.get_attributes s + ; tags } let content_of (spans : Span.t list) = @@ -270,7 +280,10 @@ module Destination = struct ; ("xs.tracing.finished_spans_table.count", string_of_int count) ] in - let@ _ = with_tracing ~parent ~attributes ~name in + let@ _ = + with_tracing ~trace_context:TraceContext.empty ~parent ~attributes + ~name + in all_spans |> Content.Json.ZipkinV2.content_of |> export @@ -283,7 +296,8 @@ module Destination = struct let ((_span_list, span_count) as span_info) = Spans.since () in let attributes = [("export.traces.count", string_of_int span_count)] in let@ parent = - with_tracing ~parent:None ~attributes ~name:"Tracing.flush_spans" + with_tracing ~trace_context:TraceContext.empty ~parent:None ~attributes + ~name:"Tracing.flush_spans" in TracerProvider.get_tracer_providers () |> List.filter TracerProvider.get_enabled diff --git a/ocaml/xapi-cli-server/xapi_cli.ml b/ocaml/xapi-cli-server/xapi_cli.ml index a38115fd831..72057550ffd 100644 --- a/ocaml/xapi-cli-server/xapi_cli.ml +++ b/ocaml/xapi-cli-server/xapi_cli.ml @@ -132,11 +132,17 @@ module TraceHelper = struct let open Tracing in let span_context = Option.map Span.get_context span in let traceparent = Option.map SpanContext.to_traceparent span_context in - let trace_context = TraceContext.(with_traceparent traceparent empty) in + let trace_context = + Option.map SpanContext.context_of_span_context span_context + in + let trace_context = + Option.value ~default:TraceContext.empty trace_context + |> TraceContext.with_traceparent traceparent + in Tracing_propagator.Propagator.Http.inject_into trace_context end -let do_rpcs _req s username password minimal cmd session args tracing = +let do_rpcs req s username password minimal cmd session args = let cmdname = get_cmdname cmd in let cspec = try Hashtbl.find cmdtable cmdname @@ -151,8 +157,21 @@ let do_rpcs _req s username password minimal cmd session args tracing = let _ = check_required_keys cmd cspec.reqd in try let generic_rpc = get_rpc () in + let trace_context = Tracing_propagator.Propagator.Http.extract_from req in + let parent = + (* This is a "faux" span in the sense that it's not exported by the program. It exists + so that the derived child span can refer to its span-id as its parent during exportation + (along with inheriting the trace-id). *) + let open Tracing in + let ( let* ) = Option.bind in + let* traceparent = TraceContext.traceparent_of trace_context in + let* span_context = SpanContext.of_traceparent traceparent in + let span = Tracer.span_of_span_context span_context (get_cmdname cmd) in + Some span + in (* NB the request we've received is for the /cli. We need an XMLRPC request for the API *) - Tracing.with_tracing ~parent:tracing ~name:("xe " ^ cmdname) @@ fun span -> + Tracing.with_tracing ~trace_context ~parent ~name:("xe " ^ cmdname) + @@ fun span -> let req = Xmlrpc_client.xmlrpc ~version:"1.1" "/" in let req = TraceHelper.inject_span_into_req span req in let rpc = generic_rpc req s in @@ -204,15 +223,6 @@ let uninteresting_cmd_postfixes = ["help"; "-get"; "-list"] let exec_command req cmd s session args = let params = get_params cmd in - let tracing = - let ( let* ) = Option.bind in - let open Tracing in - let context = Tracing_propagator.Propagator.Http.extract_from req in - let* traceparent = TraceContext.traceparent_of context in - let* span_context = SpanContext.of_traceparent traceparent in - let span = Tracer.span_of_span_context span_context (get_cmdname cmd) in - Some span - in let minimal = List.assoc_opt "minimal" params |> Option.fold ~none:false ~some:bool_of_string @@ -271,7 +281,7 @@ let exec_command req cmd s session args = params ) ) ; - do_rpcs req s u p minimal cmd session args tracing + do_rpcs req s u p minimal cmd session args let get_line str i = try diff --git a/ocaml/xapi/context.ml b/ocaml/xapi/context.ml index 56829d37d75..5f357e110af 100644 --- a/ocaml/xapi/context.ml +++ b/ocaml/xapi/context.ml @@ -223,8 +223,7 @@ let parent_of_origin (origin : origin) span_name = | Http (req, _) -> let context = Tracing_propagator.Propagator.Http.extract_from req in let open Tracing in - let* traceparent = TraceContext.traceparent_of context in - let* span_context = SpanContext.of_traceparent traceparent in + let* span_context = SpanContext.of_trace_context context in let span = Tracer.span_of_span_context span_context span_name in Some span | _ -> diff --git a/ocaml/xapi/helpers.ml b/ocaml/xapi/helpers.ml index d75c4dce1c9..8c2f91fc2a3 100644 --- a/ocaml/xapi/helpers.ml +++ b/ocaml/xapi/helpers.ml @@ -392,7 +392,13 @@ module TraceHelper = struct let open Tracing in let span_context = Option.map Span.get_context span in let traceparent = Option.map SpanContext.to_traceparent span_context in - let trace_context = TraceContext.(with_traceparent traceparent empty) in + let trace_context = + Option.map SpanContext.context_of_span_context span_context + in + let trace_context = + Option.value ~default:TraceContext.empty trace_context + |> TraceContext.with_traceparent traceparent + in Tracing_propagator.Propagator.Http.inject_into trace_context end