diff --git a/app/vmmc.ml b/app/vmmc.ml index d66ee7a..87d7745 100644 --- a/app/vmmc.ml +++ b/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 = { - vname = name ; cpuid ; requested_memory ; block_device ; network ; - vmimage ; argv - } in + let vm_config = { cpuid ; requested_memory ; block_device ; network ; vmimage ; argv } in let cmd = if force then `Vm_force_create vm_config diff --git a/app/vmmd.ml b/app/vmmd.ml index 1f89fba..fea7f31 100644 --- a/app/vmmd.ml +++ b/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! *) diff --git a/src/vmm_asn.ml b/src/vmm_asn.ml index bd421f5..d7b1854 100644 --- a/src/vmm_asn.ml +++ b/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) diff --git a/src/vmm_asn.mli b/src/vmm_asn.mli index 9094932..80c60ee 100644 --- a/src/vmm_asn.mli +++ b/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 - diff --git a/src/vmm_core.ml b/src/vmm_core.ml index e58e95f..cc03fc6 100644 --- a/src/vmm_core.ml +++ b/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" - pp_id vm.vname vm.cpuid vm.requested_memory + Fmt.pf ppf "cpu %d, %d MB memory, block device %a@ bridge %a, image %a, argv %a" + 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 diff --git a/src/vmm_core.mli b/src/vmm_core.mli index 6c0bd83..979605b 100644 --- a/src/vmm_core.mli +++ b/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 diff --git a/src/vmm_engine.ml b/src/vmm_engine.ml index af9c47b..8fdc605 100644 --- a/src/vmm_engine.ml +++ b/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 - (match Vmm_resources.find_vm t.resources vm_config.vname with + let name = hdr.Vmm_asn.id in + (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 -> - let tasks = String.Map.add (string_of_id vm_config.vname) task t.tasks in + Vmm_resources.insert_vm t.resources name vm >>= fun resources -> + 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 = - (match Vmm_unix.shutdown vm with +let handle_shutdown t name vm r = + (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 tasks = String.Map.remove (string_of_id vm.config.vname) t.tasks in + let header = Vmm_asn.{ version = t.wire_version ; sequence = t.stats_counter ; id = name } 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 - if Vmm_resources.check_vm_policy resources vm_config then + let resources = Vmm_resources.remove t.resources id in + 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 -> diff --git a/src/vmm_engine.mli b/src/vmm_engine.mli index af6d787..bf119a5 100644 --- a/src/vmm_engine.mli +++ b/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 diff --git a/src/vmm_resources.ml b/src/vmm_resources.ml index a3be201..55d2932 100644 --- a/src/vmm_resources.ml +++ b/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 dom = domain vm.vname in +let check_vm_policy t name vm = + 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 = - if check_vm_policy t vm.config then - match Vmm_trie.insert vm.config.vname (Vm vm) t with +let insert_vm t name vm = + if check_vm_policy t name vm.config then + match Vmm_trie.insert name (Vm vm) t with | t', None -> Ok t' | _, Some _ -> Error (`Msg "vm already exists") else diff --git a/src/vmm_resources.mli b/src/vmm_resources.mli index 9878c65..ced6a6b 100644 --- a/src/vmm_resources.mli +++ b/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. *) diff --git a/src/vmm_unix.ml b/src/vmm_unix.ml index 3b17165..b6cb824 100644 --- a/src/vmm_unix.ml +++ b/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 vm -> Fpath.(tmpdir / "fifo" / (string_of_id vm.vname)))) + ((fun name -> Fpath.(tmpdir / (string_of_id name) + "img")), + (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 = - 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 = +let prepare name 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 (fifo_file vm.config) >>= fun () -> + Bos.OS.File.delete (image_file name) >>= 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!"); diff --git a/src/vmm_unix.mli b/src/vmm_unix.mli index 5c79b2f..8a4d9d3 100644 --- a/src/vmm_unix.mli +++ b/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