CP-311893: cross host backtraces for xe --trace (#6955)

xe `--trace` has existed since ~2014, but it isn't documented in
`--help`, and therefore not well known.
Also it only worked on a single host, limiting its usefulness in a pool.
However propagating backtraces between XAPIs in a pool is doable, by
using the already existing `backtrace` field in the Task object.

Having working cross-host backtraces appears to have been the original
design goal in
[doc/content/design/backtraces.md](https://github.com/xapi-project/xen-api/blob/master/doc/content/design/backtraces.md)

In theory this should also work cross-language, with python SM backends,
however some plumbing is missing there: it currently doesn't work with
either SMAPIv1 or SMAPIv3. Fixing that should be the topic of another PR
(by someone else).

Author: edwintorok

ocaml/libs/log/debug.ml

@@ -135,6 +135,10 @@ let facility = ref Syslog.Daemon
 
 let set_facility f = facility := f
 
+let set_backtrace_name this_host_name =
+  let name = Printf.sprintf "%s @ %s" Sys.argv.(0) this_host_name in
+  Backtrace.set_my_name name
+
 let get_facility () = !facility
 
 let output_log brand level priority s =

ocaml/libs/log/debug.mli

@@ -34,6 +34,9 @@ module type BRAND = sig val name : string end
 val set_facility : Syslog.facility -> unit
 (** Set the syslog facility that will be used by this program. *)
 
+val set_backtrace_name : string -> unit
+(** Set the hostname for backtraces *)
+
 val disable : ?level:Syslog.level -> string -> unit
 (** [disable brand] Suppress all log output from the given [brand]. Specifying a
     [level] disables * only this log level, otherwise all levels for the given

ocaml/xapi-idl/lib/task_server.ml

@@ -207,6 +207,8 @@ functor
       try SMap.find id !(tasks.task_map)
       with _ -> raise (Interface.does_not_exist ("task", id))
 
+    let backtrace_of t = t.backtrace
+
     let to_interface_task t =
       {
         Interface.Task.id= t.id

ocaml/xapi-idl/lib/task_server.mli

@@ -69,6 +69,8 @@ module Task : functor (Interface : INTERFACE) -> sig
 
   val to_interface_task : task_handle -> Interface.Task.t
 
+  val backtrace_of : task_handle -> Backtrace.t
+
   (* [add tasks dbg f] adds a new task with debug string [dbg] that will execute
      [f] when run *)
   val add :

ocaml/xapi-idl/lib/xcp_service.ml

@@ -443,6 +443,7 @@ let configure_common ~options ~resources arg_parse_fn =
   (* Register the Logs reporter to ensure we get log messages from libraries
      using Logs *)
   Debug.init_logs () ;
+  let () = try Unix.gethostname () |> Debug.set_backtrace_name with _ -> () in
   let resources = default_resources @ resources in
   let config_spec = common_options @ options @ to_opt resources in
   (* It's very confusing if there are duplicate key names *)

ocaml/xapi/create_misc.ml

@@ -155,6 +155,7 @@ let read_localhost_info ~__context =
     try Some (Xapi_inventory.lookup k) with _ -> None
   in
   let this_host_name = Networking_info.get_hostname () in
+  Debug.set_backtrace_name this_host_name ;
   let open Xapi_inventory in
   let open Xenops_interface.Host in
   {

ocaml/xapi/message_forwarding.ml

@@ -141,7 +141,14 @@ let do_op_on_common ~local_fn ~__context ~host ~remote_fn f =
       local_fn ~__context
     else
       let task_opt = set_forwarding_on_task ~__context ~host in
-      f __context host task_opt remote_fn
+      try f __context host task_opt remote_fn
+      with Api_errors.Server_error (_, _) as e -> (
+        match task_opt with
+        | None ->
+            raise e
+        | Some task ->
+            TaskHelper.reraise ~__context ~task e
+      )
   with
   | ( Xmlrpc_client.Connection_reset
     | Http_client.Http_request_rejected _

ocaml/xapi/server_helpers.ml

@@ -89,11 +89,17 @@ let exec_with_context ~__context ~need_complete ?marshaller ?f_forward ?quiet f
     with
     | Api_errors.Server_error (a, _) as e when a = Api_errors.task_cancelled ->
         Backtrace.is_important e ;
-        if need_complete then TaskHelper.cancel ~__context ;
+        if need_complete then
+          TaskHelper.cancel ~__context
+        else
+          TaskHelper.store_backtrace ~__context e ;
         raise e
     | e ->
         Backtrace.is_important e ;
-        if need_complete then TaskHelper.failed ~__context e ;
+        if need_complete then
+          TaskHelper.failed ~__context e
+        else
+          TaskHelper.store_backtrace ~__context e ;
         raise e
   in
   let@ () =

ocaml/xapi/taskHelper.ml

@@ -262,6 +262,18 @@ let cancel ~__context =
   let@ self = operate_on_db_task ~__context in
   cancel_this ~__context ~self
 
+let store_backtrace ~__context exn =
+  D.log_and_ignore_exn @@ fun () ->
+  let@ self = operate_on_db_task ~__context in
+  let status = Db_actions.DB_Action.Task.get_status ~__context ~self in
+  match status with
+  | `pending ->
+      (* store backtrace, for message-forwarding to read on the coordinator *)
+      Db_actions.DB_Action.Task.set_backtrace ~__context ~self
+        ~value:(Sexplib.Sexp.to_string Backtrace.(sexp_of_t (get exn)))
+  | _ ->
+      ()
+
 let failed ~__context exn =
   let backtrace = Printexc.get_raw_backtrace () in
   let@ () = finally_complete_tracing ~error:(exn, backtrace) __context in
@@ -293,6 +305,24 @@ let failed ~__context exn =
             "`failure"
         )
 
+let reraise ~__context ~task exn =
+  Backtrace.is_important exn ;
+  let () =
+    D.log_and_ignore_exn @@ fun () ->
+    (* best-effort: retrieve existing backtrace and join with local *)
+    let remote_bt =
+      Db_actions.DB_Action.Task.get_backtrace ~__context ~self:task
+      |> Sexplib.Sexp.of_string
+      |> Backtrace.t_of_sexp
+    in
+    let local_bt = Backtrace.remove exn in
+    (* start with remote Backtrace *)
+    Backtrace.add exn remote_bt ;
+    (* add back local *)
+    Backtrace.add exn local_bt
+  in
+  raise exn
+
 type id = Sm of string | Xenops of string * string
 
 (* queue name * id *)

ocaml/xapi/taskHelper.mli

@@ -55,9 +55,13 @@ val cancel_this : __context:Context.t -> self:API.ref_task -> unit
 
 val cancel : __context:Context.t -> unit
 
+val store_backtrace : __context:Context.t -> exn -> unit
+
 val failed : __context:Context.t -> exn -> unit
 (** Call this when a task fails with [exn] *)
 
+val reraise : __context:Context.t -> task:API.ref_task -> exn -> 'a
+
 val init : unit -> unit
 
 val rbac_assert_permission_fn :