Implement killall waiting

daemon/albatrossd.ml

@@ -175,13 +175,11 @@ let jump _ systemd influx tmpdir dbdir retries enable_stats =
        let self_destruct_mutex = Lwt_mutex.create () in
        let self_destruct () =
          Lwt_mutex.with_lock self_destruct_mutex (fun () ->
-             (if Vmm_vmmd.killall !state then
+             (let state', tasks = Vmm_vmmd.killall !state Lwt.task in
-                (* not too happy about the sleep here, but cleaning up resources
+              state := state';
-                   is really important (fifos, vm images, tap devices) - which
+              Lwt_list.iter_s (fun exit_code ->
-                   is done asynchronously (in the task waitpid() on the pid) *)
+                  exit_code >>= fun (_ : process_exit) -> Lwt.return_unit)
-                Lwt_unix.sleep 1.
+                tasks) >>= fun () ->
-              else
-                Lwt.return_unit) >>= fun () ->
              Vmm_lwt.safe_close ss)
        in
        Sys.(set_signal sigterm

src/vmm_vmmd.ml

@@ -17,11 +17,6 @@ type 'a t = {
 
 let in_shutdown = ref false
 
-let killall t =
-  match List.map snd (Vmm_trie.all t.resources.Vmm_resources.unikernels) with
-  | [] -> false
-  | vms -> in_shutdown := true ; List.iter Vmm_unix.destroy vms ; true
-
 let remove_resources t name =
   let resources = match Vmm_resources.remove_vm t.resources name with
     | Error (`Msg e) ->
@@ -63,6 +58,17 @@ let register_restart t id create =
   | Some _ -> Logs.err (fun m -> m "restart attempted to overwrite waiter"); None
   | _ -> Some (register t id create)
 
+let killall t create =
+  let vms = Vmm_trie.all t.resources.Vmm_resources.unikernels in
+  in_shutdown := true ;
+  let t, xs = List.fold_left
+      (fun (t, acc) (id, _) ->
+         let (t, a) = register t id create in
+         (t, a :: acc))
+      (t, []) vms in
+  List.iter Vmm_unix.destroy (List.map snd vms) ;
+  t, xs
+
 let init () =
   let t = {
     console_counter = 1L ;

src/vmm_vmmd.mli

@@ -32,7 +32,7 @@ val handle_command : 'a t -> Vmm_commands.wire ->
    | `Wait_and_create of Name.t * (Name.t * Unikernel.config) ],
    Vmm_commands.res) result
 
-val killall : 'a t -> bool
+val killall : 'a t -> (unit -> 'b * 'a) -> 'a t * ('b list)
 
 val restore_unikernels : unit -> (Unikernel.config Vmm_trie.t, [> `Msg of string ]) result