CA-409628: fix error-prone Debug.log_backtrace that always lost the important part of the backtrace (#6430)

Before/after can be seen clearly in the newly added unit test:
* previously line 8 was not printed anywhere, even though that is the
actual place the exception is raised
* the whole backtrace was printed on a single line, which can be quite
annoying

After:
* line 8 is present
* the correct backtrace printer is used that prints each stack frame on
a separate line with a counter

```diff --git a/ocaml/libs/log/test/log_test.t b/ocaml/libs/log/test/log_test.t
index f25ee70..fbdeebf 100644
--- a/ocaml/libs/log/test/log_test.t
+++ b/ocaml/libs/log/test/log_test.t
@@ -1,4 +1,9 @@
   $ ./log_test.exe | sed -re 's/[0-9]+T[0-9:.]+Z//'
-  [|debug||0 |main|log_test.ml] Raised at Xapi_stdext_pervasives__Pervasiveext.finally in file \"ocaml/libs/xapi-stdext/lib/xapi-stdext-pervasives/pervasiveext.ml\", line 39, characters 6-15\nCalled from Dune__exe__Log_test.(fun) in file \"ocaml/libs/log/test/log_test.ml\", line 15, characters 4-55\n
+  [|error||0 |main|backtrace] Raised Invalid_argument("index out of bounds")
+  [|error||0 |main|backtrace] 1/4 log_test.exe Raised at file ocaml/libs/log/test/log_test.ml, line 8
+  [|error||0 |main|backtrace] 2/4 log_test.exe Called from file ocaml/libs/xapi-stdext/lib/xapi-stdext-pervasives/pervasiveext.ml, line 24
+  [|error||0 |main|backtrace] 3/4 log_test.exe Called from file ocaml/libs/xapi-stdext/lib/xapi-stdext-pervasives/pervasiveext.ml, line 39
+  [|error||0 |main|backtrace] 4/4 log_test.exe Called from file ocaml/libs/log/test/log_test.ml, line 15
+  [|error||0 |main|backtrace]
```

Author: robhoes

ocaml/gencert/selfcert.ml

@@ -109,6 +109,7 @@ let generate_pub_priv_key length =
       let stdout, _stderr = call_openssl args in
       Ok stdout
     with e ->
+      Backtrace.is_important e ;
       let msg = "generating RSA key failed" in
       D.error "selfcert.ml: %s" msg ;
       Debug.log_backtrace e (Backtrace.get e) ;

ocaml/libs/http-lib/dune

@@ -1,109 +1,103 @@
 (library
-  (name http_lib)
-  (public_name http-lib)
-  (modes best)
-  (wrapped false)
-  (modules (:standard \ http_svr http_proxy server_io http_test radix_tree_test test_client test_server))
-  (preprocess (per_module ((pps ppx_deriving_rpc) Http)))
-  (libraries
-    astring
-    base64
-    fmt
-    ipaddr
-    mtime
-    mtime.clock.os
-    rpclib.core
-    rpclib.json
-    rpclib.xml
-    safe_resources
-    sha
-    stunnel
-    threads.posix
-    uuid
-    uri
-    xapi-backtrace
-    xapi-consts.xapi_version
-    xapi-idl.updates
-    xapi-log
-    clock
-    xapi-stdext-pervasives
-    xapi-stdext-threads
-    xapi-stdext-unix
-    xml-light2
-  )
-)
+ (name http_lib)
+ (public_name http-lib)
+ (modes best)
+ (wrapped false)
+ (modules
+  (:standard
+   \
+   http_svr
+   http_proxy
+   server_io
+   http_test
+   radix_tree_test
+   test_client
+   test_server))
+ (preprocess
+  (per_module
+   ((pps ppx_deriving_rpc)
+    Http)))
+ (libraries
+  astring
+  base64
+  fmt
+  ipaddr
+  mtime
+  mtime.clock.os
+  rpclib.core
+  rpclib.json
+  rpclib.xml
+  safe_resources
+  sha
+  stunnel
+  threads.posix
+  uuid
+  uri
+  xapi-backtrace
+  xapi-consts.xapi_version
+  xapi-idl.updates
+  xapi-log
+  clock
+  xapi-stdext-pervasives
+  xapi-stdext-threads
+  xapi-stdext-unix
+  xml-light2))
 
 (library
-  (name httpsvr)
-  (wrapped false)
-  (modes best)
-  (modules http_svr http_proxy server_io)
-  (libraries
-    astring
-    http_lib
-    ipaddr
-    polly
-    tgroup
-    threads.posix
-    tracing
-    tracing_propagator
-    uri
-    xapi-log
-    xapi-stdext-pervasives
-    xapi-stdext-threads
-    xapi-stdext-unix
-  )
-)
+ (name httpsvr)
+ (wrapped false)
+ (modes best)
+ (modules http_svr http_proxy server_io)
+ (libraries
+  astring
+  http_lib
+  ipaddr
+  polly
+  tgroup
+  threads.posix
+  tracing
+  tracing_propagator
+  uri
+  xapi-backtrace
+  xapi-log
+  xapi-stdext-pervasives
+  xapi-stdext-threads
+  xapi-stdext-unix))
 
 (tests
-  (names http_test radix_tree_test)
-  (package http-lib)
-  (modes (best exe))
-  (modules http_test radix_tree_test)
-  (libraries
-    alcotest
-
-    fmt
-    http_lib
-  )
-)
+ (names http_test radix_tree_test)
+ (package http-lib)
+ (modes
+  (best exe))
+ (modules http_test radix_tree_test)
+ (libraries alcotest fmt http_lib))
 
 (executable
-  (modes exe)
-  (name test_client)
-  (modules test_client)
-  (libraries
-
-    http_lib
-    safe-resources
-    stunnel
-    threads.posix
-    xapi-backtrace
-    xapi-log
-    xapi-stdext-pervasives
-    xapi-stdext-unix
-  )
-)
+ (modes exe)
+ (name test_client)
+ (modules test_client)
+ (libraries
+  http_lib
+  safe-resources
+  stunnel
+  threads.posix
+  xapi-backtrace
+  xapi-log
+  xapi-stdext-pervasives
+  xapi-stdext-unix))
 
 (executable
-  (modes exe)
-  (name test_server)
-  (modules test_server)
-  (libraries
-
-    http_lib
-    httpsvr
-    safe-resources
-    threads.posix
-    xapi-stdext-threads
-    xapi-stdext-unix
-  )
-)
+ (modes exe)
+ (name test_server)
+ (modules test_server)
+ (libraries
+  http_lib
+  httpsvr
+  safe-resources
+  threads.posix
+  xapi-stdext-threads
+  xapi-stdext-unix))
 
 (cram
-  (package xapi)
-  (deps
-    test_client.exe
-    test_server.exe
-  )
-)
+ (package xapi)
+ (deps test_client.exe test_server.exe))

