restart on failure

client/albatross_client_bistro.ml

@@ -110,8 +110,8 @@ let info_ _ endp cert key ca name =
 let destroy _ endp cert key ca name =
   jump endp cert key ca name (`Unikernel_cmd `Unikernel_destroy)
 
-let create _ endp cert key ca force name image cpuid memory argv block network compression =
+let create _ endp cert key ca force name image cpuid memory argv block network compression restart_on_fail =
-  match Albatross_cli.create_vm force image cpuid memory argv block network compression with
+  match Albatross_cli.create_vm force image cpuid memory argv block network compression restart_on_fail with
   | Ok cmd -> jump endp cert key ca name (`Unikernel_cmd cmd)
   | Error (`Msg msg) -> Error (`Msg msg)
 
@@ -208,7 +208,7 @@ let create_cmd =
     [`S "DESCRIPTION";
      `P "Creates a virtual machine."]
   in
-  Term.(term_result (const create $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ force $ vm_name $ image $ cpu $ vm_mem $ args $ block $ net $ compress_level 9)),
+  Term.(term_result (const create $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ force $ vm_name $ image $ cpu $ vm_mem $ args $ block $ net $ compress_level 9 $ restart_on_fail)),
   Term.info "create" ~doc ~man
 
 let console_cmd =

client/albatross_client_local.ml

@@ -61,8 +61,8 @@ let info_ _ opt_socket name =
 let destroy _ opt_socket name =
   jump opt_socket name (`Unikernel_cmd `Unikernel_destroy)
 
-let create _ opt_socket force name image cpuid memory argv block network compression =
+let create _ opt_socket force name image cpuid memory argv block network compression restart_on_fail =
-  match Albatross_cli.create_vm force image cpuid memory argv block network compression with
+  match Albatross_cli.create_vm force image cpuid memory argv block network compression restart_on_fail with
   | Ok cmd -> jump opt_socket name (`Unikernel_cmd cmd)
   | Error (`Msg msg) -> Error (`Msg msg)
 
@@ -153,7 +153,7 @@ let create_cmd =
     [`S "DESCRIPTION";
      `P "Creates a virtual machine."]
   in
-  Term.(term_result (const create $ setup_log $ socket $ force $ vm_name $ image $ cpu $ vm_mem $ args $ block $ net $ compress_level 0)),
+  Term.(term_result (const create $ setup_log $ socket $ force $ vm_name $ image $ cpu $ vm_mem $ args $ block $ net $ compress_level 0 $ restart_on_fail)),
   Term.info "create" ~doc ~man
 
 let console_cmd =

command-line/albatross_cli.ml

@@ -79,7 +79,7 @@ let setup_log style_renderer level =
   Logs.set_level level;
   Logs.set_reporter (Logs_fmt.reporter ~dst:Format.std_formatter ())
 
-let create_vm force image cpuid memory argv block_devices bridges compression =
+let create_vm force image cpuid memory argv block_devices bridges compression restart_on_fail =
   let open Rresult.R.Infix in
   Bos.OS.File.read (Fpath.v image) >>| fun image ->
   let image = match compression with
@@ -88,8 +88,9 @@ let create_vm force image cpuid memory argv block_devices bridges compression =
       let img = Vmm_compress.compress ~level image in
       `Hvt_amd64_compressed, Cstruct.of_string img
   and argv = match argv with [] -> None | xs -> Some xs
+  and fail_behaviour = if restart_on_fail then `Restart else `Quit
   in
-  let config = Unikernel.{ cpuid ; memory ; block_devices ; bridges ; argv ; image } in
+  let config = Unikernel.{ cpuid ; memory ; block_devices ; bridges ; argv ; image ; fail_behaviour } in
   if force then `Unikernel_force_create config else `Unikernel_create config
 
 let policy vms memory cpus block bridges =
@@ -236,6 +237,10 @@ let net =
   let doc = "Network device names" in
   Arg.(value & opt_all string [] & info [ "net" ] ~doc)
 
+let restart_on_fail =
+  let doc = "Restart on fail" in
+  Arg.(value & flag & info [ "restart-on-fail" ] ~doc)
+
 let timestamp_c =
   let parse s = match Ptime.of_rfc3339 s with
     | Ok (t, _, _) -> `Ok t

