Debug: add pretty-printing function for signals

When signals are are written to logs, the POSIX name should be used to minimize
confusion. It makes sense that the function that does this is in the logging
library instead of the unix one, as most users will be already be using the
logging library, but not all the unix one.

Moving it there also allows for a more ergonomic usage with the logging
functions.

Signed-off-by: Pau Ruiz Safont <[email protected]>

doc/content/design/coverage/index.md

@@ -98,8 +98,7 @@ terminated by receiving the `TERM` signal, a signal handler must be
 installed:
 
     let stop signal =
-      let name = Xapi_stdext_unix.Unixext.string_of_signal signal in
-      printf "caught signal %s\n" name;
+      printf "caught signal %a\n" Debug.Pp.signal signal;
       exit 0
 
     Sys.set_signal Sys.sigterm (Sys.Signal_handle stop)

ocaml/forkexecd/src/child.ml

@@ -111,11 +111,11 @@ let report_child_exit comms_sock args child_pid status =
         Fe.WEXITED n
     | Unix.WSIGNALED n ->
         log_failure args child_pid
-          (Printf.sprintf "exited with signal: %s" (Unixext.string_of_signal n)) ;
+          (Printf.sprintf "exited with signal: %a" Debug.Pp.signal n) ;
         Fe.WSIGNALED n
     | Unix.WSTOPPED n ->
         log_failure args child_pid
-          (Printf.sprintf "stopped with signal: %s" (Unixext.string_of_signal n)) ;
+          (Printf.sprintf "stopped with signal: %a" Debug.Pp.signal n) ;
         Fe.WSTOPPED n
   in
   let result = Fe.Finished pr in

ocaml/libs/log/debug.ml

@@ -353,4 +353,8 @@ functor
       with e -> log_backtrace_internal ~level:Syslog.Debug ~msg:"debug" e ()
   end
 
-module Pp = struct let mtime_span () = Fmt.str "%a" Mtime.Span.pp end
+module Pp = struct
+  let mtime_span () = Fmt.to_to_string Mtime.Span.pp
+
+  let signal () = Fmt.(to_to_string Dump.signal)
+end

ocaml/libs/log/debug.mli

@@ -91,4 +91,8 @@ val is_disabled : string -> Syslog.level -> bool
 
 module Pp : sig
   val mtime_span : unit -> Mtime.Span.t -> string
+
+  val signal : unit -> int -> string
+  (** signal pretty-prints an ocaml signal number as its POSIX name, see
+      {Fmt.Dump.signal} *)
 end

ocaml/libs/xapi-compression/xapi_compression.ml

@@ -123,22 +123,17 @@ module Make (Algorithm : ALGORITHM) = struct
           error "%s" msg ; failwith msg
         in
         Unixfd.safe_close close_later ;
-        let open Xapi_stdext_unix in
         match snd (Forkhelpers.waitpid pid) with
         | Unix.WEXITED 0 ->
             ()
         | Unix.WEXITED i ->
             failwith_error (Printf.sprintf "exit code %d" i)
         | Unix.WSIGNALED i ->
             failwith_error
-              (Printf.sprintf "killed by signal: %s"
-                 (Unixext.string_of_signal i)
-              )
+              (Printf.sprintf "killed by signal: %a" Debug.Pp.signal i)
         | Unix.WSTOPPED i ->
             failwith_error
-              (Printf.sprintf "stopped by signal: %s"
-                 (Unixext.string_of_signal i)
-              )
+              (Printf.sprintf "stopped by signal: %a" Debug.Pp.signal i)
       )
 
   let compress fd f = go Compress Active fd f

ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.ml

@@ -371,64 +371,6 @@ let kill_and_wait ?(signal = Sys.sigterm) ?(timeout = 10.) pid =
       raise Process_still_alive
   )
 
-let string_of_signal = function
-  | s when s = Sys.sigabrt ->
-      "SIGABRT"
-  | s when s = Sys.sigalrm ->
-      "SIGALRM"
-  | s when s = Sys.sigfpe ->
-      "SIGFPE"
-  | s when s = Sys.sighup ->
-      "SIGHUP"
-  | s when s = Sys.sigill ->
-      "SIGILL"
-  | s when s = Sys.sigint ->
-      "SIGINT"
-  | s when s = Sys.sigkill ->
-      "SIGKILL"
-  | s when s = Sys.sigpipe ->
-      "SIGPIPE"
-  | s when s = Sys.sigquit ->
-      "SIGQUIT"
-  | s when s = Sys.sigsegv ->
-      "SIGSEGV"
-  | s when s = Sys.sigterm ->
-      "SIGTERM"
-  | s when s = Sys.sigusr1 ->
-      "SIGUSR1"
-  | s when s = Sys.sigusr2 ->
-      "SIGUSR2"
-  | s when s = Sys.sigchld ->
-      "SIGCHLD"
-  | s when s = Sys.sigcont ->
-      "SIGCONT"
-  | s when s = Sys.sigstop ->
-      "SIGSTOP"
-  | s when s = Sys.sigttin ->
-      "SIGTTIN"
-  | s when s = Sys.sigttou ->
-      "SIGTTOU"
-  | s when s = Sys.sigvtalrm ->
-      "SIGVTALRM"
-  | s when s = Sys.sigprof ->
-      "SIGPROF"
-  | s when s = Sys.sigbus ->
-      "SIGBUS"
-  | s when s = Sys.sigpoll ->
-      "SIGPOLL"
-  | s when s = Sys.sigsys ->
-      "SIGSYS"
-  | s when s = Sys.sigtrap ->
-      "SIGTRAP"
-  | s when s = Sys.sigurg ->
-      "SIGURG"
-  | s when s = Sys.sigxcpu ->
-      "SIGXCPU"
-  | s when s = Sys.sigxfsz ->
-      "SIGXFSZ"
-  | s ->
-      Printf.sprintf "SIG(%d)" s
-
 let with_polly f =
   let polly = Polly.create () in
   let finally () = Polly.close polly in