ocaml/libs/http-lib/http_svr.ml

@@ -189,8 +189,9 @@ let response_request_header_fields_too_large s =
   response_error_html s "431" "Request Header Fields Too Large" [] body
 
 let response_internal_error ?req ?extra exc s =
+  Backtrace.is_important exc ;
   E.error "Responding with 500 Internal Error due to %s" (Printexc.to_string exc) ;
-  E.log_backtrace () ;
+  E.log_backtrace exc ;
   let version = Option.map get_return_version req in
   let extra =
     Option.fold ~none:""
@@ -473,6 +474,7 @@ let read_request ?proxy_seen ~read_timeout ~total_timeout ~max_length fd =
     in
     (Some r, proxy)
   with e ->
+    Backtrace.is_important e ;
     D.warn "%s (%s)" (Printexc.to_string e) __LOC__ ;
     best_effort (fun () ->
         match e with
@@ -498,8 +500,7 @@ let read_request ?proxy_seen ~read_timeout ~total_timeout ~max_length fd =
                 )
         | exc ->
             response_internal_error exc fd
-              ~extra:(escape (Printexc.to_string exc)) ;
-            log_backtrace ()
+              ~extra:(escape (Printexc.to_string exc))
     ) ;
     (None, None)
 

ocaml/libs/http-lib/server_io.ml