daemon/albatrossd.ml

@@ -10,38 +10,86 @@ let version = `AV3
 
 let state = ref (Vmm_vmmd.init version)
 
-let create stat_out log_out cons_out data_out cons succ_cont fail_cont =
+let stub_hdr = Vmm_commands.{ version ; sequence = 0L ; name = Name.root }
+let stub_data_out _ = Lwt.return_unit
+
+(*
+ - handle_create only prepares the unikernel (fifo, image file)
+  -> IO console about fifo
+ - only the succ_cont later commits this (to resources)
+  --> there's a brief period
+ *)
+
+let create_lock = Lwt_mutex.create ()
+
+let rec create stat_out log_out cons_out data_out hdr name config =
+  (match Vmm_vmmd.handle_create !state hdr name config with
+   | Error `Msg msg ->
+     Logs.err (fun m -> m "failed to create %a: %s" Name.pp name msg) ;
+     Lwt.return (None, (hdr, `Failure msg))
+   | Ok (state', `Create (cons, succ_cont, fail_cont)) ->
+     state := state';
      cons_out "create" cons >>= function
-  | Error () ->
+     | Error () -> Lwt.return (None, fail_cont ())
-    let data = fail_cont () in
-    data_out data
      | Ok () -> match succ_cont !state with
        | Error (`Msg msg) ->
          Logs.err (fun m -> m "create (exec) failed %s" msg) ;
-      let data = fail_cont () in
+         Lwt.return (None, fail_cont ())
-      data_out data
        | Ok (state', stat, log, data, name, vm) ->
          state := state';
+         (match Unikernel.(vm.config.fail_behaviour) with
+          | `Quit -> ()
+          | `Restart ->
+            match Vmm_vmmd.register_restart !state name Lwt.task with
+            | None -> ()
+            | Some (state', task) ->
+              state := state';
+              Lwt.async (fun () ->
+                  task >>= function
+                  | (`Signal _ | `Stop _) as r ->
+                    Logs.warn (fun m -> m "unikernel %a exited with signal %a"
+                                  Name.pp name pp_process_exit r);
+                    Lwt.return_unit
+                  | `Exit i ->
+                    (* results:
+                       normal exit (i.e. teardown) is 0
+                       solo5-exit allows an arbitrary int
+                       solo5-abort emits 255
+                       solo5 internal error (bad image, bad manigest) is 1
+                       ocaml exceptions (out of memory et al) use 2
+                       -> soon (4.10) they'll abort == 255
+                       signal 11 is if a kill -TERM was sent (i.e. our destroy)
+
+                       --> best: user-provided list of which exit codes to restart on
+                           (and filter 1 specially)
+                    *)
+                    match i with
+                    | 1 -> Logs.warn (fun m -> m "solo5 exit failure"); Lwt.return_unit
+                    | _ ->
+                      Logs.info (fun m -> m "solo5 exited with %d, restarting" i);
+                      Lwt_mutex.with_lock create_lock (fun () ->
+                          create stat_out log_out cons_out stub_data_out
+                            stub_hdr name vm.Unikernel.config)));
+         stat_out "setting up stat" stat >>= fun () ->
+         log_out "setting up log" log >|= fun () ->
+         (Some vm, data)) >>= fun (started, data) ->
+  (match started with
+   | None -> ()
+   | Some vm ->
      Lwt.async (fun () ->
          Vmm_lwt.wait_and_clear vm.Unikernel.pid >>= fun r ->
+         Lwt_mutex.with_lock create_lock (fun () ->
              let state', stat', log' = Vmm_vmmd.handle_shutdown !state name vm r in
              state := state';
              stat_out "handle shutdown stat" stat' >>= fun () ->
              log_out "handle shutdown log" log' >|= fun () ->
              let state', waiter_opt = Vmm_vmmd.waiter !state name in
              state := state';
-          (match waiter_opt with
+             waiter_opt) >|= function
          | None -> ()
-           | Some wakeme -> Lwt.wakeup wakeme ())) ;
+         | Some wakeme -> Lwt.wakeup wakeme r));
-      stat_out "setting up stat" stat >>= fun () ->
-      log_out "setting up log" log >>= fun () ->
   data_out data
 
