get rid of vm_config.vname

app/vmmc.ml

@@ -94,10 +94,7 @@ let create _ opt_socket force name image cpuid requested_memory boot_params bloc
   (* TODO we could do the compression btw *)
   and vmimage = `Hvt_amd64, Cstruct.of_string image'
   in
-  let vm_config = {
+  let vm_config = { cpuid ; requested_memory ; block_device ; network ; vmimage ; argv } in
-    vname = name ; cpuid ; requested_memory ; block_device ; network ;
-    vmimage ; argv
-  } in
   let cmd =
     if force then
       `Vm_force_create vm_config

app/vmmd.ml

@@ -47,18 +47,18 @@ let create c_fd process cont =
         | Error (`Msg msg) ->
           Logs.err (fun m -> m "create continuation failed %s" msg) ;
           Lwt.return_unit
-        | Ok (state'', out, vm) ->
+        | Ok (state'', out, name, vm) ->
           state := state'' ;
           s := { !s with vm_created = succ !s.vm_created } ;
           Lwt.async (fun () ->
               Vmm_lwt.wait_and_clear vm.Vmm_core.pid vm.Vmm_core.stdout >>= fun r ->
-              let state', out' = Vmm_engine.handle_shutdown !state vm r in
+              let state', out' = Vmm_engine.handle_shutdown !state name vm r in
               s := { !s with vm_destroyed = succ !s.vm_destroyed } ;
               state := state' ;
               process out' >|= fun () ->
               Lwt.wakeup wakeme ()) ;
           process out >>= fun () ->
-          let state', out = Vmm_engine.setup_stats !state vm in
+          let state', out = Vmm_engine.setup_stats !state name vm in
           state := state' ;
           process out (* TODO: need to read from stats socket! *)
 

src/vmm_asn.ml

@@ -248,9 +248,8 @@ let vm_of_cert prefix cert =
   opt cert Oid.network strings_of_cstruct >>= fun network ->
   req "vmimage" cert Oid.vmimage image_of_cstruct >>= fun vmimage ->
   opt cert Oid.argv strings_of_cstruct >>= fun argv ->
-  let vname = prefix @ [ id cert ] in
   let network = match network with None -> [] | Some x -> x in
-  Ok { vname ; cpuid ; requested_memory ; block_device ; network ; vmimage ; argv }
+  Ok { cpuid ; requested_memory ; block_device ; network ; vmimage ; argv }
 
 let command_of_cert version cert =
   version_of_cert version cert >>= fun () ->
@@ -508,7 +507,7 @@ let pp_vm_cmd ppf = function
 let vm_config =
   let f (cpuid, requested_memory, block_device, network, vmimage, argv) =
     let network = match network with None -> [] | Some xs -> xs in
-    { vname = [] ; cpuid ; requested_memory ; block_device ; network ; vmimage ; argv }
+    { cpuid ; requested_memory ; block_device ; network ; vmimage ; argv }
   and g vm =
     let network = match vm.network with [] -> None | xs -> Some xs in
     (vm.cpuid, vm.requested_memory, vm.block_device, network, vm.vmimage, vm.argv)

src/vmm_asn.mli

@@ -233,4 +233,3 @@ type log_entry = header * Ptime.t * Log.event
 val log_entry_to_cstruct : log_entry -> Cstruct.t
 
 val log_entry_of_cstruct : Cstruct.t -> (log_entry, [> `Msg of string ]) result
-

src/vmm_core.ml

