Libguestfs - Jul 2022 - [PATCH common 2/4] mltools: Reimplement On_exit to use a list of actions

https://bugzilla.redhat.com/show_bug.cgi?id=1953286#c26

This set of changes enhances the common/mltools On_exit module to:

 - allow actions to be ordered using a priority field

 - allow waiting for killed subprocesses to exit (with some caveats)

Related set of changes to virt-v2v will follow.

This will require some changes to libguestfs and guestfs-tools
projects which I have not done yet because I want to get feedback on
the approach first.

Rich.

Make it clearer what this function does and that it's potentially
dangerous.  The functionality itself is unchanged.
---
 mltools/on_exit.ml  | 2 +-
 mltools/on_exit.mli | 2 +-
 2 files changed, 2 insertions(+), 2 deletions(-)

diff --git a/mltools/on_exit.ml b/mltools/on_exit.ml
index 53ccb68..9cdc496 100644
--- a/mltools/on_exit.ml
+++ b/mltools/on_exit.ml
@@ -102,7 +102,7 @@ let unlink filename    register ();
   List.push_front filename files
 
-let rmdir dir +let rm_rf dir    register ();
   List.push_front dir rmdirs
 
diff --git a/mltools/on_exit.mli b/mltools/on_exit.mli
index a02e3db..9bcf104 100644
--- a/mltools/on_exit.mli
+++ b/mltools/on_exit.mli
@@ -47,7 +47,7 @@ val f : (unit -> unit) -> unit
 val unlink : string -> unit
 (** Unlink a single temporary file on exit. *)
 
-val rmdir : string -> unit
+val rm_rf : string -> unit
 (** Recursively remove a temporary directory on exit (using [rm -rf]). *)
 
 val kill : ?signal:int -> int -> unit
-- 
2.37.0.rc2

Previously we used separate lists of files, dirs, pids, etc.  This
makes it harder to introduce new features to reorder actions.
Reimplement the module so we use a simple list of actions, where each
action can have type File, Rm_rf, Kill, etc.  Iterate through this
list on exit to execute the actions.

The actions will run in a different order from before, but we didn't
guarantee the ordering before.  Apart from that the functionality is
unchanged.
---
 mltools/on_exit.ml | 48 ++++++++++++++++++++++------------------------
 1 file changed, 23 insertions(+), 25 deletions(-)

diff --git a/mltools/on_exit.ml b/mltools/on_exit.ml
index 9cdc496..4fa2c3b 100644
--- a/mltools/on_exit.ml
+++ b/mltools/on_exit.ml
@@ -23,23 +23,29 @@ open Common_gettext.Gettext
 open Unix
 open Printf
 
-(* List of files to unlink. *)
-let files = ref []
+type action +  | Unlink of string     (* filename *)
+  | Rm_rf of string      (* directory *)
+  | Kill of int * int    (* signal, pid *)
+  | Fn of (unit -> unit) (* generic function *)
 
-(* List of directories to remove. *)
-let rmdirs = ref []
-
-(* List of PIDs to kill. *)
-let kills = ref []
-
-(* List of functions to call. *)
-let fns = ref []
+(* List of actions. *)
+let actions = ref []
 
 (* Perform a single exit action, printing any exception but
  * otherwise ignoring failures.
  *)
-let do_action f arg -  try f arg with exn -> debug "%s"
(Printexc.to_string exn)
+let do_action action +  try
+    match action with
+    | Unlink file -> Unix.unlink file
+    | Rm_rf dir ->
+       let cmd = sprintf "rm -rf %s" (Filename.quote dir) in
+       ignore (Tools_utils.shell_command cmd)
+    | Kill (signal, pid) ->
+       kill pid signal
+    | Fn f -> f ()
+  with exn -> debug "%s" (Printexc.to_string exn)
 
 (* Make sure the actions are performed only once. *)
 let done_actions = ref false
@@ -47,15 +53,7 @@ let done_actions = ref false
 (* Perform the exit actions. *)
 let do_actions ()    if not !done_actions then (
-    List.iter (do_action (fun f -> f ())) !fns;
-    List.iter (do_action (fun (signal, pid) -> kill pid signal)) !kills;
-    List.iter (do_action (fun file -> Unix.unlink file)) !files;
-    List.iter (do_action (
-      fun dir ->
-        let cmd = sprintf "rm -rf %s" (Filename.quote dir) in
-        ignore (Tools_utils.shell_command cmd)
-      )
-    ) !rmdirs;
+    List.iter do_action !actions
   );
   done_actions := true
 
