CA-432805: Avoid fuse exit hanging in flush_all

ocaml/database/db_connections.ml

@@ -87,6 +87,8 @@ let pre_exit_hook () =
    ensure that they flush a consistent snapshot. Backends must also ensure that
    they do not hold the global db_lock whilst they are writing to non-local
    storage.
+   Exits use Unix._exit: the database is already flushed, and the flush_all in
+   Stdlib.exit can block forever on a stale channel while Db_lock is held.
 *)
 let flush_dirty_and_maybe_exit dbconn exit_spec =
   Db_conn_store.with_db_conn_lock dbconn (fun () ->
@@ -101,7 +103,7 @@ let flush_dirty_and_maybe_exit dbconn exit_spec =
           if refcount = 0 then (
             debug "refcount is 0; exiting" ;
             pre_exit_hook () ;
-            exit 0
+            Unix._exit 0
           ) else
             debug "refcount is %d; not exiting" refcount
       ) ;
@@ -111,7 +113,7 @@ let flush_dirty_and_maybe_exit dbconn exit_spec =
       | None ->
           ()
       | Some ret_code ->
-          pre_exit_hook () ; exit ret_code
+          pre_exit_hook () ; Unix._exit ret_code
       ) ;
       was_anything_flushed
   )

ocaml/xapi-consts/constants.ml

@@ -327,6 +327,9 @@ let cli_report_ignored_parameters = ref Off
 (* the time taken to wait before restarting in a different mode for pool eject/join operations *)
 let fuse_time = ref 10.
 
+(* the time the fuse allows for flush and exit before forcing the process out *)
+let fuse_exit_grace = ref 60.
+
 (* Names of storage parameters *)
 let _sm_vm_hint = "vmhint"
 

ocaml/xapi/xapi_fuse.ml

@@ -42,8 +42,21 @@ let once kind f =
       )
   )
 
+(* The exit may hang, and nothing else would kill the process if it did, so
+   add a timer that forces the process to exit. *)
+let force_exit_after_grace ~fuse_length ret_code =
+  let wait = fuse_length +. !Constants.fuse_exit_grace in
+  try
+    ignore (Thread.create (fun () -> Thread.delay wait ; Unix._exit ret_code) ()) ;
+    debug "%s: forcing exit %d if still running in %.0fs" __FUNCTION__ ret_code
+      wait
+  with e ->
+    warn "%s: could not start the exit timer: %s" __FUNCTION__
+      (Printexc.to_string e)
+
 let light_fuse_and_run ?(fuse_length = !Constants.fuse_time) () =
   once `Exit @@ fun () ->
+  force_exit_after_grace ~fuse_length Xapi_globs.restart_return_code ;
   debug
     "light_fuse_and_run: calling Rrdd.backup_rrds to save current RRDs locally" ;
   let delay_so_far =
@@ -82,7 +95,7 @@ let light_fuse_and_run ?(fuse_length = !Constants.fuse_time) () =
              "Caught an exception flushing database (perhaps it hasn't been \
               initialised yet): %s; restarting immediately"
              (ExnHelper.string_of_exn e) ;
-           exit Xapi_globs.restart_return_code
+           Unix._exit Xapi_globs.restart_return_code
        )
        ()
     )
@@ -116,6 +129,7 @@ let light_fuse_and_reboot ?(fuse_length = !Constants.fuse_time) () =
 
 let light_fuse_and_dont_restart ?(fuse_length = !Constants.fuse_time) () =
   once `Exit @@ fun () ->
+  force_exit_after_grace ~fuse_length 0 ;
   ignore
     (Thread.create
        (fun () ->

ocaml/xapi/xapi_globs.ml

@@ -1239,6 +1239,7 @@ let xapi_globs_spec =
     , LongDurationFromSeconds host_assumed_dead_interval
     )
   ; ("fuse_time", Float Constants.fuse_time)
+  ; ("fuse_exit_grace", Float Constants.fuse_exit_grace)
   ; ("db_restore_fuse_time", Float Constants.db_restore_fuse_time)
   ; ("inactive_session_timeout", Float inactive_session_timeout)
   ; ("pending_task_timeout", Float pending_task_timeout)

scripts/xapi.conf

@@ -316,6 +316,10 @@ sm-plugins=ext nfs iscsi lvmoiscsi dummy file hba rawhba udev iso lvm lvmohba lv
 # allows the current API call to succeed.
 # fuse_time = 10
 
+# time after the fuse delay before xapi is forced to exit if flushing the
+# database and exiting has not finished.
+# fuse_exit_grace = 60
+
 # time after receiving a pool database restore before automatically restarting
 # xapi to read it.
 # db_restore_fuse_time = 30