CP-50444: Instrument http svr with dt

dune

@@ -3,7 +3,7 @@
     (ocamlopt_flags (:standard -g -p -w -39))
     (flags (:standard -w -39))
   )
-  (dev (flags (:standard -g -w -39 -warn-error -69)))
+  (dev (flags (:standard -g -w -39)))
   (release
     (flags (:standard -w -39-6@5))
     (env-vars (ALCOTEST_COMPACT 1))

dune-project

@@ -205,6 +205,7 @@
    (xapi-rrd (= :version))
    (xapi-stdext-threads (= :version))
    (xapi-stdext-unix (= :version))
+   xapi-tracing
   )
 )
 

ocaml/libs/http-lib/dune

@@ -45,6 +45,7 @@
     ipaddr
     polly
     threads.posix
+    tracing
     uri
     xapi-log
     xapi-stdext-pervasives

ocaml/libs/http-lib/http.ml

@@ -694,6 +694,29 @@ 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
+    )
 end
 
 module Response = struct

ocaml/libs/http-lib/http.mli

@@ -128,6 +128,11 @@ 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 *)

ocaml/libs/http-lib/http_svr.ml

@@ -43,6 +43,8 @@ module E = Debug.Make (struct let name = "http_internal_errors" end)
 
 let ( let* ) = Option.bind
 
+let ( let@ ) f x = f x
+
 type uri_path = string
 
 module Stats = struct
@@ -101,6 +103,7 @@ let response_of_request req hdrs =
 
 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 res =
     {
       (response_of_request req hdrs) with
@@ -441,9 +444,28 @@ let request_of_bio_exn ~proxy_seen ~read_timeout ~total_timeout ~max_length bio
     	already sent back a suitable error code and response to the client. *)
 let request_of_bio ?proxy_seen ~read_timeout ~total_timeout ~max_length ic =
   try
+    let tracer = Tracing.Tracer.get_tracer ~name:"http_tracer" in
+    let loop_span =
+      match Tracing.Tracer.start ~tracer ~name:__FUNCTION__ ~parent:None () with
+      | Ok span ->
+          span
+      | Error _ ->
+          None
+    in
     let r, proxy =
       request_of_bio_exn ~proxy_seen ~read_timeout ~total_timeout ~max_length ic
     in
+    let parent_span = Http.Request.traceparent_of r in
+    let loop_span =
+      Option.fold ~none:None
+        ~some:(fun span ->
+          Tracing.Tracer.update_span_with_parent span parent_span
+        )
+        loop_span
+    in
+    let _ : (Tracing.Span.t option, exn) result =
+      Tracing.Tracer.finish loop_span
+    in
     (Some r, proxy)
   with e ->
     D.warn "%s (%s)" (Printexc.to_string e) __LOC__ ;
