diff --git a/app/vmm_cli.ml b/app/vmm_cli.ml index a9ce21d..546e924 100644 --- a/app/vmm_cli.ml +++ b/app/vmm_cli.ml @@ -27,7 +27,7 @@ let create_vm force image cpuid requested_memory argv block_device network compr `Hvt_amd64_compressed, Cstruct.of_string img and argv = match argv with [] -> None | xs -> Some xs in - let vm_config = { cpuid ; requested_memory ; block_device ; network ; argv ; vmimage } in + let vm_config = Vm.{ cpuid ; requested_memory ; block_device ; network ; argv ; vmimage } in if force then `Vm_force_create vm_config else `Vm_create vm_config let policy vms memory cpus block bridges = diff --git a/app/vmmd.ml b/app/vmmd.ml index ae074e8..8585ed6 100644 --- a/app/vmmd.ml +++ b/app/vmmd.ml @@ -32,7 +32,7 @@ let create process cont = 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 -> + Vmm_lwt.wait_and_clear vm.Vmm_core.Vm.pid vm.Vmm_core.Vm.stdout >>= fun r -> let state', out' = Vmm_vmmd.handle_shutdown !state name vm r in s := { !s with vm_destroyed = succ !s.vm_destroyed } ; state := state' ; diff --git a/src/vmm_asn.ml b/src/vmm_asn.ml index f854a96..5806c6d 100644 --- a/src/vmm_asn.ml +++ b/src/vmm_asn.ml @@ -265,10 +265,10 @@ let log_cmd = let vm_config = let f (cpuid, requested_memory, block_device, network, vmimage, argv) = let network = match network with None -> [] | Some xs -> xs in - { cpuid ; requested_memory ; block_device ; network ; vmimage ; argv } + Vm.{ 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) + let network = match vm.Vm.network with [] -> None | xs -> Some xs in + (vm.Vm.cpuid, vm.Vm.requested_memory, vm.Vm.block_device, network, vm.Vm.vmimage, vm.Vm.argv) in Asn.S.map f g @@ Asn.S.(sequence6 diff --git a/src/vmm_commands.ml b/src/vmm_commands.ml index 8204db3..efd6b3e 100644 --- a/src/vmm_commands.ml +++ b/src/vmm_commands.ml @@ -48,15 +48,15 @@ let pp_log_cmd ppf = function type vm_cmd = [ | `Vm_info - | `Vm_create of vm_config - | `Vm_force_create of vm_config + | `Vm_create of Vm.config + | `Vm_force_create of Vm.config | `Vm_destroy ] let pp_vm_cmd ppf = function | `Vm_info -> Fmt.string ppf "vm info" - | `Vm_create vm_config -> Fmt.pf ppf "vm create %a" pp_vm_config vm_config - | `Vm_force_create vm_config -> Fmt.pf ppf "vm force create %a" pp_vm_config vm_config + | `Vm_create vm_config -> Fmt.pf ppf "vm create %a" Vm.pp_config vm_config + | `Vm_force_create vm_config -> Fmt.pf ppf "vm force create %a" Vm.pp_config vm_config | `Vm_destroy -> Fmt.string ppf "vm destroy" type policy_cmd = [ @@ -120,7 +120,7 @@ type success = [ | `Empty | `String of string | `Policies of (Name.t * Policy.t) list - | `Vms of (Name.t * vm_config) list + | `Vms of (Name.t * Vm.config) list | `Blocks of (Name.t * int * bool) list ] @@ -131,7 +131,7 @@ let pp_success ppf = function | `Empty -> Fmt.string ppf "success" | `String data -> Fmt.pf ppf "success: %s" data | `Policies ps -> Fmt.(list ~sep:(unit "@.") (pair ~sep:(unit ": ") Name.pp Policy.pp)) ppf ps - | `Vms vms -> Fmt.(list ~sep:(unit "@.") (pair ~sep:(unit ": ") Name.pp pp_vm_config)) ppf vms + | `Vms vms -> Fmt.(list ~sep:(unit "@.") (pair ~sep:(unit ": ") Name.pp Vm.pp_config)) ppf vms | `Blocks blocks -> Fmt.(list ~sep:(unit "@.") pp_block) ppf blocks type wire = header * [ diff --git a/src/vmm_commands.mli b/src/vmm_commands.mli index 19c7324..2836c81 100644 --- a/src/vmm_commands.mli +++ b/src/vmm_commands.mli @@ -28,8 +28,8 @@ type log_cmd = [ type vm_cmd = [ | `Vm_info - | `Vm_create of vm_config - | `Vm_force_create of vm_config + | `Vm_create of Vm.config + | `Vm_force_create of Vm.config | `Vm_destroy ] @@ -74,7 +74,7 @@ type success = [ | `Empty | `String of string | `Policies of (Name.t * Policy.t) list - | `Vms of (Name.t * vm_config) list + | `Vms of (Name.t * Vm.config) list | `Blocks of (Name.t * int * bool) list ] diff --git a/src/vmm_core.ml b/src/vmm_core.ml index b6a9a79..b07585b 100644 --- a/src/vmm_core.ml +++ b/src/vmm_core.ml @@ -30,13 +30,6 @@ end module IS = Set.Make(I) module IM = Map.Make(I) -type vmtype = [ `Hvt_amd64 | `Hvt_arm64 | `Hvt_amd64_compressed ] - -let pp_vmtype ppf = function - | `Hvt_amd64 -> Fmt.pf ppf "hvt-amd64" - | `Hvt_amd64_compressed -> Fmt.pf ppf "hvt-amd64-compressed" - | `Hvt_arm64 -> Fmt.pf ppf "hvt-arm64" - module Name = struct type t = string list @@ -201,65 +194,69 @@ module Policy = struct sub_bridges super.bridges sub.bridges && sub_block super.block sub.block end -type vm_config = { - cpuid : int ; - requested_memory : int ; - block_device : string option ; - network : string list ; - vmimage : vmtype * Cstruct.t ; - argv : string list option ; -} +module Vm = struct + type vmtype = [ `Hvt_amd64 | `Hvt_arm64 | `Hvt_amd64_compressed ] -let pp_image ppf (typ, blob) = - let l = Cstruct.len blob in - Fmt.pf ppf "%a: %d bytes" pp_vmtype typ l + let pp_vmtype ppf = function + | `Hvt_amd64 -> Fmt.pf ppf "hvt-amd64" + | `Hvt_amd64_compressed -> Fmt.pf ppf "hvt-amd64-compressed" + | `Hvt_arm64 -> Fmt.pf ppf "hvt-arm64" -let pp_vm_config ppf (vm : vm_config) = - 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 - Fmt.(option ~none:(unit "no") (list ~sep:(unit " ") string)) vm.argv + type config = { + cpuid : int ; + requested_memory : int ; + block_device : string option ; + network : string list ; + vmimage : vmtype * Cstruct.t ; + argv : string list option ; + } -let good_bridge idxs nets = - (* TODO: uniqueness of n -- it should be an ordered set? *) - List.for_all (fun n -> String.Map.mem n nets) idxs + let pp_image ppf (typ, blob) = + let l = Cstruct.len blob in + Fmt.pf ppf "%a: %d bytes" pp_vmtype typ l -let vm_matches_res (res : Policy.t) (vm : vm_config) = - res.Policy.vms >= 1 && IS.mem vm.cpuid res.Policy.cpuids && - vm.requested_memory <= res.memory && - good_bridge vm.network res.bridges + let pp_config ppf (vm : config) = + 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 + Fmt.(option ~none:(unit "no") (list ~sep:(unit " ") string)) vm.argv -let check_policies vm res = - let rec climb = function - | super :: sub :: xs -> - if Policy.is_sub ~super ~sub then climb (sub :: xs) - else Error (`Msg "policy violation") - | [x] -> Ok x - | [] -> Error (`Msg "empty resource list") - in - climb res >>= fun res -> - if vm_matches_res res vm then Ok () else Error (`Msg "VM does not match policy") + let good_bridge idxs nets = + (* TODO: uniqueness of n -- it should be an ordered set? *) + List.for_all (fun n -> String.Map.mem n nets) idxs -type vm = { - config : vm_config ; - cmd : Bos.Cmd.t ; - pid : int ; - taps : string list ; - stdout : Unix.file_descr (* ringbuffer thingy *) -} + let vm_matches_res (res : Policy.t) (vm : config) = + res.Policy.vms >= 1 && IS.mem vm.cpuid res.Policy.cpuids && + vm.requested_memory <= res.Policy.memory && + good_bridge vm.network res.Policy.bridges -let pp_vm ppf vm = - Fmt.pf ppf "pid %d@ taps %a (block %a) cmdline %a" - vm.pid Fmt.(list ~sep:(unit ", ") string) vm.taps - Fmt.(option ~none:(unit "no") string) vm.config.block_device - Bos.Cmd.pp vm.cmd + let check_policies vm res = + let rec climb = function + | super :: sub :: xs -> + if Policy.is_sub ~super ~sub then climb (sub :: xs) + else Error (`Msg "policy violation") + | [x] -> Ok x + | [] -> Error (`Msg "empty resource list") + in + climb res >>= fun res -> + if vm_matches_res res vm then Ok () else Error (`Msg "VM does not match policy") -let translate_tap vm tap = - match List.filter (fun (t, _) -> tap = t) (List.combine vm.taps vm.config.network) with - | [ (_, b) ] -> Some b - | _ -> None + type t = { + config : config ; + cmd : Bos.Cmd.t ; + pid : int ; + taps : string list ; + stdout : Unix.file_descr (* ringbuffer thingy *) + } + + let pp ppf vm = + Fmt.pf ppf "pid %d@ taps %a (block %a) cmdline %a" + vm.pid Fmt.(list ~sep:(unit ", ") string) vm.taps + Fmt.(option ~none:(unit "no") string) vm.config.block_device + Bos.Cmd.pp vm.cmd +end module Stats = struct type rusage = { diff --git a/src/vmm_core.mli b/src/vmm_core.mli index 42eb4c7..349760a 100644 --- a/src/vmm_core.mli +++ b/src/vmm_core.mli @@ -62,38 +62,39 @@ module Policy : sig val is_sub : super:t -> sub:t -> bool end -type vmtype = [ `Hvt_amd64 | `Hvt_amd64_compressed | `Hvt_arm64 ] -val pp_vmtype : vmtype Fmt.t +module Vm : sig + type vmtype = [ `Hvt_amd64 | `Hvt_amd64_compressed | `Hvt_arm64 ] + val pp_vmtype : vmtype Fmt.t -type vm_config = { - cpuid : int; - requested_memory : int; - block_device : string option; - network : string list; - vmimage : vmtype * Cstruct.t; - argv : string list option; -} + type config = { + cpuid : int; + requested_memory : int; + block_device : string option; + network : string list; + vmimage : vmtype * Cstruct.t; + argv : string list option; + } -val pp_image : (vmtype * Cstruct.t) Fmt.t + val pp_image : (vmtype * Cstruct.t) Fmt.t -val pp_vm_config : vm_config Fmt.t -val good_bridge : string list -> 'a Astring.String.map -> bool + val pp_config : config Fmt.t + val good_bridge : string list -> 'a Astring.String.map -> bool -val vm_matches_res : Policy.t -> vm_config -> bool + val vm_matches_res : Policy.t -> config -> bool -val check_policies : - vm_config -> Policy.t list -> (unit, [> `Msg of string ]) Result.result + val check_policies : + config -> Policy.t list -> (unit, [> `Msg of string ]) Result.result -type vm = { - config : vm_config; - cmd : Bos.Cmd.t; - pid : int; - taps : string list; - stdout : Unix.file_descr; -} + type t = { + config : config; + cmd : Bos.Cmd.t; + pid : int; + taps : string list; + stdout : Unix.file_descr; + } -val pp_vm : vm Fmt.t -val translate_tap : vm -> string -> string option + val pp : t Fmt.t +end module Stats : sig type rusage = { diff --git a/src/vmm_resources.ml b/src/vmm_resources.ml index e98e6e2..24f492b 100644 --- a/src/vmm_resources.ml +++ b/src/vmm_resources.ml @@ -10,10 +10,10 @@ type res_entry = { let empty_res = { running_vms = 0 ; used_memory = 0 ; used_blockspace = 0 } -let check_resource (p : Policy.t) (vm : vm_config) (res : res_entry) = +let check_resource (p : Policy.t) (vm : Vm.config) (res : res_entry) = succ res.running_vms <= p.Policy.vms && - res.used_memory + vm.requested_memory <= p.Policy.memory && - vm_matches_res p vm + res.used_memory + vm.Vm.requested_memory <= p.Policy.memory && + Vm.vm_matches_res p vm let check_resource_policy (p : Policy.t) (res : res_entry) = res.running_vms <= p.Policy.vms && res.used_memory <= p.Policy.memory && @@ -22,12 +22,12 @@ let check_resource_policy (p : Policy.t) (res : res_entry) = | Some mb -> res.used_blockspace <= mb type entry = - | Vm of vm + | Vm of Vm.t | Block of int * bool | Policy of Policy.t let pp_entry id ppf = function - | Vm vm -> Fmt.pf ppf "vm %a: %a@." Name.pp id pp_vm_config vm.config + | Vm vm -> Fmt.pf ppf "vm %a: %a@." Name.pp id Vm.pp_config vm.Vm.config | Policy p -> Fmt.pf ppf "policy %a: %a@." Name.pp id Policy.pp p | Block (size, used) -> Fmt.pf ppf "block device %a: %dMB (used %B)@." Name.pp id size used @@ -56,7 +56,7 @@ let resource_usage t name = | Block (size, _) -> { res with used_blockspace = res.used_blockspace + size } | Vm vm -> { res with running_vms = succ res.running_vms ; - used_memory = vm.config.requested_memory + res.used_memory }) + used_memory = vm.Vm.config.Vm.requested_memory + res.used_memory }) empty_res let find_vm t name = match Vmm_trie.find name t with @@ -72,7 +72,7 @@ let find_block t name = match Vmm_trie.find name t with | _ -> None let set_block_usage active t name vm = - match vm.config.block_device with + match vm.Vm.config.Vm.block_device with | None -> Ok t | Some block -> let block_name = Name.block_name name block in @@ -108,7 +108,7 @@ let check_vm_policy t name vm = let insert_vm t name vm = let open Rresult.R.Infix in - check_vm_policy t name vm.config >>= function + check_vm_policy t name vm.Vm.config >>= function | false -> Error (`Msg "resource policy mismatch") | true -> match Vmm_trie.insert name (Vm vm) t with | t', None -> set_block_usage true t' name vm @@ -135,8 +135,8 @@ let check_policy_below t name p = then Some p' else None | Vm vm, Some p -> - let cfg = vm.config in - if IS.mem cfg.cpuid p.cpuids && good_bridge cfg.network p.bridges + let cfg = vm.Vm.config in + if IS.mem cfg.Vm.cpuid p.Policy.cpuids && Vm.good_bridge cfg.Vm.network p.Policy.bridges then Some p else None | _, res -> res) diff --git a/src/vmm_resources.mli b/src/vmm_resources.mli index d812927..a6db281 100644 --- a/src/vmm_resources.mli +++ b/src/vmm_resources.mli @@ -18,7 +18,7 @@ type t val empty : t (** [find_vm t id] is either [Some vm] or [None]. *) -val find_vm : t -> Vmm_core.Name.t -> Vmm_core.vm option +val find_vm : t -> Vmm_core.Name.t -> Vmm_core.Vm.t option (** [find_policy t Name.t] is either [Some policy] or [None]. *) val find_policy : t -> Vmm_core.Name.t -> Vmm_core.Policy.t option @@ -28,11 +28,11 @@ val find_block : t -> Vmm_core.Name.t -> (int * bool) option (** [check_vm_policy t Name.t vm] checks whether [vm] under [Name.t] in [t] would be allowed under the current policies. *) -val check_vm_policy : t -> Vmm_core.Name.t -> Vmm_core.vm_config -> (bool, [> `Msg of string ]) result +val check_vm_policy : t -> Vmm_core.Name.t -> Vmm_core.Vm.config -> (bool, [> `Msg of string ]) result (** [insert_vm t Name.t vm] inserts [vm] under [Name.t] in [t], and returns the new [t] or an error. *) -val insert_vm : t -> Vmm_core.Name.t -> Vmm_core.vm -> (t, [> `Msg of string]) result +val insert_vm : t -> Vmm_core.Name.t -> Vmm_core.Vm.t -> (t, [> `Msg of string]) result (** [insert_policy t Name.t policy] inserts [policy] under [Name.t] in [t], and returns the new [t] or an error. *) @@ -57,7 +57,7 @@ val remove_block : t -> Vmm_core.Name.t -> (t, [> `Msg of string ]) result (** [fold t Name.t f_vm f_policy f_block acc] folds [f_vm], [f_policy] and [f_block] below [Name.t] over [t]. *) val fold : t -> Vmm_core.Name.t -> - (Vmm_core.Name.t -> Vmm_core.vm -> 'a -> 'a) -> + (Vmm_core.Name.t -> Vmm_core.Vm.t -> 'a -> 'a) -> (Vmm_core.Name.t -> Vmm_core.Policy.t -> 'a -> 'a) -> (Vmm_core.Name.t -> int -> bool -> 'a -> 'a) -> 'a -> 'a diff --git a/src/vmm_unix.ml b/src/vmm_unix.ml index f1edc79..be91da2 100644 --- a/src/vmm_unix.ml +++ b/src/vmm_unix.ml @@ -107,7 +107,7 @@ let destroy_tap tapname = | x -> Error (`Msg ("unsupported operating system " ^ x)) let prepare name vm = - (match vm.vmimage with + (match vm.Vm.vmimage with | `Hvt_amd64, blob -> Ok blob | `Hvt_amd64_compressed, blob -> begin match Vmm_compress.uncompress (Cstruct.to_string blob) with @@ -128,7 +128,7 @@ let prepare name vm = acc >>= fun acc -> create_tap b >>= fun tap -> Ok (tap :: acc)) - (Ok []) vm.network >>= fun taps -> + (Ok []) vm.Vm.network >>= fun taps -> Bos.OS.File.write (Name.image_file name) (Cstruct.to_string image) >>= fun () -> Ok (List.rev taps) @@ -136,7 +136,7 @@ let shutdown name vm = (* same order as prepare! *) Bos.OS.File.delete (Name.image_file name) >>= fun () -> Bos.OS.File.delete (Name.fifo_file name) >>= fun () -> - List.fold_left (fun r n -> r >>= fun () -> destroy_tap n) (Ok ()) vm.taps + List.fold_left (fun r n -> r >>= fun () -> destroy_tap n) (Ok ()) vm.Vm.taps let cpuset cpu = Lazy.force (uname ()) >>= fun (sys, _) -> @@ -157,10 +157,10 @@ let exec name vm taps block = | _, _ -> Error (`Msg "cannot handle multiple network interfaces")) >>= fun bin -> let net = List.map (fun t -> "--net=" ^ t) taps and block = match block with None -> [] | Some dev -> [ "--disk=" ^ Fpath.to_string (block_file dev) ] - and argv = match vm.argv with None -> [] | Some xs -> xs - and mem = "--mem=" ^ string_of_int vm.requested_memory + and argv = match vm.Vm.argv with None -> [] | Some xs -> xs + and mem = "--mem=" ^ string_of_int vm.Vm.requested_memory in - cpuset vm.cpuid >>= fun cpuset -> + cpuset vm.Vm.cpuid >>= fun cpuset -> let cmd = Bos.Cmd.(of_list cpuset % p Fpath.(dbdir / "solo5-hvt" + bin) % mem %% of_list net %% of_list block % @@ -178,14 +178,14 @@ let exec name vm taps block = let pid = create_process prog line stdout stdout in Logs.debug (fun m -> m "created process %d: %a" pid Bos.Cmd.pp cmd) ; (* this should get rid of the vmimage from vmmd's memory! *) - let config = { vm with vmimage = (fst vm.vmimage, Cstruct.create 0) } in - Ok { config ; cmd ; pid ; taps ; stdout } + let config = Vm.{ vm with vmimage = (fst vm.vmimage, Cstruct.create 0) } in + Ok Vm.{ config ; cmd ; pid ; taps ; stdout } with Unix.Unix_error (e, _, _) -> close_no_err stdout; R.error_msgf "cmd %a exits: %a" Bos.Cmd.pp cmd pp_unix_error e -let destroy vm = Unix.kill vm.pid 15 (* 15 is SIGTERM *) +let destroy vm = Unix.kill vm.Vm.pid 15 (* 15 is SIGTERM *) let bytes_of_mb size = let res = size lsl 20 in diff --git a/src/vmm_unix.mli b/src/vmm_unix.mli index ba74287..7b7ecc4 100644 --- a/src/vmm_unix.mli +++ b/src/vmm_unix.mli @@ -4,13 +4,13 @@ open Rresult open Vmm_core -val prepare : Name.t -> vm_config -> (string list, [> R.msg ]) result +val prepare : Name.t -> Vm.config -> (string list, [> R.msg ]) result -val shutdown : Name.t -> vm -> (unit, [> R.msg ]) result +val shutdown : Name.t -> Vm.t -> (unit, [> R.msg ]) result -val exec : Name.t -> vm_config -> string list -> Name.t option -> (vm, [> R.msg ]) result +val exec : Name.t -> Vm.config -> string list -> Name.t option -> (Vm.t, [> R.msg ]) result -val destroy : vm -> unit +val destroy : Vm.t -> unit val close_no_err : Unix.file_descr -> unit diff --git a/src/vmm_vmmd.ml b/src/vmm_vmmd.ml index 93c768d..1fbf01e 100644 --- a/src/vmm_vmmd.ml +++ b/src/vmm_vmmd.ml @@ -64,7 +64,7 @@ let handle_create t reply name vm_config = (Vmm_resources.check_vm_policy t.resources name vm_config >>= function | false -> Error (`Msg "resource policies don't allow creation of this VM") | true -> Ok ()) >>= fun () -> - (match vm_config.block_device with + (match vm_config.Vm.block_device with | None -> Ok None | Some dev -> let block_device_name = Name.block_name name dev in @@ -89,11 +89,11 @@ let handle_create t reply name vm_config = Vmm_resources.insert_vm t.resources name vm >>= fun resources -> let tasks = String.Map.add (Name.to_string name) task t.tasks in let t = { t with resources ; tasks } in - let t, out = log t name (`Vm_start (name, vm.pid, vm.taps, None)) in + let t, out = log t name (`Vm_start (name, vm.Vm.pid, vm.Vm.taps, None)) in Ok (t, [ reply (`String "created VM") ; out ], name, vm))) let setup_stats t name vm = - let stat_out = `Stats_add (vm.pid, vm.taps) in + let stat_out = `Stats_add (vm.Vm.pid, vm.Vm.taps) in let header = Vmm_commands.{ version = t.wire_version ; sequence = t.stats_counter ; name } in let t = { t with stats_counter = Int64.succ t.stats_counter } in t, `Stat (header, `Command (`Stats_cmd stat_out)) @@ -101,17 +101,17 @@ let setup_stats t name vm = 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)) ; + | Error (`Msg e) -> Logs.warn (fun m -> m "%s while shutdown vm %a" e Vm.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 pp_vm vm) ; + Logs.warn (fun m -> m "%s while removing vm %a from resources" e Vm.pp vm) ; t.resources | Ok resources -> resources in let header = Vmm_commands.{ version = t.wire_version ; sequence = t.stats_counter ; name } in let tasks = String.Map.remove (Name.to_string name) t.tasks in let t = { t with stats_counter = Int64.succ t.stats_counter ; resources ; tasks } in - let t, logout = log t name (`Vm_stop (name, vm.pid, r)) + let t, logout = log t name (`Vm_stop (name, vm.Vm.pid, r)) in (t, [ `Stat (header, `Command (`Stats_cmd `Stats_remove)) ; logout ]) @@ -152,7 +152,7 @@ let handle_vm_cmd t reply id msg_to_err = function Logs.debug (fun m -> m "info %a" Name.pp id) ; let vms = Vmm_resources.fold t.resources id - (fun id vm vms -> (id, vm.config) :: vms) + (fun id vm vms -> (id, vm.Vm.config) :: vms) (fun _ _ vms-> vms) (fun _ _ _ vms -> vms) [] diff --git a/src/vmm_vmmd.mli b/src/vmm_vmmd.mli index 99dec53..de6fab1 100644 --- a/src/vmm_vmmd.mli +++ b/src/vmm_vmmd.mli @@ -12,17 +12,17 @@ type service_out = [ type out = [ service_out | `Data of Vmm_commands.wire ] -val handle_shutdown : 'a t -> Vmm_core.Name.t -> Vmm_core.vm -> +val handle_shutdown : 'a t -> Vmm_core.Name.t -> Vmm_core.Vm.t -> [ `Exit of int | `Signal of int | `Stop of int ] -> 'a t * out list val handle_command : 'a t -> Vmm_commands.wire -> 'a t * out list * - [ `Create of 'c t -> 'c -> ('c t * out list * Vmm_core.Name.t * Vmm_core.vm, [> `Msg of string ]) result + [ `Create of 'c t -> 'c -> ('c t * out list * Vmm_core.Name.t * Vmm_core.Vm.t, [> `Msg of string ]) result | `Loop | `End | `Wait of 'a * out | `Wait_and_create of 'a * ('a t -> 'a t * out list * - [ `Create of 'd t -> 'd -> ('d t * out list * Vmm_core.Name.t * Vmm_core.vm, [> Rresult.R.msg ]) result + [ `Create of 'd t -> 'd -> ('d t * out list * Vmm_core.Name.t * Vmm_core.Vm.t, [> Rresult.R.msg ]) result | `End ]) ] -val setup_stats : 'a t -> Vmm_core.Name.t -> Vmm_core.vm -> 'a t * out +val setup_stats : 'a t -> Vmm_core.Name.t -> Vmm_core.Vm.t -> 'a t * out