ocaml/libs/xapi-stdext/lib/xapi-stdext-unix/unixext.mli

@@ -122,10 +122,6 @@ exception Process_still_alive
 
 val kill_and_wait : ?signal:int -> ?timeout:float -> int -> unit
 
-val string_of_signal : int -> string
-(** [string_of_signal x] translates an ocaml signal number into
- *  a string suitable for logging. *)
-
 val proxy : Unix.file_descr -> Unix.file_descr -> unit
 
 val really_read : Unix.file_descr -> bytes -> int -> int -> unit

ocaml/nbd/src/cleanup.ml

@@ -220,7 +220,7 @@ module Runtime = struct
         exit 0
     | Signal n ->
         Printf.eprintf "unexpected signal %s in signal handler - exiting"
-          (Xapi_stdext_unix.Unixext.string_of_signal n) ;
+          Fmt.(to_to_string Dump.signal n) ;
         flush stderr ;
         exit 1
     | e ->
@@ -230,7 +230,7 @@ module Runtime = struct
         exit 1
 
   let cleanup_resources signal =
-    let name = Xapi_stdext_unix.Unixext.string_of_signal signal in
+    let name = Fmt.(to_to_string Dump.signal signal) in
     let cleanup () =
       Lwt_log.warning_f "Caught signal %s, cleaning up" name >>= fun () ->
       (* First we have to close the open file descriptors corresponding to the

ocaml/nbd/src/dune

@@ -4,6 +4,7 @@
  (libraries
   cmdliner
   consts
+  fmt
   local_xapi_session
   lwt
   lwt.unix
@@ -19,7 +20,6 @@
   xapi-consts
   xapi-inventory
   xapi-types
-  xapi-stdext-unix
   xen-api-client-lwt
   )
 )

ocaml/networkd/bin/network_server.ml

@@ -53,8 +53,8 @@ let on_shutdown signal =
   let dbg = "shutdown" in
   Debug.with_thread_associated dbg
     (fun () ->
-      debug "xcp-networkd caught signal %s; performing cleanup actions."
-        (Xapi_stdext_unix.Unixext.string_of_signal signal) ;
+      debug "xcp-networkd caught signal %a; performing cleanup actions."
+        Debug.Pp.signal signal ;
       write_config ()
     )
     ()

ocaml/xapi-guard/lib/server_interface.ml

@@ -38,8 +38,8 @@ let shutdown = Lwt_switch.create ()
 
 let () =
   let cleanup n =
