CP-53470 Additional traces around xenopsd VM_migrate & rejoin traceparents in requests forwarded to xenopsd by xapi (xapi-project#6275)

Reconnected VM_receive_memory span to VM.migrate:
When xapi passes the traceparent header to xenopsd it is serialised
under the additional_headers field of the json body, updated xenopsd to
expect that instead of sourcing it from the non existent traceparent
field

Added some additional spans around vm migration critical section
including the specific point we receive the suspend from
emu-manager/xenguest - this required moving the with_tracing function to
a more common location

Author: edwintorok

ocaml/xenopsd/lib/xenops_migrate.ml

@@ -95,7 +95,7 @@ module Forwarded_http_request = struct
   type t = {
       uri: string
     ; query: (string * string) list
-    ; traceparent: string option
+    ; additional_headers: (string * string) list
     ; cookie: (string * string) list
     ; body: string option
   }

ocaml/xenopsd/lib/xenops_server.ml

@@ -1835,28 +1835,6 @@ let rec atomics_of_operation = function
   | _ ->
       []
 
-let with_tracing ~name ~task f =
-  let open Tracing in
-  let parent = Xenops_task.tracing task in
-  let tracer = Tracer.get_tracer ~name in
-  match Tracer.start ~tracer ~name ~parent () with
-  | Ok span -> (
-      Xenops_task.set_tracing task span ;
-      try
-        let result = f () in
-        ignore @@ Tracer.finish span ;
-        Xenops_task.set_tracing task parent ;
-        result
-      with exn ->
-        let backtrace = Printexc.get_raw_backtrace () in
-        let error = (exn, backtrace) in
-        ignore @@ Tracer.finish span ~error ;
-        raise exn
-    )
-  | Error e ->
-      warn "Failed to start tracing: %s" (Printexc.to_string e) ;
-      f ()
-
 let rec perform_atomic ~progress_callback ?result (op : atomic)
     (t : Xenops_task.task_handle) : unit =
   let module B = (val get_backend () : S) in

ocaml/xenopsd/lib/xenops_task.ml

@@ -1,5 +1,7 @@
 open Xenops_utils
 
+module D = Debug.Make (struct let name = __MODULE__ end)
+
 module XI = struct
   include Xenops_interface
 
@@ -89,3 +91,25 @@ let traceparent_header_of_task t =
     )
     (Xenops_task.tracing t)
   |> Option.to_list
+
+let with_tracing ~name ~task f =
+  let open Tracing in
+  let parent = Xenops_task.tracing task in
+  let tracer = Tracer.get_tracer ~name in
+  match Tracer.start ~tracer ~name ~parent () with
+  | Ok span -> (
+      Xenops_task.set_tracing task span ;
+      try
+        let result = f () in
+        let _ : (Span.t option, exn) result = Tracer.finish span in
+        Xenops_task.set_tracing task parent ;
+        result
+      with exn ->
+        let backtrace = Printexc.get_raw_backtrace () in
+        let error = (exn, backtrace) in
+        let _ : (Span.t option, exn) result = Tracer.finish span ~error in
+        raise exn
+    )
+  | Error e ->
+      D.warn "Failed to start tracing: %s" (Printexc.to_string e) ;
+      f ()

ocaml/xenopsd/lib/xenopsd.ml

@@ -356,7 +356,8 @@ let handle_received_fd this_connection =
         let context = {Xenops_server.transferred_fd= Some received_fd} in
         let uri = Uri.of_string req.Xenops_migrate.Forwarded_http_request.uri in
         let traceparent =
-          req.Xenops_migrate.Forwarded_http_request.traceparent
+          List.assoc_opt "traceparent"
+            req.Xenops_migrate.Forwarded_http_request.additional_headers
         in
         fn uri req.Xenops_migrate.Forwarded_http_request.cookie traceparent
           this_connection context

ocaml/xenopsd/xc/device.ml

@@ -2501,6 +2501,7 @@ module Backend = struct
       let assert_can_suspend ~xs:_ _ = ()
 
       let suspend (task : Xenops_task.task_handle) ~xs ~qemu_domid domid =
+        with_tracing ~task ~name:"Qemu_none.Dm.suspend" @@ fun () ->
         Dm_Common.signal task ~xs ~qemu_domid ~domid "save" ~wait_for:"paused"
 
       let stop ~xs:_ ~qemu_domid:_ ~vtpm:_ _ = ()
@@ -3180,7 +3181,8 @@ module Backend = struct
 
       (* key not present *)
 
-      let suspend (_ : Xenops_task.task_handle) ~xs:_ ~qemu_domid:_ domid =
+      let suspend (task : Xenops_task.task_handle) ~xs:_ ~qemu_domid:_ domid =
+        with_tracing ~task ~name:"Qemu_upstream_compat.Dm.suspend" @@ fun () ->
         let as_msg cmd = Qmp.(Success (Some __LOC__, cmd)) in
         let perms = [Unix.O_WRONLY; Unix.O_CREAT] in
         let save_file = sprintf qemu_save_path domid in
@@ -3860,7 +3862,8 @@ module Dm = struct
     debug "Called Dm.restore_vgpu" ;
     start_vgpu ~xc ~xs task ~restore:true domid vgpus vcpus profile
 