@@ -160,7 +160,6 @@ let is_sub ~super ~sub =
   sub_bridges super.bridges sub.bridges && sub_block super.block sub.block
 
 type vm_config = {
-  vname : id ;
   cpuid : int ;
   requested_memory : int ;
   block_device : string option ;
@@ -169,18 +168,13 @@ type vm_config = {
   argv : string list option ;
 }
 
-(* used for block devices *)
-let location vm = match vm.vname with
-  | tld::rest -> tld, String.concat ~sep:"." rest
-  | [] -> invalid_arg "dunno how this happened"
-
 let pp_image ppf (typ, blob) =
   let l = Cstruct.len blob in
   Fmt.pf ppf "%a: %d bytes" pp_vmtype typ l
 
 let pp_vm_config ppf (vm : vm_config) =
-  Fmt.pf ppf "%a cpu %d, %d MB memory, block device %a@ bridge %a, image %a, argv %a"
+  Fmt.pf ppf "cpu %d, %d MB memory, block device %a@ bridge %a, image %a, argv %a"
-    pp_id vm.vname vm.cpuid vm.requested_memory
+    vm.cpuid vm.requested_memory
     Fmt.(option ~none:(unit "no") string) vm.block_device
     Fmt.(list ~sep:(unit ", ") string) vm.network
     pp_image vm.vmimage

src/vmm_core.mli

@@ -204,7 +204,6 @@ val sub_block : 'a option -> 'a option -> bool
 val sub_cpu : IS.t -> IS.t -> bool
 val is_sub : super:policy -> sub:policy -> bool
 type vm_config = {
-  vname : id;
   cpuid : int;
   requested_memory : int;
   block_device : string option;
@@ -212,7 +211,6 @@ type vm_config = {
   vmimage : vmtype * Cstruct.t;
   argv : string list option;
 }
-val location : vm_config -> string * string
 val pp_image :
   Format.formatter ->
   [< `Hvt_amd64 | `Hvt_amd64_compressed | `Hvt_arm64 ] * Cstruct.t -> unit

src/vmm_engine.ml

@@ -47,28 +47,28 @@ let log t id event =
 
 let handle_create t hdr vm_config =
   (* TODO fix (remove field?) *)
-  let vm_config = { vm_config with vname = hdr.Vmm_asn.id } in
+  let name = hdr.Vmm_asn.id in
-  (match Vmm_resources.find_vm t.resources vm_config.vname with
+  (match Vmm_resources.find_vm t.resources name with
    | Some _ -> Error (`Msg "VM with same name is already running")
    | None -> Ok ()) >>= fun () ->
   Logs.debug (fun m -> m "now checking resource policies") ;
-  (if Vmm_resources.check_vm_policy t.resources vm_config then
+  (if Vmm_resources.check_vm_policy t.resources name vm_config then
      Ok ()
    else
      Error (`Msg "resource policies don't allow this")) >>= fun () ->
   (* prepare VM: save VM image to disk, create fifo, ... *)
-  Vmm_unix.prepare vm_config >>= fun taps ->
+  Vmm_unix.prepare name vm_config >>= fun taps ->
   Logs.debug (fun m -> m "prepared vm with taps %a" Fmt.(list ~sep:(unit ",@ ") string) taps) ;
   (* TODO should we pre-reserve sth in t? *)
   let cons = `Console_add in
-  let header = Vmm_asn.{ version = t.wire_version ; sequence = t.console_counter ; id = vm_config.vname } in
+  let header = Vmm_asn.{ version = t.wire_version ; sequence = t.console_counter ; id = name } in
   Ok ({ t with console_counter = Int64.succ t.console_counter }, [ `Cons (header, `Command (`Console_cmd cons)) ],
       `Create (fun t task ->
           (* actually execute the vm *)
-          Vmm_unix.exec vm_config taps >>= fun vm ->
+          Vmm_unix.exec name vm_config taps >>= fun vm ->
           Logs.debug (fun m -> m "exec()ed vm") ;
-          Vmm_resources.insert_vm t.resources vm >>= fun resources ->
+          Vmm_resources.insert_vm t.resources name vm >>= fun resources ->
-          let tasks = String.Map.add (string_of_id vm_config.vname) task t.tasks in
+          let tasks = String.Map.add (string_of_id name) task t.tasks in
           let used_bridges =
             List.fold_left2 (fun b br ta ->
                 let old = match String.Map.find br b with
@@ -79,21 +79,21 @@ let handle_create t hdr vm_config =
               t.used_bridges vm_config.network taps
           in
           let t = { t with resources ; tasks ; used_bridges } in
-          let t, out = log t vm_config.vname (`VM_start (vm.pid, vm.taps, None)) in
+          let t, out = log t name (`VM_start (vm.pid, vm.taps, None)) in
           let data = `Success (`String "created VM") in
-          Ok (t, [ `Data (hdr, data) ; out ], vm)))
+          Ok (t, [ `Data (hdr, data) ; out ], name, vm)))
 
-let setup_stats t vm =
+let setup_stats t name vm =
   let stat_out = `Stats_add (vm.pid, vm.taps) in
-  let header = Vmm_asn.{ version = t.wire_version ; sequence = t.stats_counter ; id = vm.config.vname } in
+  let header = Vmm_asn.{ version = t.wire_version ; sequence = t.stats_counter ; id = name } in
   let t = { t with stats_counter = Int64.succ t.stats_counter } in
   t, [ `Stat (header, `Command (`Stats_cmd stat_out)) ]
 
-let handle_shutdown t vm r =
+let handle_shutdown t name vm r =
-  (match Vmm_unix.shutdown vm with
+  (match Vmm_unix.shutdown name vm with
    | Ok () -> ()
    | Error (`Msg e) -> Logs.warn (fun m -> m "%s while shutdown vm %a" e pp_vm vm)) ;
-  let resources = Vmm_resources.remove t.resources vm.config.vname in
+  let resources = Vmm_resources.remove t.resources name in
   let used_bridges =
     List.fold_left2 (fun b br ta ->
         let old = match String.Map.find br b with
@@ -104,10 +104,10 @@ let handle_shutdown t vm r =
       t.used_bridges vm.config.network vm.taps
   in
   let stat_out = `Stats_remove in
-  let header = Vmm_asn.{ version = t.wire_version ; sequence = t.stats_counter ; id = vm.config.vname } in
+  let header = Vmm_asn.{ version = t.wire_version ; sequence = t.stats_counter ; id = name } in
-  let tasks = String.Map.remove (string_of_id vm.config.vname) t.tasks in
+  let tasks = String.Map.remove (string_of_id name) t.tasks in
   let t = { t with stats_counter = Int64.succ t.stats_counter ; resources ; used_bridges ; tasks } in
-  let t, logout = log t vm.config.vname (`VM_stop (vm.pid, r))
+  let t, logout = log t name (`VM_stop (vm.pid, r))
   in
   (t, [ `Stat (header, `Command (`Stats_cmd stat_out)) ; logout ])
 
@@ -172,8 +172,8 @@ let handle_command t (header, payload) =
     | `Command (`Vm_cmd (`Vm_create vm_config)) ->
       handle_create t header vm_config
     | `Command (`Vm_cmd (`Vm_force_create vm_config)) ->
-      let resources = Vmm_resources.remove t.resources vm_config.vname in
+      let resources = Vmm_resources.remove t.resources id in
-      if Vmm_resources.check_vm_policy resources vm_config then
+      if Vmm_resources.check_vm_policy resources id vm_config then
         begin match Vmm_resources.find_vm t.resources id with
           | None -> handle_create t header vm_config
           | Some vm ->

src/vmm_engine.mli

@@ -11,16 +11,16 @@ type service_out = [
 
 type out = [ service_out | `Data of Vmm_asn.wire ]
 
-val handle_shutdown : 'a t -> Vmm_core.vm ->
+val handle_shutdown : 'a t -> Vmm_core.id -> Vmm_core.vm ->
   [ `Exit of int | `Signal of int | `Stop of int ] -> 'a t * out list
 
 val handle_command : 'a t -> Vmm_asn.wire ->
   'a t * out list *
-  [ `Create of 'c t -> 'c -> ('c t * out list * Vmm_core.vm, [> Rresult.R.msg ]) result
+  [ `Create of 'c t -> 'c -> ('c t * out list * Vmm_core.id * Vmm_core.vm, [> Rresult.R.msg ]) result
   | `End
   | `Wait of 'a * out list
   | `Wait_and_create of 'a * ('a t -> 'a t * out list *
-                                      [ `Create of 'd t -> 'd -> ('d t * out list * Vmm_core.vm, [> Rresult.R.msg ]) result
+                                      [ `Create of 'd t -> 'd -> ('d t * out list * Vmm_core.id * Vmm_core.vm, [> Rresult.R.msg ]) result
                                       | `End ]) ]
 
-val setup_stats : 'a t -> Vmm_core.vm -> 'a t * out list
+val setup_stats : 'a t -> Vmm_core.id -> Vmm_core.vm -> 'a t * out list

src/vmm_resources.ml

@@ -50,17 +50,17 @@ let find_vm t name = match Vmm_trie.find name t with
   | Some (Vm vm) -> Some vm
   | _ -> None
 
-let check_vm_policy t vm =
+let check_vm_policy t name vm =
-  let dom = domain vm.vname in
+  let dom = domain name in
   let res = resource_usage t dom in
   match Vmm_trie.find dom t with
   | None -> true
   | Some (Vm _) -> assert false
   | Some (Policy p) -> check_resource p vm res
 
-let insert_vm t vm =
+let insert_vm t name vm =
-  if check_vm_policy t vm.config then
+  if check_vm_policy t name vm.config then
-    match Vmm_trie.insert vm.config.vname (Vm vm) t with
+    match Vmm_trie.insert name (Vm vm) t with
     | t', None -> Ok t'
     | _, Some _ -> Error (`Msg "vm already exists")
   else

src/vmm_resources.mli

@@ -22,11 +22,11 @@ val find_vm : t -> Vmm_core.id -> Vmm_core.vm option
 
 (** [check_vm_policy t vm] checks whether [vm] under [id] in [t] would be
     allowed under the current policies. *)
-val check_vm_policy : t -> Vmm_core.vm_config -> bool
+val check_vm_policy : t -> Vmm_core.id -> Vmm_core.vm_config -> bool
 
 (** [insert_vm t vm] inserts [vm] under [id] in [t], and returns the new [t] or
     an error. *)
-val insert_vm : t -> Vmm_core.vm -> (t, [> `Msg of string]) result
+val insert_vm : t -> Vmm_core.id -> Vmm_core.vm -> (t, [> `Msg of string]) result
 
 (** [insert_policy t id policy] inserts [policy] under [id] in [t], and returns
    the new [t] or an error. *)

src/vmm_unix.ml

@@ -58,8 +58,8 @@ let rec mkfifo name =
   | Unix.Unix_error (Unix.EINTR, _, _) -> mkfifo name
 
 let image_file, fifo_file =
-  ((fun vm -> Fpath.(tmpdir / (string_of_id vm.vname) + "img")),
+  ((fun name -> Fpath.(tmpdir / (string_of_id name) + "img")),
-   (fun vm -> Fpath.(tmpdir / "fifo" / (string_of_id vm.vname))))
+   (fun name -> Fpath.(tmpdir / "fifo" / (string_of_id name))))
 
 let rec fifo_exists file =
   try Ok (Unix.((stat @@ Fpath.to_string file).st_kind = S_FIFO)) with
@@ -103,18 +103,7 @@ let destroy_tap tapname =
     Bos.OS.Cmd.run Bos.Cmd.(v "ip" % "tuntap" % "del" % "dev" % tapname % "mode" % "tap")
   | x -> Error (`Msg ("unsupported operating system " ^ x))
 
-let create_bridge bname =
+let prepare name vm =
-  Lazy.force (uname ()) >>= fun (sys, _) ->
-  match sys with
-  | x when x = "FreeBSD" ->
-    let cmd = Bos.Cmd.(v "ifconfig" % "bridge" % "create") in
-    Bos.OS.Cmd.run_out cmd |> Bos.OS.Cmd.out_string >>= fun (name, _) ->
-    Bos.OS.Cmd.run Bos.Cmd.(v "ifconfig" % name % "name" % bname)
-  | x when x = "Linux" ->
-    Bos.OS.Cmd.run Bos.Cmd.(v "brctl" % "addbr" % bname)
-  | x -> Error (`Msg ("unsupported operating system " ^ x))
-
-let prepare vm =
   (match vm.vmimage with
    | `Hvt_amd64, blob -> Ok blob
    | `Hvt_amd64_compressed, blob ->
@@ -123,7 +112,7 @@ let prepare vm =
        | Error () -> Error (`Msg "failed to uncompress")
      end
    | `Hvt_arm64, _ -> Error (`Msg "no amd64 hvt image found")) >>= fun image ->
-  let fifo = fifo_file vm in
+  let fifo = fifo_file name in
   (match fifo_exists fifo with
    | Ok true -> Ok ()
    | Ok false -> Error (`Msg ("file " ^ Fpath.to_string fifo ^ " exists and is not a fifo"))
@@ -137,13 +126,13 @@ let prepare vm =
       create_tap b >>= fun tap ->
       Ok (tap :: acc))
     (Ok []) vm.network >>= fun taps ->
-  Bos.OS.File.write (image_file vm) (Cstruct.to_string image) >>= fun () ->
+  Bos.OS.File.write (image_file name) (Cstruct.to_string image) >>= fun () ->
   Ok (List.rev taps)
 
-let shutdown vm =
+let shutdown name vm =
   (* same order as prepare! *)
-  Bos.OS.File.delete (image_file vm.config) >>= fun () ->
+  Bos.OS.File.delete (image_file name) >>= fun () ->
-  Bos.OS.File.delete (fifo_file vm.config) >>= fun () ->
+  Bos.OS.File.delete (fifo_file name) >>= fun () ->
   List.fold_left (fun r n -> r >>= fun () -> destroy_tap n) (Ok ()) vm.taps
 
 let cpuset cpu =
@@ -156,7 +145,7 @@ let cpuset cpu =
     Ok ([ "taskset" ; "-c" ; cpustring ])
   | x -> Error (`Msg ("unsupported operating system " ^ x))
 
-let exec vm taps =
+let exec name vm taps =
   (* TODO: --net-mac=xx *)
   let net = List.map (fun t -> "--net=" ^ t) taps in
   let argv = match vm.argv with None -> [] | Some xs -> xs in
@@ -168,12 +157,12 @@ let exec vm taps =
   let mem = "--mem=" ^ string_of_int vm.requested_memory in
   let cmd =
     Bos.Cmd.(of_list cpuset % p bin % mem %% of_list net %
-             "--" % p (image_file vm) %% of_list argv)
+             "--" % p (image_file name) %% of_list argv)
   in
   let line = Bos.Cmd.to_list cmd in
   let prog = try List.hd line with Failure _ -> failwith err_empty_line in
   let line = Array.of_list line in
-  let fifo = fifo_file vm in
+  let fifo = fifo_file name in
   Logs.debug (fun m -> m "write fd for fifo %a" Fpath.pp fifo);
   write_fd_for_file fifo >>= fun stdout ->
   Logs.debug (fun m -> m "opened file descriptor!");

src/vmm_unix.mli

@@ -4,16 +4,14 @@ open Rresult
 
 open Vmm_core
 
-val prepare : vm_config -> (string list, [> R.msg ]) result
+val prepare : id -> vm_config -> (string list, [> R.msg ]) result
 
-val shutdown : vm -> (unit, [> R.msg ]) result
+val shutdown : id -> vm -> (unit, [> R.msg ]) result
 
-val exec : vm_config -> string list -> (vm, [> R.msg ]) result
+val exec : id -> vm_config -> string list -> (vm, [> R.msg ]) result
 
 val destroy : vm -> unit
 
 val close_no_err : Unix.file_descr -> unit
 
 val create_tap : string -> (string, [> R.msg ]) result
-
-val create_bridge : string -> (unit, [> R.msg ]) result