-let register who header =
-  match Vmm_vmmd.register !state who Lwt.task with
-  | None -> Error (header, `Failure "task already registered")
-  | Some (state', task) -> state := state' ; Ok task
-
 let handle log_out cons_out stat_out fd addr =
   Logs.debug (fun m -> m "connection from %a" Vmm_lwt.pp_sockaddr addr) ;
   (* now we need to read a packet and handle it
@@ -69,49 +117,40 @@ let handle log_out cons_out stat_out fd addr =
       Lwt.return_unit
     | Ok wire ->
       Logs.debug (fun m -> m "read %a" Vmm_commands.pp_wire wire) ;
+      Lwt_mutex.lock create_lock >>= fun () ->
       match Vmm_vmmd.handle_command !state wire with
-      | Error wire -> out wire
+      | Error wire -> Lwt_mutex.unlock create_lock; out wire
       | Ok (state', next) ->
         state := state' ;
         match next with
-        | `Loop wire -> out wire >>= loop
+        | `Loop wire -> Lwt_mutex.unlock create_lock; out wire >>= loop
-        | `End wire -> out wire
+        | `End wire -> Lwt_mutex.unlock create_lock; out wire
-        | `Create (cons, succ, fail) ->
+        | `Create (hdr, id, vm) ->
-          create stat_out log_out cons_out out cons succ fail
+          create stat_out log_out cons_out out hdr id vm >|= fun () ->
+          Lwt_mutex.unlock create_lock
         | `Wait (who, data) ->
-          (match register who (fst wire) with
+          let state', task = Vmm_vmmd.register !state who Lwt.task in
-           | Error data' -> out data'
-           | Ok task ->
-             task >>= fun () ->
-             out data)
-        | `Wait_and_create (who, next) ->
-          (match register who (fst wire) with
-           | Error data -> out data
-           | Ok task ->
-             task >>= fun () ->
-             match next !state with
-             | Error data -> out data
-             | Ok (state', `Create (cons, succ, fail)) ->
           state := state';
-               create stat_out log_out cons_out out cons succ fail)
+          Lwt_mutex.unlock create_lock;
+          task >>= fun r ->
+          out (data r)
+        | `Wait_and_create (who, (hdr, id, vm)) ->
+          let state', task = Vmm_vmmd.register !state who Lwt.task in
+          state := state';
+          Lwt_mutex.unlock create_lock;
+          task >>= fun r ->
+          Logs.info (fun m -> m "wait returned %a" pp_process_exit r);
+          Lwt_mutex.with_lock create_lock (fun () ->
+              create stat_out log_out cons_out out hdr id vm)
   in
   loop () >>= fun () ->
   Vmm_lwt.safe_close fd
 
-let connect_client_socket sock =
+let write_reply name fd txt (header, cmd) =
-  let name = socket_path sock in
-  Vmm_lwt.connect Lwt_unix.PF_UNIX (Lwt_unix.ADDR_UNIX name) >|= function
-  | None -> None
-  | Some x -> Some (x, Lwt_mutex.create ())
-
-let write_reply name (fd, mut) txt (header, cmd) =
-  Logs.debug (fun m -> m "locking to write to %s" name) ;
-  Lwt_mutex.with_lock mut (fun () ->
   Vmm_lwt.write_wire fd (header, cmd) >>= function
   | Error `Exception -> invalid_arg ("exception during " ^ txt ^ " while writing to " ^ name)