-  let suspend_varstored (_ : Xenops_task.task_handle) ~xs domid ~vm_uuid =
+  let suspend_varstored (task : Xenops_task.task_handle) ~xs domid ~vm_uuid =
+    with_tracing ~task ~name:"Dm.suspend_varstored" @@ fun () ->
     debug "Called Dm.suspend_varstored (domid=%d)" domid ;
     Service.Varstored.stop ~xs domid ;
     Xenops_sandbox.Varstore_guard.read ~domid efivars_save_path ~vm_uuid
@@ -3877,6 +3880,7 @@ module Dm = struct
     debug "Wrote EFI variables to %s (domid=%d)" path domid
 
   let suspend_vtpm (task : Xenops_task.task_handle) ~xs domid ~vtpm =
+    with_tracing ~task ~name:"Dm.suspend_vtpm" @@ fun () ->
     debug "Called Dm.suspend_vtpm (domid=%d)" domid ;
     let dbg = Xenops_task.get_dbg task in
     Option.map

ocaml/xenopsd/xc/domain.ml

@@ -1703,22 +1703,23 @@ let suspend_emu_manager ~(task : Xenops_task.task_handle) ~xc:_ ~xs ~domain_type
           (string_of_message message) ;
         match message with
         | Suspend ->
-            do_suspend_callback () ;
-            if domain_type = `hvm then (
-              let vm_uuid = Uuidx.to_string uuid in
-              debug "VM = %s; domid = %d; suspending qemu-dm" vm_uuid domid ;
-              Device.Dm.suspend task ~xs ~qemu_domid ~dm domid ;
-              if is_uefi then
-                let (_ : string) =
-                  Device.Dm.suspend_varstored task ~xs domid ~vm_uuid
-                in
-                let (_ : string list) =
-                  Device.Dm.suspend_vtpm task ~xs domid ~vtpm
-                in
-                ()
+            ( with_tracing ~task ~name:"suspend_emu_manager Suspend" @@ fun () ->
+              do_suspend_callback () ;
+              if domain_type = `hvm then (
+                let vm_uuid = Uuidx.to_string uuid in
+                debug "VM = %s; domid = %d; suspending qemu-dm" vm_uuid domid ;
+                Device.Dm.suspend task ~xs ~qemu_domid ~dm domid ;
+                if is_uefi then
+                  let (_ : string) =
+                    Device.Dm.suspend_varstored task ~xs domid ~vm_uuid
+                  in
+                  let (_ : string list) =
+                    Device.Dm.suspend_vtpm task ~xs domid ~vtpm
+                  in
+                  ()
+              )
             ) ;
-            send_done cnx ;
-            wait_for_message ()
+            send_done cnx ; wait_for_message ()
         | Prepare x when x = "xenguest" ->
             debug "Writing Libxc header" ;
             write_header main_fd (Libxc, 0L) >>= fun () ->
@@ -1741,6 +1742,7 @@ let suspend_emu_manager ~(task : Xenops_task.task_handle) ~xc:_ ~xs ~domain_type
                 )
         )
         | Result _ ->
+            with_tracing ~task ~name:"suspend_emu_manager Result" @@ fun () ->
             debug "VM = %s; domid = %d; emu-manager completed successfully"
               (Uuidx.to_string uuid) domid ;
             return ()

ocaml/xenopsd/xc/dune

@@ -51,6 +51,8 @@
   xapi-stdext-std
   xapi-stdext-threads
   xapi-stdext-unix
+  xapi-tracing
+  xapi-tracing-export
   xapi_xenopsd
   xapi_xenopsd_c_stubs
   xapi_xenopsd_xc_c_stubs

ocaml/xenopsd/xc/xenops_server_xen.ml

@@ -2499,15 +2499,35 @@ module VM = struct
                   None
             in
             let manager_path = choose_emu_manager vm.Vm.platformdata in
+            with_tracing ~task ~name:"VM_save_domain_suspend" @@ fun () ->
             Domain.suspend task ~xc ~xs ~domain_type ~dm:(dm_of ~vm)
               ~vtpm:(vtpm_of ~vm) ~progress_callback ~qemu_domid ~manager_path
               ~is_uefi vm_str domid fd vgpu_fd flags' (fun () ->
+                with_tracing ~task ~name:"VM_save_domain_suspend_callback"
+                @@ fun () ->
                 (* SCTX-2558: wait more for ballooning if needed *)
-                wait_ballooning task vm ;
-                pre_suspend_callback task ;
-                if not (request_shutdown task vm Suspend 30.) then
+                ( with_tracing ~task ~name:"VM_save_wait_ballooning" @@ fun () ->
+                  wait_ballooning task vm
+                ) ;
+                ( with_tracing ~task ~name:"VM_save_pre_suspend_callback"
+                @@ fun () -> pre_suspend_callback task
+                ) ;
+
+                if
+                  not
+                    ( with_tracing ~task
+                        ~name:"VM_save_domain_suspend_callback_request_shutdown"
+                    @@ fun () -> request_shutdown task vm Suspend 30.
+                    )
+                then
                   raise (Xenopsd_error Failed_to_acknowledge_suspend_request) ;
-                if not (wait_shutdown task vm Suspend 1200.) then
+                if
+                  not
+                    ( with_tracing ~task
+                        ~name:"VM_save_domain_suspend_callback_wait_shutdown"
+                    @@ fun () -> wait_shutdown task vm Suspend 1200.
+                    )
+                then
                   raise (Xenopsd_error (Failed_to_suspend (vm.Vm.id, 1200.)))
             ) ;
             (* Record the final memory usage of the domain so we know how much