From f0003e62da3e44e363d577c2c4d71c4592728c8f Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= <edwin.torok@cloud.com>
Date: Thu, 25 Apr 2024 16:42:28 +0100
Subject: [PATCH] CP-49134: tracing: do not destroy stacktrace
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

Reraise with the original stacktrace, this requires using the raw backtrace instead of the string one.

Signed-off-by: Edwin Török <edwin.torok@cloud.com>
---
 ocaml/libs/tracing/tracing.ml      | 5 +++--
 ocaml/libs/tracing/tracing.mli     | 4 +++-
 ocaml/tests/test_observer.ml       | 2 +-
 ocaml/xapi/context.ml              | 2 +-
 ocaml/xapi/context.mli             | 2 +-
 ocaml/xapi/taskHelper.ml           | 2 +-
 ocaml/xenopsd/lib/xenops_server.ml | 2 +-
 7 files changed, 11 insertions(+), 8 deletions(-)

diff --git a/ocaml/libs/tracing/tracing.ml b/ocaml/libs/tracing/tracing.ml
index ab097253dcb..3f521f6f29c 100644
--- a/ocaml/libs/tracing/tracing.ml
+++ b/ocaml/libs/tracing/tracing.ml
@@ -331,6 +331,7 @@ module Span = struct
     | exn, stacktrace -> (
         let msg = Printexc.to_string exn in
         let exn_type = Printexc.exn_slot_name exn in
+        let stacktrace = Printexc.raw_backtrace_to_string stacktrace in
         let _description =
           Some
             (Printf.sprintf "Error: %s Type: %s Backtrace: %s" msg exn_type
@@ -720,10 +721,10 @@ let with_tracing ?(attributes = []) ?(parent = None) ~name f =
         ignore @@ Tracer.finish span ;
         result
       with exn ->
-        let backtrace = Printexc.get_backtrace () in
+        let backtrace = Printexc.get_raw_backtrace () in
         let error = (exn, backtrace) in
         ignore @@ Tracer.finish span ~error ;
-        raise exn
+        Printexc.raise_with_backtrace exn backtrace
     )
     | Error e ->
         warn "Failed to start tracing: %s" (Printexc.to_string e) ;
diff --git a/ocaml/libs/tracing/tracing.mli b/ocaml/libs/tracing/tracing.mli
index e78153c9790..18b248cc881 100644
--- a/ocaml/libs/tracing/tracing.mli
+++ b/ocaml/libs/tracing/tracing.mli
@@ -163,7 +163,9 @@ module Tracer : sig
   *)
 
   val finish :
-    ?error:exn * string -> Span.t option -> (Span.t option, exn) result
+       ?error:exn * Printexc.raw_backtrace
+    -> Span.t option
+    -> (Span.t option, exn) result
 
   val span_hashtbl_is_empty : unit -> bool
 
diff --git a/ocaml/tests/test_observer.ml b/ocaml/tests/test_observer.ml
index 7ea23a05939..2e2f8e6aa29 100644
--- a/ocaml/tests/test_observer.ml
+++ b/ocaml/tests/test_observer.ml
@@ -466,7 +466,7 @@ let test_tracing_exn_backtraces () =
       let (_ : int) = test_a () in
       ()
     with e -> (
-      let stacktrace = Printexc.get_backtrace () in
+      let stacktrace = Printexc.get_raw_backtrace () in
       let x = Tracer.finish ~error:(e, stacktrace) x in
       match x with
       | Ok (Some span) ->
diff --git a/ocaml/xapi/context.ml b/ocaml/xapi/context.ml
index 7027caaec67..41faa238bd5 100644
--- a/ocaml/xapi/context.ml
+++ b/ocaml/xapi/context.ml
@@ -517,7 +517,7 @@ let with_tracing ?originator ~__context name f =
       result
     with exn ->
       let backtrace = Printexc.get_raw_backtrace () in
-      let error = (exn, Printexc.raw_backtrace_to_string backtrace) in
+      let error = (exn, backtrace) in
       ignore @@ Tracer.finish span ~error ;
       Printexc.raise_with_backtrace exn backtrace
   )
diff --git a/ocaml/xapi/context.mli b/ocaml/xapi/context.mli
index 98e04215272..34e51afd2ee 100644
--- a/ocaml/xapi/context.mli
+++ b/ocaml/xapi/context.mli
@@ -142,7 +142,7 @@ val get_client_ip : t -> string option
 
 val get_user_agent : t -> string option
 
-val complete_tracing : ?error:exn * string -> t -> unit
+val complete_tracing : ?error:exn * Printexc.raw_backtrace -> t -> unit
 
 val tracing_of : t -> Tracing.Span.t option
 
diff --git a/ocaml/xapi/taskHelper.ml b/ocaml/xapi/taskHelper.ml
index 30d36c0ed37..465859e7fca 100644
--- a/ocaml/xapi/taskHelper.ml
+++ b/ocaml/xapi/taskHelper.ml
@@ -265,7 +265,7 @@ let cancel ~__context =
   cancel_this ~__context ~self
 
 let failed ~__context exn =
-  let backtrace = Printexc.get_backtrace () in
+  let backtrace = Printexc.get_raw_backtrace () in
   let@ () = finally_complete_tracing ~error:(exn, backtrace) __context in
   let code, params = ExnHelper.error_of_exn exn in
   let@ self = operate_on_db_task ~__context in
diff --git a/ocaml/xenopsd/lib/xenops_server.ml b/ocaml/xenopsd/lib/xenops_server.ml
index 579ce5d6f05..e5d8016bedb 100644
--- a/ocaml/xenopsd/lib/xenops_server.ml
+++ b/ocaml/xenopsd/lib/xenops_server.ml
@@ -1840,7 +1840,7 @@ let with_tracing ~name ~task f =
         Xenops_task.set_tracing task parent ;
         result
       with exn ->
-        let backtrace = Printexc.get_backtrace () in
+        let backtrace = Printexc.get_raw_backtrace () in
         let error = (exn, backtrace) in
         ignore @@ Tracer.finish span ~error ;
         raise exn