@@ -53,12 +53,13 @@ let establish_server ?(signal_fds = []) forker handler sock =
              let s, caller = Unix.accept ~cloexec:true sock in
              try ignore (forker handler s caller)
              with exc ->
+               Backtrace.is_important exc ;
                (* NB provided 'forker' is configured to make a background thread then the
                   only way we can get here is if Thread.create fails.
                   This means we haven't executed any code which could close the fd therefore
                   we should do it ourselves. *)
                debug "Got exception in server_io.ml: %s" (Printexc.to_string exc) ;
-               log_backtrace () ;
+               log_backtrace exc ;
                Unix.close s ;
                Thread.delay 30.0
          )

ocaml/libs/log/debug.ml

@@ -258,6 +258,10 @@ let with_thread_associated ?client ?(quiet = false) desc f x =
       (* This function is a top-level exception handler typically used on fresh
          threads. This is the last chance to do something with the backtrace *)
       if not quiet then (
+        (* It would seem that a Backtrace.is_important would be missing here.
+           But in fact it has actually been called in [let result] above,
+           so calling it again is not necessary.
+        *)
         output_log "backtrace" Syslog.Err "error"
           (Printf.sprintf "%s failed with exception %s" desc
              (Printexc.to_string exn)
@@ -307,7 +311,7 @@ module type DEBUG = sig
 
   val audit : ?raw:bool -> ('a, unit, string, string) format4 -> 'a
 
-  val log_backtrace : unit -> unit
+  val log_backtrace : exn -> unit
 
   val log_and_ignore_exn : (unit -> unit) -> unit
 end
@@ -344,9 +348,10 @@ functor
         )
         fmt
 
-    let log_backtrace () =
-      let backtrace = Printexc.get_backtrace () in
-      debug "%s" (String.escaped backtrace)
+    let log_backtrace exn =
+      let level = Syslog.Debug in
+      if not (is_disabled Brand.name level) then
+        log_backtrace_internal ~level exn ()
 
     let log_and_ignore_exn f =
       try f ()

ocaml/libs/log/debug.mli

@@ -76,7 +76,15 @@ module type DEBUG = sig
   val audit : ?raw:bool -> ('a, unit, string, string) format4 -> 'a
   (** Audit function *)
 
-  val log_backtrace : unit -> unit
+  val log_backtrace : exn -> unit
+  (** [log_backtrace exn] logs the backtrace associated with [exn].
+      Either this or {!Backtrace.is_important} must be the first statement in an exception handler,
+      otherwise the backtrace may be overwritten (e.g. by formatting functions that internally raise and catch exceptions).
+
+      This has to be used instead of getting a new backtrace from Printexc if [Backtrace.is_important] was ever called,
+      because that function stashes away the backtrace and then overwrites the current backtrace (to avoid duplicate frames in the stacktrace,
+      when Backtrace.get is used).
+   *)
 
   val log_and_ignore_exn : (unit -> unit) -> unit
 end

ocaml/libs/log/test/dune

@@ -0,0 +1,6 @@
+(executable
+ (name log_test)
+ (libraries log xapi-stdext-threads threads.posix xapi-backtrace))
+
+(cram
+ (deps log_test.exe))

ocaml/libs/log/test/log_test.ml

@@ -0,0 +1,17 @@
+module D = Debug.Make (struct let name = Filename.basename __FILE__ end)
+
+let m = Mutex.create ()
+
+let a = [||]
+
+let buggy () = a.(1) <- 0
+
+let () =
+  Printexc.record_backtrace true ;
+  Debug.log_to_stdout () ;
+  ()
+  |> Debug.with_thread_associated "main" @@ fun () ->
+     try Xapi_stdext_threads.Threadext.Mutex.execute m buggy
+     with e ->
+       D.log_backtrace e ;
+       D.warn "Got exception: %s" (Printexc.to_string e)

ocaml/libs/log/test/log_test.mli

@@ -0,0 +1,9 @@
+  $ ./log_test.exe | sed -re 's/[0-9]+T[0-9:.]+Z//'
+  [|error||0 |main|backtrace] Raised Invalid_argument("index out of bounds")
+  [|error||0 |main|backtrace] 1/4 log_test.exe Raised at file ocaml/libs/log/test/log_test.ml, line 7
+  [|error||0 |main|backtrace] 2/4 log_test.exe Called from file ocaml/libs/xapi-stdext/lib/xapi-stdext-pervasives/pervasiveext.ml, line 24
+  [|error||0 |main|backtrace] 3/4 log_test.exe Called from file ocaml/libs/xapi-stdext/lib/xapi-stdext-pervasives/pervasiveext.ml, line 39
+  [|error||0 |main|backtrace] 4/4 log_test.exe Called from file ocaml/libs/log/test/log_test.ml, line 14
+  [|error||0 |main|backtrace] 
+  [| warn||0 |main|log_test.ml] Got exception: Invalid_argument("index out of bounds")
+

ocaml/libs/log/test/log_test.t

@@ -4052,7 +4052,6 @@ let rio_help printer minimal cmd =
         in
         printer (Cli_printer.PTable [recs])
     | None ->
-        D.log_backtrace () ;
         error "Responding with Unknown command %s" cmd ;
         printer (Cli_printer.PList ["Unknown command '" ^ cmd ^ "'"])
   in

ocaml/xapi-cli-server/cli_frontend.ml

@@ -58,7 +58,7 @@ let with_xapi ~cache ?(timeout = 120.) f =
 let serve_forever_lwt path callback =
   let conn_closed _ = () in
   let on_exn e =
-    log_backtrace () ;
+    log_backtrace e ;
     warn "Exception: %s" (Printexc.to_string e)
   in
   let stop, do_stop = Lwt.task () in

ocaml/xapi-guard/lib/server_interface.ml

@@ -299,7 +299,7 @@ let make_message_switch_server () =
         (* best effort resume *)
         let* () =
           Lwt.catch (resume ~vtpm_read_write ~uefi_read_write) (fun e ->
-              D.log_backtrace () ;
+              D.log_backtrace e ;
               D.warn "Resume failed: %s" (Printexc.to_string e) ;
               Lwt.return_unit
           )
@@ -321,7 +321,7 @@ let main log_level =
   let old_hook = !Lwt.async_exception_hook in
   (Lwt.async_exception_hook :=
      fun exn ->
-       D.log_backtrace () ;
+       D.log_backtrace exn ;
        D.error "Lwt caught async exception: %s" (Printexc.to_string exn) ;
        old_hook exn
   ) ;

ocaml/xapi-guard/src/main.ml

@@ -68,7 +68,7 @@ let () =
   let old_hook = !Lwt.async_exception_hook in
   Lwt.async_exception_hook :=
     fun exn ->
-      D.log_backtrace () ;
+      D.log_backtrace exn ;
       D.error "Lwt caught async exception: %s" (Printexc.to_string exn) ;
       old_hook exn
 

ocaml/xapi-guard/test/xapi_guard_test.ml

@@ -87,7 +87,6 @@ let gpu_err =
       def= gpu_errors
     ; raiser=
         (fun e ->
-          log_backtrace () ;
           let exn = Gpumon_error e in
           error "%s (%s)" (Printexc.to_string exn) __LOC__ ;
           raise exn

ocaml/xapi-idl/gpumon/gpumon_interface.ml

@@ -87,7 +87,6 @@ let err =
       def= errors
     ; raiser=
         (fun e ->
-          log_backtrace () ;
           let exn = MemoryError e in
           error "%s (%s)" (Printexc.to_string exn) __LOC__ ;
           raise exn