-      | Ok () -> Vmm_lwt.read_wire fd) >|= fun r ->
+  | Ok () ->
-  Logs.debug (fun m -> m "unlocking, wrote and read %s" name) ;
+    Vmm_lwt.read_wire fd >|= function
-  match r with
     | Ok (header', reply) ->
       if not Vmm_commands.(version_eq header.version header'.version) then begin
         Logs.err (fun m -> m "%s: wrong version (got %a, expected %a) in reply from %s"
@@ -125,8 +164,8 @@ let write_reply name (fd, mut) txt (header, cmd) =
                      txt header'.Vmm_commands.sequence header.Vmm_commands.sequence name) ;
         invalid_arg "wrong sequence number received"
       end else begin
-      Logs.debug (fun m -> m "%s: received valid reply from %s %a"
+        Logs.debug (fun m -> m "%s: received valid reply from %s %a (request %a)"
-                     txt name Vmm_commands.pp_wire (header', reply)) ;
+                       txt name Vmm_commands.pp_wire (header', reply) Vmm_commands.pp_wire (header,cmd)) ;
         match reply with
         | `Success _ -> Ok ()
         | `Failure msg ->
@@ -148,9 +187,12 @@ let jump _ influx =
   | Error (`Msg msg) -> Logs.err (fun m -> m "bailing out: %s" msg)
   | Ok old_unikernels ->
     Lwt_main.run
-      (init_influx "albatross" influx;
+      (let unix_connect s =
+         Vmm_lwt.connect Lwt_unix.PF_UNIX (Lwt_unix.ADDR_UNIX (socket_path s))
+       in
+       init_influx "albatross" influx;
        Vmm_lwt.server_socket `Vmmd >>= fun ss ->
-       (connect_client_socket `Log >|= function
+       (unix_connect `Log >|= function
          | None -> invalid_arg "cannot connect to log socket"
          | Some l -> l) >>= fun l ->
        let self_destruct_mutex = Lwt_mutex.create () in
@@ -166,10 +208,10 @@ let jump _ influx =
              Vmm_lwt.safe_close ss)
        in
        Sys.(set_signal sigterm (Signal_handle (fun _ -> Lwt.async self_destruct)));
-       (connect_client_socket `Console >|= function
+       (unix_connect `Console >|= function
          | None -> invalid_arg "cannot connect to console socket"
          | Some c -> c) >>= fun c ->
-       connect_client_socket `Stats >>= fun s ->
+       unix_connect `Stats >>= fun s ->
 
        let log_out txt wire = write_reply "log" l txt wire >|= fun _ -> ()
        and cons_out = write_reply "cons" c
@@ -178,19 +220,9 @@ let jump _ influx =
          | Some s -> write_reply "stat" s txt wire >|= fun _ -> ()
        in
 
-       let start_unikernel (name, config) =
+       Lwt_list.iter_p (fun (name, config) ->
-         let hdr = Vmm_commands.{ version ; sequence = 0L ; name = Name.root }
+           create stat_out log_out cons_out stub_data_out stub_hdr name config)
-         and data_out _ = Lwt.return_unit
+         (Vmm_trie.all old_unikernels) >>= fun () ->
-         in
-         match Vmm_vmmd.handle_create !state hdr name config with
-         | Error (`Msg msg) ->
-           Logs.err (fun m -> m "failed to restart %a: %s" Name.pp name msg) ;
-           Lwt.return_unit
-         | Ok (state', `Create (cons, succ, fail)) ->
-           state := state' ;
-           create stat_out log_out cons_out data_out cons succ fail
-       in
-       Lwt_list.iter_p start_unikernel (Vmm_trie.all old_unikernels) >>= fun () ->
 
        Lwt.catch (fun () ->
            let rec loop () =

packaging/MANIFEST

@@ -73,13 +73,16 @@ messages [
 
 	add path 'vmm/solo5*' mode 0660 group albatross
 
-   * start TLS endpoint via inetd on port 1025, add to /etc/inetd.conf:
+   * start TLS endpoint on port 1025 (blackjack), put cacert.pem, server.pem
-blackjack  stream  tcp     nowait  albatross       /usr/local/libexec/albatross/alabtross_tls_inetd   albatross_tls_inetd /usr/local/etc/albatross/cacert.pem /usr/local/etc/albatross/server.pem /usr/local/etc/albatross/server.key
+     and server.key into /usr/local/etc/albatross, add this to /etc/inetd.conf:
 
-     and add cacert.pem server.pem and server.key to /usr/local/etc/albatross
+        blackjack  stream  tcp     nowait  albatross \
+          /usr/local/libexec/albatross/alabtross_tls_inetd albatross_tls_inetd \
+          /usr/local/etc/albatross/cacert.pem \
+          /usr/local/etc/albatross/server.pem \
+          /usr/local/etc/albatross/server.key
 
-   * install solo5-hvt.net solo5-hvt.block solo5-hvt.block-net solo5-hvt.none
+   * install solo5-hvt in /var/db/albatross
-     in /var/db/albatross
 
 ===================================================================
 EOD;

provision/albatross_provision_request.ml

@@ -40,8 +40,8 @@ let info_ _ name = jump name (`Unikernel_cmd `Unikernel_info)
 let destroy _ name =
   jump name (`Unikernel_cmd `Unikernel_destroy)
 
-let create _ force name image cpuid memory argv block network compression =
+let create _ force name image cpuid memory argv block network compression restart_on_fail =
-  match Albatross_cli.create_vm force image cpuid memory argv block network compression with
+  match Albatross_cli.create_vm force image cpuid memory argv block network compression restart_on_fail with
   | Ok cmd -> jump name (`Unikernel_cmd cmd)
   | Error (`Msg msg) -> Error (`Msg msg)
 
@@ -122,7 +122,7 @@ let create_cmd =
     [`S "DESCRIPTION";
      `P "Creates a virtual machine."]
   in
-  Term.(term_result (const create $ setup_log $ force $ vm_name $ image $ cpu $ vm_mem $ args $ block $ net $ compress_level 9)),
+  Term.(term_result (const create $ setup_log $ force $ vm_name $ image $ cpu $ vm_mem $ args $ block $ net $ compress_level 9 $ restart_on_fail)),
   Term.info "create" ~doc ~man
 
 let console_cmd =

src/vmm_asn.ml

@@ -282,27 +282,40 @@ let log_cmd =
   Asn.S.map f g @@
   Asn.S.(sequence (single (optional ~label:"since" utc_time)))
 
+let fail_behaviour =
+  let f = function
+    | `C1 () -> `Quit
+    | `C2 () -> `Restart
+  and g = function
+    | `Quit -> `C1 ()
+    | `Restart -> `C2 ()
+  in
+  Asn.S.map f g @@
+  Asn.S.(choice2
+           (explicit 0 null)
+           (explicit 1 null))
+
 let unikernel_config =
   let open Unikernel in
-  let f (image, cpuid, memory, blocks, bridges, argv) =
+  let f (fail_behaviour, (image, (cpuid, (memory, (blocks, (bridges, argv)))))) =
     let bridges = match bridges with None -> [] | Some xs -> xs
     and block_devices = match blocks with None -> [] | Some xs -> xs
     in
-    { cpuid ; memory ; block_devices ; bridges ; image ; argv }
+    { cpuid ; memory ; block_devices ; bridges ; image ; argv ; fail_behaviour }
   and g vm =
     let bridges = match vm.bridges with [] -> None | xs -> Some xs
     and blocks = match vm.block_devices with [] -> None | xs -> Some xs
     in
-    (vm.image, vm.cpuid, vm.memory, blocks, bridges, vm.argv)
+    (vm.fail_behaviour, (vm.image, (vm.cpuid, (vm.memory, (blocks, (bridges, vm.argv))))))
   in
-  Asn.S.map f g @@
+  Asn.S.(map f g @@ sequence @@
-  Asn.S.(sequence6
+           (required ~label:"fail behaviour" (explicit 3 fail_behaviour))
-           (required ~label:"image" image)
+         @ (required ~label:"image" image)
-           (required ~label:"cpu" int)
+         @ (required ~label:"cpu" int)
-           (required ~label:"memory" int)
+         @ (required ~label:"memory" int)
-           (optional ~label:"blocks" (explicit 0 (sequence_of utf8_string)))
+         @ (optional ~label:"blocks" (explicit 0 (sequence_of utf8_string)))
-           (optional ~label:"bridges" (explicit 1 (sequence_of utf8_string)))
+         @ (optional ~label:"bridges" (explicit 1 (sequence_of utf8_string)))
-           (optional ~label:"arguments"(explicit 2 (sequence_of utf8_string))))
+        -@ (optional ~label:"arguments"(explicit 2 (sequence_of utf8_string))))
 
 let unikernel_cmd =
   let f = function

src/vmm_core.ml

@@ -158,6 +158,11 @@ module Unikernel = struct
     | `Hvt_amd64_compressed -> Fmt.pf ppf "hvt-amd64-compressed"
     | `Hvt_arm64 -> Fmt.pf ppf "hvt-arm64"
 
+  type fail_behaviour = [ `Quit | `Restart ]
+
+  let pp_fail_behaviour ppf f =
+    Fmt.string ppf (match f with `Quit -> "quit" | `Restart -> "restart")
+
   type config = {
     cpuid : int ;
     memory : int ;
@@ -165,6 +170,7 @@ module Unikernel = struct
     bridges : string list ;
     image : typ * Cstruct.t ;
     argv : string list option ;
+    fail_behaviour : fail_behaviour;
   }
 
   let pp_image ppf (typ, blob) =
@@ -172,7 +178,8 @@ module Unikernel = struct
     Fmt.pf ppf "%a: %d bytes" pp_typ typ l
 
   let pp_config ppf (vm : config) =
-    Fmt.pf ppf "cpu %d, %d MB memory, block devices %a@ bridge %a, image %a, argv %a"
+    Fmt.pf ppf "fail behaviour %a, cpu %d, %d MB memory, block devices %a@ bridge %a, image %a, argv %a"
+      pp_fail_behaviour vm.fail_behaviour
       vm.cpuid vm.memory
       Fmt.(list ~sep:(unit ", ") string) vm.block_devices
       Fmt.(list ~sep:(unit ", ") string) vm.bridges
@@ -280,9 +287,9 @@ end
 type process_exit = [ `Exit of int | `Signal of int | `Stop of int ]
 
 let pp_process_exit ppf = function
-  | `Exit n -> Fmt.pf ppf "exit %a (%d)" Fmt.Dump.signal n n
+  | `Exit n -> Fmt.pf ppf "exit %d" n
-  | `Signal n -> Fmt.pf ppf "signal %a (%d)" Fmt.Dump.signal n n
+  | `Signal n -> Fmt.pf ppf "signal %a (numeric %d)" Fmt.Dump.signal n n
-  | `Stop n -> Fmt.pf ppf "stop %a (%d)" Fmt.Dump.signal n n
+  | `Stop n -> Fmt.pf ppf "stop %a (numeric %d)" Fmt.Dump.signal n n
 
 module Log = struct
   type log_event = [

src/vmm_core.mli

@@ -58,6 +58,8 @@ module Unikernel : sig
   type typ = [ `Hvt_amd64 | `Hvt_amd64_compressed | `Hvt_arm64 ]
   val pp_typ : typ Fmt.t
 
+  type fail_behaviour = [ `Quit | `Restart ]
+
   type config = {
     cpuid : int;
     memory : int;
@@ -65,6 +67,7 @@ module Unikernel : sig
     bridges : string list;
     image : typ * Cstruct.t;
     argv : string list option;
+    fail_behaviour : fail_behaviour;
   }
 
   val pp_image : (typ * Cstruct.t) Fmt.t

src/vmm_lwt.ml

@@ -88,7 +88,8 @@ let read_wire s =
       (fun e ->
          let err = Printexc.to_string e in
          Logs.err (fun m -> m "exception %s while reading" err) ;
-         Lwt.return (Error `Exception))
+         safe_close s >|= fun () ->
+         Error `Exception)
   in
   r buf 0 4 >>= function
   | Error e -> Lwt.return (Error e)
@@ -121,7 +122,8 @@ let write_raw s buf =
           w (off + n) (l - n))
       (fun e ->
          Logs.err (fun m -> m "exception %s while writing" (Printexc.to_string e)) ;
-         Lwt.return (Error `Exception))
+         safe_close s >|= fun () ->
+         Error `Exception)
   in
   (*  Logs.debug (fun m -> m "writing %a" Cstruct.hexdump_pp (Cstruct.of_bytes buf)) ; *)
   w 0 (Bytes.length buf)

src/vmm_vmmd.ml

@@ -23,8 +23,30 @@ let killall t =
   | [] -> 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) ->
+      Logs.warn (fun m -> m "%s while removing vm %a from resources" e Name.pp name) ;
+      t.resources
+    | Ok resources -> resources
+  in
+  { t with resources }
+
+let dump_unikernels t =
+  let unikernels = Vmm_trie.all t.resources.Vmm_resources.unikernels in
+  let trie = List.fold_left (fun t (name, unik) ->
+      fst @@ Vmm_trie.insert name unik.Unikernel.config t)
+      Vmm_trie.empty unikernels
+  in
+  let data = Vmm_asn.unikernels_to_cstruct trie in
+  match Vmm_unix.dump data with
+  | Error (`Msg msg) -> Logs.err (fun m -> m "failed to dump unikernels: %s" msg)
+  | Ok () -> Logs.info (fun m -> m "dumped current state")
+
 let waiter t id =
+  let t = remove_resources t id in
   let name = Name.to_string id in
+  if not !in_shutdown then dump_unikernels t ;
   match String.Map.find name t.waiters with
   | None -> t, None
   | Some waiter ->
@@ -33,11 +55,14 @@ let waiter t id =
 
 let register t id create =
   let name = Name.to_string id in
-  match String.Map.find name t.waiters with
-  | None ->
   let task, waiter = create () in
-    Some ({ t with waiters = String.Map.add name waiter t.waiters }, task)
+  { t with waiters = String.Map.add name waiter t.waiters }, task
-  | Some _ -> None
+
+let register_restart t id create =
+  let name = Name.to_string id in
+  match String.Map.find name t.waiters with
+  | Some _ -> Logs.err (fun m -> m "restart attempted to overwrite waiter"); None
+  | _ -> Some (register t id create)
 
 let init wire_version =
   let t = {
@@ -89,17 +114,6 @@ let restore_unikernels () =
       Logs.info (fun m -> m "restored %d unikernels" (List.length (Vmm_trie.all unikernels))) ;
       Ok unikernels
 
-let dump_unikernels t =
-  let unikernels = Vmm_trie.all t.resources.Vmm_resources.unikernels in
-  let trie = List.fold_left (fun t (name, unik) ->
-      fst @@ Vmm_trie.insert name unik.Unikernel.config t)
-      Vmm_trie.empty unikernels
-  in
-  let data = Vmm_asn.unikernels_to_cstruct trie in
-  match Vmm_unix.dump data with
-  | Error (`Msg msg) -> Logs.err (fun m -> m "failed to dump unikernels: %s" msg)
-  | Ok () -> Logs.info (fun m -> m "dumped current state")
-
 let setup_stats t name vm =
   let stat_out =
     let name = match Vmm_unix.vm_device vm with
@@ -171,14 +185,6 @@ let handle_shutdown t name vm r =
   (match Vmm_unix.free_system_resources name vm.Unikernel.taps with
    | Ok () -> ()
    | Error (`Msg e) -> Logs.warn (fun m -> m "%s while shutdown vm %a" e Unikernel.pp vm)) ;
-  let resources = match Vmm_resources.remove_vm t.resources name with
-    | Error (`Msg e) ->
-      Logs.warn (fun m -> m "%s while removing vm %a from resources" e Unikernel.pp vm) ;
-      t.resources
-    | Ok resources -> resources
-  in
-  let t = { t with resources } in
-  if not !in_shutdown then dump_unikernels t ;
   let t, log_out = log t name (`Unikernel_stop (name, vm.Unikernel.pid, r)) in
   let t, stat_out = remove_stats t name in
   (t, stat_out, log_out)
@@ -213,7 +219,7 @@ let handle_policy_cmd t reply id = function
     | _ ->
       Ok (t, `End (reply (`Policies policies)))
 
-let handle_unikernel_cmd t reply header id msg_to_err = function
+let handle_unikernel_cmd t reply header id = function
   | `Unikernel_info ->
     Logs.debug (fun m -> m "info %a" Name.pp id) ;
     let vms =
@@ -228,29 +234,37 @@ let handle_unikernel_cmd t reply header id msg_to_err = function
       | _ ->
         Ok (t, `End (reply (`Unikernels vms)))
     end
-  | `Unikernel_create vm_config -> handle_create t header id vm_config
+  | `Unikernel_create vm_config -> Ok (t, `Create (header, id, vm_config))
   | `Unikernel_force_create vm_config ->
     begin
       let resources =
         match Vmm_resources.remove_vm t.resources id with
-        | Error _ -> t.resources
+        | Error _ -> t.resources | Ok r -> r
-        | Ok r -> r
       in
       Vmm_resources.check_vm resources id vm_config >>= fun () ->
       match Vmm_resources.find_vm t.resources id with
-      | None -> handle_create t header id vm_config
+      | None -> Ok (t, `Create (header, id, vm_config))
       | Some vm ->
-        Vmm_unix.destroy vm ;
+        (match Vmm_unix.destroy vm with
-        Ok (t, `Wait_and_create
+         | exception Unix.Unix_error _ -> ()
-              (id, fun t -> msg_to_err @@ handle_create t header id vm_config))
+         | () -> ());
+        Ok (t, `Wait_and_create (id, (header, id, vm_config)))
     end
   | `Unikernel_destroy ->
     match Vmm_resources.find_vm t.resources id with
-    | Some vm ->
-      Vmm_unix.destroy vm ;
-      let s = reply (`String "destroyed unikernel") in
-      Ok (t, `Wait (id, s))
     | None -> Error (`Msg "destroy: not found")
+    | Some vm ->
+      let answer =
+        try
+          Vmm_unix.destroy vm ; "destroyed unikernel"
+        with
+          Unix.Unix_error _ -> "kill failed"
+      in
+      let s ex =
+        let data = Fmt.strf "%a %s %a" Name.pp id answer pp_process_exit ex in
+        reply (`String data)
+      in
+      Ok (t, `Wait (id, s))
 
 let handle_block_cmd t reply id = function
   | `Block_remove ->
@@ -300,7 +314,7 @@ let handle_command t (header, payload) =
   msg_to_err (
     match payload with
     | `Command (`Policy_cmd pc) -> handle_policy_cmd t reply id pc
-    | `Command (`Unikernel_cmd vc) -> handle_unikernel_cmd t reply header id msg_to_err vc
+    | `Command (`Unikernel_cmd vc) -> handle_unikernel_cmd t reply header id vc
     | `Command (`Block_cmd bc) -> handle_block_cmd t reply id bc
     | _ ->
       Logs.err (fun m -> m "ignoring %a" Vmm_commands.pp_wire (header, payload)) ;

src/vmm_vmmd.mli

@@ -8,7 +8,9 @@ val init : Vmm_commands.version -> 'a t
 
 val waiter : 'a t -> Name.t -> 'a t * 'a option
 
-val register : 'a t -> Name.t -> (unit -> 'b * 'a) -> ('a t * 'b) option
+val register : 'a t -> Name.t -> (unit -> 'b * 'a) -> ('a t * 'b)
+
+val register_restart : 'a t -> Name.t -> (unit -> 'b * 'a) -> ('a t * 'b) option
 
 type 'a create =
   Vmm_commands.wire *
@@ -24,11 +26,11 @@ val handle_create : 'a t -> Vmm_commands.header ->
 
 val handle_command : 'a t -> Vmm_commands.wire ->
   ('a t *
-   [ `Create of 'a create
+   [ `Create of Vmm_commands.header * Name.t * Unikernel.config
    | `Loop of Vmm_commands.wire
    | `End of Vmm_commands.wire
-   | `Wait of Name.t * Vmm_commands.wire
+   | `Wait of Name.t * (process_exit -> Vmm_commands.wire)
-   | `Wait_and_create of Name.t * ('a t -> ('a t * [ `Create of 'a create ], Vmm_commands.wire) result) ],
+   | `Wait_and_create of Name.t * (Vmm_commands.header * Name.t * Unikernel.config) ],
    Vmm_commands.wire) result
 
 val killall : 'a t -> bool