CA-409628: Do not lose the original backtrace in log_backtrace

There are 2 log_backtrace functions in the Debug module, one of them prints the full backtrace,
the other one prints the backtrace just from the last time Backtrace.is_important got called,
i.e. it drops the *important* part of the backtrace.

Delete the buggy function and replace it with a function that always takes an exception,
so that we can look up any stashed backtrace.

There are good reasons why Backtrace.is_important wipes the current backtrace after it stashes it away (destroying the important part):
 * if it didn't, then every time Backtrace.is_important got called we'd get the same backtrace prefix appeneded multiple times
 * for cross-process/language backtraces to work you need to use Backtrace.get to retrieve the stashed backtrace when printing, and not use the OCaml one directly from Printexc.

 But that means you need to be disciplined in how you deal with backtraces:
 * catching and reraising the same exception with the same backtrace using Printexc.rawbacktrace is fine
 * the first statement in an exception handler needs to be either Backtrace.is_important, or Debug.log_backtrace (which calls is_important internally)

 Using Printexc.get_backtrace/Printexc.get_rawbacktrace for printing purposes has to be avoided if we ever called Backtrace.is_important.

 The updated unit test shows that we properly print line 8 as the source of the exception now.

 This fixes backtraces from xcp-rrdd.

Signed-off-by: Edwin Török <[email protected]>

Author: edwintorok

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:""
@@ -497,9 +498,10 @@ let read_request ?proxy_seen ~read_timeout ~total_timeout ~max_length fd =
                    (Unix.error_message a) b c
                 )
         | exc ->
+            Backtrace.is_important exc ;
             response_internal_error exc fd
               ~extra:(escape (Printexc.to_string exc)) ;
-            log_backtrace ()
+            log_backtrace 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

@@ -307,7 +307,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 +344,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/log_test.ml

@@ -13,5 +13,5 @@ let () =
   |> Debug.with_thread_associated "main" @@ fun () ->
      try Xapi_stdext_threads.Threadext.Mutex.execute m buggy
      with e ->
-       D.log_backtrace () ;
+       D.log_backtrace e ;
        D.warn "Got exception: %s" (Printexc.to_string e)

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 14, characters 9-60\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 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/xapi-cli-server/cli_frontend.ml

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

ocaml/xapi-guard/lib/server_interface.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/src/main.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
   ) ;