@@ -486,6 +508,8 @@ let request_of_bio ?proxy_seen ~read_timeout ~total_timeout ~max_length ic =
     (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 ic = Buf_io.of_fd ss in
   let finished = ref false in
   try
@@ -499,6 +523,7 @@ let handle_one (x : 'a Server.t) ss context req =
       Option.value ~default:empty
         (Radix_tree.longest_prefix req.Request.uri method_map)
     in
+    let@ _ = Tracing.with_child_trace span ~name:"handler" in
     ( match te.TE.handler with
     | BufIO handlerfn ->
         handlerfn req ic context
@@ -561,6 +586,7 @@ let handle_connection ~header_read_timeout ~header_total_timeout
       request_of_bio ?proxy_seen ~read_timeout ~total_timeout
         ~max_length:max_header_length ic
     in
+
     (* 2. now we attempt to process the request *)
     let finished =
       Option.fold ~none:true

ocaml/libs/tracing/tracing.ml

@@ -127,7 +127,7 @@ let ok_none = Ok None
 module Status = struct
   type status_code = Unset | Ok | Error [@@deriving rpcty]
 
-  type t = {status_code: status_code; description: string option}
+  type t = {status_code: status_code; _description: string option}
 end
 
 module Attributes = struct
@@ -151,6 +151,8 @@ end
 module SpanContext = struct
   type t = {trace_id: string; span_id: string} [@@deriving rpcty]
 
+  let context trace_id span_id = {trace_id; span_id}
+
   let to_traceparent t = Printf.sprintf "00-%s-%s-01" t.trace_id t.span_id
 
   let of_traceparent traceparent =
@@ -167,7 +169,7 @@ module SpanContext = struct
 end
 
 module SpanLink = struct
-  type t = {context: SpanContext.t; attributes: (string * string) list}
+  type t = {_context: SpanContext.t; _attributes: (string * string) list}
 end
 
 module Span = struct
@@ -208,7 +210,7 @@ module Span = struct
     (* 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
-    let status : Status.t = {status_code= Status.Unset; description= None} in
+    let status : Status.t = {status_code= Status.Unset; _description= None} in
     let links = [] in
     let events = [] in
     {
@@ -250,7 +252,7 @@ module Span = struct
   let set_span_kind span span_kind = {span with span_kind}
 
   let add_link span context attributes =
-    let link : SpanLink.t = {context; attributes} in
+    let link : SpanLink.t = {_context= context; _attributes= attributes} in
     {span with links= link :: span.links}
 
   let add_event span name attributes =
@@ -263,7 +265,7 @@ module Span = struct
     | exn, stacktrace -> (
         let msg = Printexc.to_string exn in
         let exn_type = Printexc.exn_slot_name exn in
-        let description =
+        let _description =
           Some
             (Printf.sprintf "Error: %s Type: %s Backtrace: %s" msg exn_type
                stacktrace
@@ -286,17 +288,17 @@ module Span = struct
                 span.attributes
                 (Attributes.of_list exn_attributes)
             in
-            {span with status= {status_code; description}; attributes}
+            {span with status= {status_code; _description}; attributes}
         | _ ->
             span
       )
 
   let set_ok span =
-    let description = None in
+    let _description = None in
     let status_code = Status.Ok in
     match span.status.status_code with
     | Unset ->
-        {span with status= {status_code; description}}
+        {span with status= {status_code; _description}}
     | _ ->
         span
 end
@@ -311,7 +313,7 @@ module Spans = struct
         Hashtbl.length spans
     )
 
-  let max_spans = Atomic.make 1000
+  let max_spans = Atomic.make 2500
 
   let set_max_spans x = Atomic.set max_spans x
 
@@ -519,8 +521,8 @@ module TracerProvider = struct
       get_tracer_providers_unlocked
 
   let set ?enabled ?attributes ?endpoints ~uuid () =
-    let update_provider (provider : t) ?(enabled = provider.enabled) attributes
-        endpoints =
+    let update_provider (provider : t) enabled attributes endpoints =
+      let enabled = Option.value ~default:provider.enabled enabled in
       let attributes : string Attributes.t =
         Option.fold ~none:provider.attributes ~some:Attributes.of_list
           attributes
@@ -537,7 +539,7 @@ module TracerProvider = struct
         let provider =
           match Hashtbl.find_opt tracer_providers uuid with
           | Some (provider : t) ->
-              update_provider provider ?enabled attributes endpoints
+              update_provider provider enabled attributes endpoints
           | None ->
               fail "The TracerProvider : %s does not exist" uuid
         in
@@ -564,9 +566,9 @@ module TracerProvider = struct
 end
 
 module Tracer = struct
-  type t = {name: string; provider: TracerProvider.t}
+  type t = {_name: string; provider: TracerProvider.t}
 
-  let create ~name ~provider = {name; provider}
+  let create ~name ~provider = {_name= name; provider}
 
   let no_op =
     let provider : TracerProvider.t =
@@ -577,7 +579,7 @@ module Tracer = struct
       ; enabled= false
       }
     in
-    {name= ""; provider}
+    {_name= ""; provider}
 
   let get_tracer ~name =
     if Atomic.get observe then (
@@ -598,7 +600,7 @@ module Tracer = struct
   let span_of_span_context context name : Span.t =
     {
       context
-    ; status= {status_code= Status.Unset; description= None}
+    ; status= {status_code= Status.Unset; _description= None}
     ; name
     ; parent= None
     ; span_kind= SpanKind.Client (* This will be the span of the client call*)
@@ -624,6 +626,30 @@ module Tracer = struct
       let span = Span.start ~attributes ~name ~parent ~span_kind () in
       Spans.add_to_spans ~span ; Ok (Some span)
 
+  let update_span_with_parent span (parent : Span.t option) =
+    if Atomic.get observe then
+      match parent with
+      | None ->
+          Some span
+      | Some parent ->
+          span
+          |> Spans.remove_from_spans
+          |> Option.map (fun existing_span ->
+                 let old_context = Span.get_context existing_span in
+                 let new_context : SpanContext.t =
+                   SpanContext.context
+                     (SpanContext.trace_id_of_span_context parent.context)
+                     old_context.span_id
+                 in
+                 let updated_span = {existing_span with parent= Some parent} in
+                 let updated_span = {updated_span with context= new_context} in
+
+                 let () = Spans.add_to_spans ~span:updated_span in
+                 updated_span
+             )
+    else
+      Some span
+
   let finish ?error span =
     Ok
       (Option.map
@@ -673,6 +699,13 @@ let with_tracing ?(attributes = []) ?(parent = None) ~name f =
   ) else
     f None
 
+let with_child_trace ?attributes parent ~name f =
+  match parent with
+  | None ->
+      f None
+  | Some _ as parent ->
+      with_tracing ?attributes ~parent ~name f
+
 module EnvHelpers = struct
   let traceparent_key = "TRACEPARENT"
 

ocaml/libs/tracing/tracing.mli

@@ -57,6 +57,8 @@ end
 module SpanContext : sig
   type t
 
+  val context : string -> string -> t
+
   val to_traceparent : t -> string
 
   val of_traceparent : string -> t option
@@ -125,6 +127,16 @@ module Tracer : sig
     -> unit
     -> (Span.t option, exn) result
 
+  val update_span_with_parent : Span.t -> Span.t option -> Span.t option
+  (**[update_span_with_parent s p] returns [Some span] where [span] is an 
+  updated verison of the span [s].
+  If [p] is [Some parent], [span] is a child of [parent], otherwise it is the 
+  original [s].
+
+  If the span [s] is finished or is no longer considered an on-going span, 
+  returns [None].
+  *)
+
   val finish :
     ?error:exn * string -> Span.t option -> (Span.t option, exn) result
 
@@ -199,6 +211,15 @@ val with_tracing :
   -> (Span.t option -> 'a)
   -> 'a
 
+val with_child_trace :
+     ?attributes:(string * string) list
+  -> Span.t option
+  -> name:string
+  -> (Span.t option -> 'a)
+  -> 'a
+(** [with_child_trace ?attributes ?parent ~name f] is like {!val:with_tracing}, but
+  only creates a span if the [parent] span exists. *)
+
 val get_observe : unit -> bool
 
 val validate_attribute : string * string -> bool