@@ -96,16 +94,16 @@ let register ()  
 let f fn    register ();
-  List.push_front fn fns
+  List.push_front (Fn fn) actions
 
 let unlink filename    register ();
-  List.push_front filename files
+  List.push_front (Unlink filename) actions
 
 let rm_rf dir    register ();
-  List.push_front dir rmdirs
+  List.push_front (Rm_rf dir) actions
 
 let kill ?(signal = Sys.sigterm) pid    register ();
-  List.push_front (signal, pid) kills
+  List.push_front (Kill (signal, pid)) actions
-- 
2.37.0.rc2

Introduce a new, optional ?prio parameter which can be used to control
the order that actions run on exit.  By default actions have priority
1000.  Higher numbered actions run first.  Lower numbered actions run
last.  So to have an action run at the very end before exit you might
use ~prio:0

Note that even with this change, some actions (eg kill) are still
asynchronous.
---
 mltools/on_exit.ml  | 24 +++++++++++++-----------
 mltools/on_exit.mli | 18 +++++++++++++-----
 2 files changed, 26 insertions(+), 16 deletions(-)

diff --git a/mltools/on_exit.ml b/mltools/on_exit.ml
index 4fa2c3b..e8353df 100644
--- a/mltools/on_exit.ml
+++ b/mltools/on_exit.ml
@@ -29,7 +29,7 @@ type action    | Kill of int * int    (* signal, pid *)
   | Fn of (unit -> unit) (* generic function *)
 
-(* List of actions. *)
+(* List of (priority, action). *)
 let actions = ref []
 
 (* Perform a single exit action, printing any exception but
@@ -50,10 +50,12 @@ let do_action action  (* Make sure the actions are performed
only once. *)
 let done_actions = ref false
 
-(* Perform the exit actions. *)
+(* Perform the exit actions in reverse priority order (highest first). *)
 let do_actions ()    if not !done_actions then (
-    List.iter do_action !actions
+    let actions = List.sort (fun (a, _) (b, _) -> compare b a) !actions in
+    let actions = List.map snd actions in
+    List.iter do_action actions
   );
   done_actions := true
 
@@ -92,18 +94,18 @@ let register ()    );
   registered := true
 
-let f fn +let f ?(prio = 1000) fn    register ();
-  List.push_front (Fn fn) actions
+  List.push_front (prio, Fn fn) actions
 
-let unlink filename +let unlink ?(prio = 1000) filename    register ();
-  List.push_front (Unlink filename) actions
+  List.push_front (prio, Unlink filename) actions
 
-let rm_rf dir +let rm_rf ?(prio = 1000) dir    register ();
-  List.push_front (Rm_rf dir) actions
+  List.push_front (prio, Rm_rf dir) actions
 
-let kill ?(signal = Sys.sigterm) pid +let kill ?(prio = 1000) ?(signal =
Sys.sigterm) pid    register ();
-  List.push_front (Kill (signal, pid)) actions
+  List.push_front (prio, Kill (signal, pid)) actions
diff --git a/mltools/on_exit.mli b/mltools/on_exit.mli
index 9bcf104..910783e 100644
--- a/mltools/on_exit.mli
+++ b/mltools/on_exit.mli
@@ -28,6 +28,12 @@
     killing another process, so we provide simple
     wrappers for those common actions here.
 
+    Actions can be ordered by setting the optional [?prio]
+    parameter.  By default all actions have priority 1000.
+    Higher numbered actions run first.  Lower numbered
+    actions run last.  So to have an action run at the
+    very end before exit you might use [~prio:0]
+
     Note this module registers signal handlers for
     SIGINT, SIGQUIT, SIGTERM and SIGHUP.  This means
     that any program that links with mltools.cmxa
@@ -39,18 +45,20 @@
     Your cleanup action might no longer run unless the
     program calls {!Stdlib.exit}. *)
 
-val f : (unit -> unit) -> unit
+val f : ?prio:int -> (unit -> unit) -> unit
 (** Register a function [f] which runs when the program exits.
     Similar to [Stdlib.at_exit] but also runs if the program is
-    killed with a signal that we can catch. *)
+    killed with a signal that we can catch.
 
-val unlink : string -> unit
+    [?prio] is the priority, default 1000.  See the description above. *)
+
+val unlink : ?prio:int -> string -> unit
 (** Unlink a single temporary file on exit. *)
 