-    let n = Fmt.(to_to_string Dump.signal n) in
-    debug "Triggering cleanup on signal %s, and waiting for servers to stop" n ;
+    debug "Triggering cleanup on signal %a, and waiting for servers to stop"
+      Debug.Pp.signal n ;
     Lwt.async (fun () ->
         let* () = Lwt_switch.turn_off shutdown in
         info "Cleanup complete, exiting" ;

ocaml/xapi/helpers.ml

@@ -104,15 +104,14 @@ let call_script ?(log_output = Always) ?env ?stdin ?timeout script args =
         (ExnHelper.string_of_exn e) ;
       raise e
   | Forkhelpers.Spawn_internal_error (stderr, stdout, status) as e ->
-      let signal = Unixext.string_of_signal in
       let message =
         match status with
         | Unix.WEXITED n ->
             Printf.sprintf "exited with code %d" n
         | Unix.WSIGNALED n ->
-            Printf.sprintf "was killed by signal %s" (signal n)
+            Printf.sprintf "was killed by signal %a" Debug.Pp.signal n
         | Unix.WSTOPPED n ->
-            Printf.sprintf "was stopped by signal %s" (signal n)
+            Printf.sprintf "was stopped by signal %a" Debug.Pp.signal n
       in
       if should_log_output_on_failure then
         debug "%s %s %s [stdout = '%s'; stderr = '%s']" script

ocaml/xapi/sm_exec.ml

@@ -393,7 +393,7 @@ let exec_xmlrpc ~dbg ?context:_ ?(needs_session = true) (driver : string)
                    (Backend_error
                       ( Api_errors.sr_backend_failure
                       , [
-                          "received signal: " ^ Unixext.string_of_signal i
+                          Printf.sprintf "received signal: %a" Debug.Pp.signal i
                         ; output
                         ; log
                         ]

ocaml/xapi/xapi_extensions.ml

@@ -50,8 +50,7 @@ let call_extension rpc =
                ( Api_errors.internal_error
                , [
                    path
-                 ; Printf.sprintf "signal: %s"
-                     (Xapi_stdext_unix.Unixext.string_of_signal i)
+                 ; Printf.sprintf "signal: %a" Debug.Pp.signal i
                  ; output
                  ; log
                  ]

ocaml/xapi/xapi_plugins.ml

@@ -49,12 +49,7 @@ let call_plugin session_id plugin_name fn_name args =
         raise
           (Api_errors.Server_error
              ( Api_errors.xenapi_plugin_failure
-             , [
-                 Printf.sprintf "signal: %s"
-                   (Xapi_stdext_unix.Unixext.string_of_signal i)
-               ; output
-               ; log
-               ]
+             , [Printf.sprintf "signal: %a" Debug.Pp.signal i; output; log]
              )
           )
     | Forkhelpers.Spawn_internal_error (log, output, Unix.WEXITED _) ->

ocaml/xcp-rrdd/bin/rrdd/xcp_rrdd.ml

@@ -735,7 +735,7 @@ let configure_writers () =
 (** we need to make sure we call exit on fatal signals to make sure profiling
     data is dumped *)
 let stop err writers signal =
-  debug "caught signal %s" (Xapi_stdext_unix.Unixext.string_of_signal signal) ;
+  debug "caught signal %a" Debug.Pp.signal signal ;
   List.iter (fun (_, writer) -> writer.Rrd_writer.cleanup ()) writers ;
   exit err
 

ocaml/xcp-rrdd/lib/plugin/utils.ml

@@ -59,13 +59,12 @@ let exec_cmd (module D : Debug.DEBUG) ~cmdstring ~(f : string -> 'a option) =
   (try loop () with End_of_file -> ()) ;
   Unix.close out_readme ;
   let pid, status = Forkhelpers.waitpid pid in
-  let signal = Xapi_stdext_unix.Unixext.string_of_signal in
   ( match status with
   | Unix.WEXITED n ->
       D.debug "Process %d exited normally with code %d" pid n
   | Unix.WSIGNALED s ->
-      D.debug "Process %d was killed by signal %s" pid (signal s)
+      D.debug "Process %d was killed by signal %a" pid Debug.Pp.signal s
   | Unix.WSTOPPED s ->
-      D.debug "Process %d was stopped by signal %s" pid (signal s)
+      D.debug "Process %d was stopped by signal %a" pid Debug.Pp.signal s
   ) ;
   List.rev !vals

ocaml/xenopsd/lib/cancellable_subprocess.ml

@@ -77,15 +77,14 @@ let run (task : Xenops_task.task_handle) ?env ?stdin fds
         | Unix.WSTOPPED n ->
             raise (Spawn_internal_error (err, out, Unix.WSTOPPED n))
         | Unix.WSIGNALED s ->
-            let signal = Unixext.string_of_signal s in
             if !cancelled then (
               debug
-                "Subprocess %s exited with signal %s and cancel requested; \
+                "Subprocess %s exited with signal %a and cancel requested; \
                  raising Cancelled"
-                cmd signal ;
+                cmd Debug.Pp.signal s ;
               Xenops_task.raise_cancelled task
             ) else (
-              debug "Subprocess %s exited with signal %s" cmd signal ;
+              debug "Subprocess %s exited with signal %a" cmd Debug.Pp.signal s ;
               raise (Spawn_internal_error (err, out, Unix.WSIGNALED s))
             )
       )

ocaml/xenopsd/lib/suspend_image.ml

@@ -275,15 +275,15 @@ let with_conversion_script task name hvm fd f =
         | Unix.WSIGNALED n ->
             Error
               (Failure
-                 (Printf.sprintf "Conversion script exited with signal %s"
-                    (Unixext.string_of_signal n)
+                 (Printf.sprintf "Conversion script exited with signal %a"
+                    Debug.Pp.signal n
                  )
               )
         | Unix.WSTOPPED n ->
             Error
               (Failure
-                 (Printf.sprintf "Conversion script stopped with signal %s"
-                    (Unixext.string_of_signal n)
+                 (Printf.sprintf "Conversion script stopped with signal %a"
+                    Debug.Pp.signal n
                  )
               )
       )

ocaml/xenopsd/lib/xenopsd.ml

@@ -461,7 +461,7 @@ let main backend =
   (* we need to catch this to make sure at_exit handlers are triggered. In
      particular, triggers for the bisect_ppx coverage profiling *)
   let signal_handler n =
-    debug "caught signal %s" (Unixext.string_of_signal n) ;
+    debug "caught signal %a" Debug.Pp.signal n ;
     exit 0
   in
   Sys.set_signal Sys.sigpipe Sys.Signal_ignore ;