vmmd: actually, first check resources, then exec VM, then insert VM

in case the insertion fails, raise Invalid_argument

this leads to more sane failure behaviour, and also cleans up resources in case
 vmm_resources.insert_vm fails (or cpuset/open of the fifo, create_process)

app/vmmd.ml

@@ -31,8 +31,9 @@ let create stat_out log_out cons_out data_out cons succ_cont fail_cont =
     data_out data
   | Ok () -> match succ_cont !state with
     | Error (`Msg msg) ->
-      Logs.err (fun m -> m "create continuation failed %s" msg) ;
+      Logs.err (fun m -> m "create (exec) failed %s" msg) ;
-      Lwt.return_unit
+      let data = fail_cont () in
+      data_out data
     | Ok (state', stat, log, data, name, vm) ->
       state := state' ;
       s := { !s with vm_created = succ !s.vm_created } ;

src/vmm_resources.ml

@@ -51,16 +51,15 @@ let find_block t name = Vmm_trie.find name t.block_devices
 
 let set_block_usage t name active =
   match Vmm_trie.find name t with
-  | None -> Error (`Msg "unknown block device")
+  | None -> invalid_arg ("block device " ^ Name.to_string name ^ " not in trie")
   | Some (size, curr) ->
-    if curr = active then
+    if curr = active
-      Error (`Msg "failed because the requested block usage was already set")
+    then invalid_arg ("block device " ^ Name.to_string name ^ " already in state " ^ (if curr then "active" else "inactive"))
-    else
+    else fst (Vmm_trie.insert name (size, active) t)
-      Ok (fst (Vmm_trie.insert name (size, active) t))
 
-let maybe_use_block t name vm active =
+let use_block t name vm active =
   match vm.Unikernel.config.Unikernel.block_device with
-  | None -> Ok t
+  | None -> t
   | Some block ->
     let block_name = Name.block_name name block in
     set_block_usage t block_name active
@@ -68,9 +67,9 @@ let maybe_use_block t name vm active =
 let remove_vm t name = match find_vm t name with
   | None -> Error (`Msg "unknown vm")
   | Some vm ->
-    maybe_use_block t.block_devices name vm false >>| fun block_devices ->
+    let block_devices = use_block t.block_devices name vm false in
     let unikernels = Vmm_trie.remove name t.unikernels in
-    { t with block_devices ; unikernels }
+    Ok { t with block_devices ; unikernels }
 
 let remove_policy t name = match find_policy t name with
   | None -> Error (`Msg "unknown policy")
@@ -126,12 +125,10 @@ let check_vm t name vm =
   vm_ok
 
 let insert_vm t name vm =
-  check_vm t name vm.Unikernel.config >>= fun () ->
+  let unikernels, old = Vmm_trie.insert name vm t.unikernels in
-  match Vmm_trie.insert name vm t.unikernels with
+  (match old with None -> () | Some _ -> invalid_arg ("unikernel " ^ Name.to_string name ^ " already exists in trie")) ;
-  | unikernels, None ->
+  let block_devices = use_block t.block_devices name vm true in
-    maybe_use_block t.block_devices name vm true >>| fun block_devices ->
+  { t with unikernels ; block_devices }
-    { t with unikernels ; block_devices }
-  | _, Some _ -> Error (`Msg "vm already exists")
 
 let check_block t name size =
   let block_ok = match find_block t name with

src/vmm_resources.mli

@@ -37,9 +37,12 @@ val find_block : t -> Name.t -> (int * bool) option
     allowed under the current policies. *)
 val check_vm : t -> Name.t -> Unikernel.config -> (unit, [> `Msg of string ]) result
 
-(** [insert_vm t Name.t vm] inserts [vm] under [Name.t] in [t], and returns the new [t] or
+(** [insert_vm t Name.t vm] inserts [vm] under [Name.t] in [t], and returns the
-    an error. *)
+    new [t].  The caller has to ensure (using {!check_vm}) that a VM with the
-val insert_vm : t -> Name.t -> Unikernel.t -> (t, [> `Msg of string]) result
+    same name does not yet exist, and the block device is not in use.
+    @raise Invalid_argument if block device is already in use, or VM already
+    exists. *)
+val insert_vm : t -> Name.t -> Unikernel.t -> t
 
 (** [insert_policy t Name.t policy] inserts [policy] under [Name.t] in [t], and returns
    the new [t] or an error. *)

src/vmm_unix.ml

@@ -210,7 +210,7 @@ let exec name config taps block =
     Logs.debug (fun m -> m "created process %d: %a" pid Bos.Cmd.pp cmd) ;
     (* we gave a copy (well, two copies) of that file descriptor to the solo5
        process and don't really need it here anymore... *)
-    close stdout ;
+    close_no_err stdout ;
     Ok Unikernel.{ config ; cmd ; pid ; taps }
   with
     Unix.Unix_error (e, _, _) ->

src/vmm_vmmd.ml

@@ -132,19 +132,25 @@ let handle_create t hdr name vm_config =
     (header, `Command (`Console_cmd `Console_add))
   in
   let success t =
-    (* actually execute the vm *)
+    (* actually execute the vm:
+       - check for safety that executing it would not exceed any resources
+       - execute it
+       - update resources
+       --> if either the first or second fails, then the fail continuation
+           below needs to be called *)
     let block_device = match vm_config.Unikernel.block_device with
       | None -> None
       | Some block -> Some (Name.block_name name block)
     in
-    Vmm_unix.exec name vm_config taps block_device >>= fun vm ->
+    Vmm_resources.check_vm t.resources name vm_config >>= fun () ->
+    Vmm_unix.exec name vm_config taps block_device >>| fun vm ->
     Logs.debug (fun m -> m "exec()ed vm") ;
-    Vmm_resources.insert_vm t.resources name vm >>= fun resources ->
+    let resources = Vmm_resources.insert_vm t.resources name vm in
     let t = { t with resources } in
     dump_unikernels t ;
     let t, log_out = log t name (`Unikernel_start (name, vm.Unikernel.pid, vm.Unikernel.taps, None)) in
     let t, stat_out = setup_stats t name vm in
-    Ok (t, stat_out, log_out, (hdr, `Success (`String "created VM")), name, vm)
+    (t, stat_out, log_out, (hdr, `Success (`String "created VM")), name, vm)
   and fail () =
     match Vmm_unix.free_resources name taps with
     | Ok () -> (hdr, `Failure "could not create VM: console failed")