-val rm_rf : string -> unit
+val rm_rf : ?prio:int -> string -> unit
 (** Recursively remove a temporary directory on exit (using [rm -rf]). *)
 
-val kill : ?signal:int -> int -> unit
+val kill : ?prio:int -> ?signal:int -> int -> unit
 (** Kill [PID] on exit.  The signal sent defaults to [Sys.sigterm].
 
     Use this with care since you can end up unintentionally killing
-- 
2.37.0.rc2

Add a new, optional [?wait] parameter to On_exit.kill, allowing
programs to wait for a number of seconds for the subprocess to exit.
---
 mltools/on_exit.ml  | 30 +++++++++++++++++++++---------
 mltools/on_exit.mli | 14 ++++++++++++--
 2 files changed, 33 insertions(+), 11 deletions(-)

diff --git a/mltools/on_exit.ml b/mltools/on_exit.ml
index e8353df..cdaa83c 100644
--- a/mltools/on_exit.ml
+++ b/mltools/on_exit.ml
@@ -24,10 +24,10 @@ open Unix
 open Printf
 
 type action -  | Unlink of string     (* filename *)
-  | Rm_rf of string      (* directory *)
-  | Kill of int * int    (* signal, pid *)
-  | Fn of (unit -> unit) (* generic function *)
+  | Unlink of string        (* filename *)
+  | Rm_rf of string         (* directory *)
+  | Kill of int * int * int (* wait, signal, pid *)
+  | Fn of (unit -> unit)    (* generic function *)
 
 (* List of (priority, action). *)
 let actions = ref []
@@ -35,18 +35,30 @@ let actions = ref []
 (* Perform a single exit action, printing any exception but
  * otherwise ignoring failures.
  *)
-let do_action action +let rec do_action action    try
     match action with
     | Unlink file -> Unix.unlink file
     | Rm_rf dir ->
        let cmd = sprintf "rm -rf %s" (Filename.quote dir) in
        ignore (Tools_utils.shell_command cmd)
-    | Kill (signal, pid) ->
-       kill pid signal
+    | Kill (wait, signal, pid) ->
+       do_kill ~wait ~signal ~pid
     | Fn f -> f ()
   with exn -> debug "%s" (Printexc.to_string exn)
 
+and do_kill ~wait ~signal ~pid +  kill pid signal;
+
+  let rec loop i +    if i > 0 then (
+      let pid', _ = waitpid [ WNOHANG ] pid in
+      if pid' = 0 then
+        loop (i-1)
+    )
+  in
+  loop wait
+
 (* Make sure the actions are performed only once. *)
 let done_actions = ref false
 
@@ -106,6 +118,6 @@ let rm_rf ?(prio = 1000) dir    register ();
   List.push_front (prio, Rm_rf dir) actions
 
-let kill ?(prio = 1000) ?(signal = Sys.sigterm) pid +let kill ?(prio = 1000)
?(wait = 0) ?(signal = Sys.sigterm) pid    register ();
-  List.push_front (prio, Kill (signal, pid)) actions
+  List.push_front (prio, Kill (wait, signal, pid)) actions
diff --git a/mltools/on_exit.mli b/mltools/on_exit.mli
index 910783e..dd35101 100644
--- a/mltools/on_exit.mli
+++ b/mltools/on_exit.mli
@@ -58,12 +58,22 @@ val unlink : ?prio:int -> string -> unit
 val rm_rf : ?prio:int -> string -> unit
 (** Recursively remove a temporary directory on exit (using [rm -rf]). *)
 
-val kill : ?prio:int -> ?signal:int -> int -> unit
+val kill : ?prio:int -> ?wait:int -> ?signal:int -> int -> unit
 (** Kill [PID] on exit.  The signal sent defaults to [Sys.sigterm].
 
     Use this with care since you can end up unintentionally killing
     another process if [PID] goes away or doesn't exist before the
-    program exits. *)
+    program exits.
+
+    The optional [?wait] flag attempts to wait for a specified
+    number of seconds for the subprocess to go away.  For example
+    using [~wait:5] will wait for up to 5 seconds.   Since this
+    runs when virt-v2v is exiting, it is best to keep waiting times
+    as short as possible.  Also there is no way to report errors
+    in the subprocess.  If reliable cleanup of a subprocess is
+    required then this is not the correct place to do it.
+
+    [?wait] defaults to [0] which means we do not try to wait. *)
 
 val register : unit -> unit
 (** Force this module to register its at_exit function and signal
-- 
2.37.0.rc2