diff --git a/app/vmm_cli.ml b/app/vmm_cli.ml index 1d828db..bee529e 100644 --- a/app/vmm_cli.ml +++ b/app/vmm_cli.ml @@ -17,18 +17,18 @@ 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 requested_memory argv block_device network compression = +let create_vm force image cpuid memory argv block_device network_interfaces compression = let open Rresult.R.Infix in Bos.OS.File.read (Fpath.v image) >>| fun image -> - let vmimage = match compression with + let image = match compression with | 0 -> `Hvt_amd64, Cstruct.of_string image | level -> let img = Vmm_compress.compress ~level image in `Hvt_amd64_compressed, Cstruct.of_string img and argv = match argv with [] -> None | xs -> Some xs 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 config = Unikernel.{ cpuid ; memory ; block_device ; network_interfaces ; argv ; image } in + if force then `Unikernel_force_create config else `Unikernel_create config let policy vms memory cpus block bridges = let bridges = String.Set.of_list bridges diff --git a/app/vmmc_bistro.ml b/app/vmmc_bistro.ml index 9030280..3080398 100644 --- a/app/vmmc_bistro.ml +++ b/app/vmmc_bistro.ml @@ -63,9 +63,6 @@ let handle (host, port) cert key ca id (cmd : Vmm_commands.t) = let jump endp cert key ca name cmd = `Ok (Lwt_main.run (handle endp cert key ca name cmd)) -let info_ _ endp cert key ca name = - jump endp cert key ca name (`Vm_cmd `Vm_info) - let info_policy _ endp cert key ca name = jump endp cert key ca name (`Policy_cmd `Policy_info) @@ -76,12 +73,15 @@ let add_policy _ endp cert key ca name vms memory cpus block bridges = let p = Vmm_cli.policy vms memory cpus block bridges in jump endp cert key ca name (`Policy_cmd (`Policy_add p)) -let destroy _ endp cert key ca name = - jump endp cert key ca name (`Vm_cmd `Vm_destroy) +let info_ _ endp cert key ca name = + jump endp cert key ca name (`Unikernel_cmd `Unikernel_info) -let create _ endp cert key ca force name image cpuid requested_memory boot_params block_device network compression = - match Vmm_cli.create_vm force image cpuid requested_memory boot_params block_device network compression with - | Ok cmd -> jump endp cert key ca name (`Vm_cmd cmd) +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 = + match Vmm_cli.create_vm force image cpuid memory argv block network compression with + | Ok cmd -> jump endp cert key ca name (`Unikernel_cmd cmd) | Error (`Msg msg) -> `Error (false, msg) let console _ endp cert key ca name since = diff --git a/app/vmmc_local.ml b/app/vmmc_local.ml index d056d09..f9ab56d 100644 --- a/app/vmmc_local.ml +++ b/app/vmmc_local.ml @@ -43,8 +43,6 @@ let handle opt_socket name (cmd : Vmm_commands.t) = let jump opt_socket name cmd = `Ok (Lwt_main.run (handle opt_socket name cmd)) -let info_ _ opt_socket name = jump opt_socket name (`Vm_cmd `Vm_info) - let info_policy _ opt_socket name = jump opt_socket name (`Policy_cmd `Policy_info) @@ -55,12 +53,15 @@ let add_policy _ opt_socket name vms memory cpus block bridges = let p = Vmm_cli.policy vms memory cpus block bridges in jump opt_socket name (`Policy_cmd (`Policy_add p)) -let destroy _ opt_socket name = - jump opt_socket name (`Vm_cmd `Vm_destroy) +let info_ _ opt_socket name = + jump opt_socket name (`Unikernel_cmd `Unikernel_info) -let create _ opt_socket force name image cpuid requested_memory boot_params block_device network compression = - match Vmm_cli.create_vm force image cpuid requested_memory boot_params block_device network compression with - | Ok cmd -> jump opt_socket name (`Vm_cmd cmd) +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 = + match Vmm_cli.create_vm force image cpuid memory argv block network compression with + | Ok cmd -> jump opt_socket name (`Unikernel_cmd cmd) | Error (`Msg msg) -> `Error (false, msg) let console _ opt_socket name since = diff --git a/app/vmmd.ml b/app/vmmd.ml index cfb11fe..eadd7ce 100644 --- a/app/vmmd.ml +++ b/app/vmmd.ml @@ -2,6 +2,8 @@ open Vmm_cli +open Vmm_core + type stats = { start : Ptime.t ; vm_created : int ; @@ -32,7 +34,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.Vm.pid vm.Vmm_core.Vm.stdout >>= fun r -> + Vmm_lwt.wait_and_clear vm.Unikernel.pid vm.Unikernel.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' ; @@ -104,7 +106,7 @@ let handle out fd addr = Vmm_lwt.safe_close fd let init_sock sock = - let name = Vmm_core.socket_path sock in + let name = socket_path sock in let c = Lwt_unix.(socket PF_UNIX SOCK_STREAM 0) in Lwt_unix.set_close_on_exec c ; Lwt.catch (fun () -> @@ -128,13 +130,13 @@ let create_mbox sock = Lwt_mvar.take mvar >>= fun data -> Vmm_lwt.write_wire fd data >>= function | Ok () -> loop () - | Error `Exception -> invalid_arg ("exception while writing to " ^ Fmt.to_to_string Vmm_core.pp_socket sock) ; + | Error `Exception -> invalid_arg ("exception while writing to " ^ Fmt.to_to_string pp_socket sock) ; in Lwt.async loop ; Some (mvar, fd) let server_socket sock = - let name = Vmm_core.socket_path sock in + let name = socket_path sock in (Lwt_unix.file_exists name >>= function | true -> Lwt_unix.unlink name | false -> Lwt.return_unit) >>= fun () -> diff --git a/app/vmmp_request.ml b/app/vmmp_request.ml index 55c8b81..9943a09 100644 --- a/app/vmmp_request.ml +++ b/app/vmmp_request.ml @@ -25,8 +25,6 @@ let jump id cmd = | Ok () -> `Ok () | Error (`Msg m) -> `Error (false, m) -let info_ _ name = jump name (`Vm_cmd `Vm_info) - let info_policy _ name = jump name (`Policy_cmd `Policy_info) @@ -37,12 +35,14 @@ let add_policy _ name vms memory cpus block bridges = let p = Vmm_cli.policy vms memory cpus block bridges in jump name (`Policy_cmd (`Policy_add p)) -let destroy _ name = - jump name (`Vm_cmd `Vm_destroy) +let info_ _ name = jump name (`Unikernel_cmd `Unikernel_info) -let create _ force name image cpuid requested_memory boot_params block_device network compression = - match Vmm_cli.create_vm force image cpuid requested_memory boot_params block_device network compression with - | Ok cmd -> jump name (`Vm_cmd cmd) +let destroy _ name = + jump name (`Unikernel_cmd `Unikernel_destroy) + +let create _ force name image cpuid memory argv block network compression = + match Vmm_cli.create_vm force image cpuid memory argv block network compression with + | Ok cmd -> jump name (`Unikernel_cmd cmd) | Error (`Msg msg) -> `Error (false, msg) let console _ name since = diff --git a/src/vmm_asn.ml b/src/vmm_asn.ml index b819cce..dc20647 100644 --- a/src/vmm_asn.ml +++ b/src/vmm_asn.ml @@ -184,20 +184,20 @@ let log_event = | `C1 () -> `Startup | `C2 (name, ip, port) -> `Login (to_name name, ip, port) | `C3 (name, ip, port) -> `Logout (to_name name, ip, port) - | `C4 (name, pid, taps, block) -> `Vm_start (to_name name, pid, taps, block) + | `C4 (name, pid, taps, block) -> `Unikernel_start (to_name name, pid, taps, block) | `C5 (name, pid, status) -> let status' = match status with | `C1 n -> `Exit n | `C2 n -> `Signal n | `C3 n -> `Stop n in - `Vm_stop (to_name name, pid, status') + `Unikernel_stop (to_name name, pid, status') and g = function | `Startup -> `C1 () | `Login (name, ip, port) -> `C2 (of_name name, ip, port) | `Logout (name, ip, port) -> `C3 (of_name name, ip, port) - | `Vm_start (name, pid, taps, block) -> `C4 (of_name name, pid, taps, block) - | `Vm_stop (name, pid, status) -> + | `Unikernel_start (name, pid, taps, block) -> `C4 (of_name name, pid, taps, block) + | `Unikernel_stop (name, pid, status) -> let status' = match status with | `Exit n -> `C1 n | `Signal n -> `C2 n @@ -238,40 +238,41 @@ let log_cmd = Asn.S.map f g @@ Asn.S.(sequence (single (optional ~label:"since" utc_time))) -let vm_config = - let f (cpuid, requested_memory, block_device, network, vmimage, argv) = - let network = match network with None -> [] | Some xs -> xs in - Vm.{ cpuid ; requested_memory ; block_device ; network ; vmimage ; argv } +let unikernel_config = + let open Unikernel in + let f (cpuid, memory, block_device, network_interfaces, image, argv) = + let network_interfaces = match network_interfaces with None -> [] | Some xs -> xs in + { cpuid ; memory ; block_device ; network_interfaces ; image ; argv } and g vm = - 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) + let network_interfaces = match vm.network_interfaces with [] -> None | xs -> Some xs in + (vm.cpuid, vm.memory, vm.block_device, network_interfaces, vm.image, vm.argv) in Asn.S.map f g @@ Asn.S.(sequence6 (required ~label:"cpu" int) (required ~label:"memory" int) (optional ~label:"block" utf8_string) - (optional ~label:"bridges" (sequence_of utf8_string)) - (required ~label:"vmimage" image) + (optional ~label:"network_interfaces" (sequence_of utf8_string)) + (required ~label:"image" image) (optional ~label:"arguments" (sequence_of utf8_string))) -let vm_cmd = +let unikernel_cmd = let f = function - | `C1 () -> `Vm_info - | `C2 vm -> `Vm_create vm - | `C3 vm -> `Vm_force_create vm - | `C4 () -> `Vm_destroy + | `C1 () -> `Unikernel_info + | `C2 vm -> `Unikernel_create vm + | `C3 vm -> `Unikernel_force_create vm + | `C4 () -> `Unikernel_destroy and g = function - | `Vm_info -> `C1 () - | `Vm_create vm -> `C2 vm - | `Vm_force_create vm -> `C3 vm - | `Vm_destroy -> `C4 () + | `Unikernel_info -> `C1 () + | `Unikernel_create vm -> `C2 vm + | `Unikernel_force_create vm -> `C3 vm + | `Unikernel_destroy -> `C4 () in Asn.S.map f g @@ Asn.S.(choice4 (explicit 0 null) - (explicit 1 vm_config) - (explicit 2 vm_config) + (explicit 1 unikernel_config) + (explicit 2 unikernel_config) (explicit 3 null)) let policy_cmd = @@ -320,14 +321,14 @@ let wire_command = | `C1 console -> `Console_cmd console | `C2 stats -> `Stats_cmd stats | `C3 log -> `Log_cmd log - | `C4 vm -> `Vm_cmd vm + | `C4 vm -> `Unikernel_cmd vm | `C5 policy -> `Policy_cmd policy | `C6 block -> `Block_cmd block and g = function | `Console_cmd c -> `C1 c | `Stats_cmd c -> `C2 c | `Log_cmd c -> `C3 c - | `Vm_cmd c -> `C4 c + | `Unikernel_cmd c -> `C4 c | `Policy_cmd c -> `C5 c | `Block_cmd c -> `C6 c in @@ -336,7 +337,7 @@ let wire_command = (explicit 0 console_cmd) (explicit 1 stats_cmd) (explicit 2 log_cmd) - (explicit 3 vm_cmd) + (explicit 3 unikernel_cmd) (explicit 4 policy_cmd) (explicit 5 block_cmd)) @@ -381,14 +382,14 @@ let success = | `C1 () -> `Empty | `C2 str -> `String str | `C3 policies -> `Policies (List.map (fun (name, p) -> to_name name, p) policies) - | `C4 vms -> `Vms (List.map (fun (name, vm) -> to_name name, vm) vms) - | `C5 blocks -> `Blocks (List.map (fun (name, s, a) -> to_name name, s, a) blocks) + | `C4 vms -> `Unikernels (List.map (fun (name, vm) -> to_name name, vm) vms) + | `C5 blocks -> `Block_devices (List.map (fun (name, s, a) -> to_name name, s, a) blocks) and g = function | `Empty -> `C1 () | `String s -> `C2 s | `Policies ps -> `C3 (List.map (fun (name, p) -> of_name name, p) ps) - | `Vms vms -> `C4 (List.map (fun (name, v) -> of_name name, v) vms) - | `Blocks blocks -> `C5 (List.map (fun (name, s, a) -> of_name name, s, a) blocks) + | `Unikernels vms -> `C4 (List.map (fun (name, v) -> of_name name, v) vms) + | `Block_devices blocks -> `C5 (List.map (fun (name, s, a) -> of_name name, s, a) blocks) in Asn.S.map f g @@ Asn.S.(choice5 @@ -401,7 +402,7 @@ let success = (explicit 3 (sequence_of (sequence2 (required ~label:"name" (sequence_of utf8_string)) - (required ~label:"vm_config" vm_config)))) + (required ~label:"config" unikernel_config)))) (explicit 4 (sequence_of (sequence3 (required ~label:"name" (sequence_of utf8_string)) diff --git a/src/vmm_commands.ml b/src/vmm_commands.ml index 643db14..1a53e75 100644 --- a/src/vmm_commands.ml +++ b/src/vmm_commands.ml @@ -46,18 +46,18 @@ let pp_log_cmd ppf = function Fmt.pf ppf "log subscribe since %a" Fmt.(option ~none:(unit "epoch") (Ptime.pp_rfc3339 ())) ts -type vm_cmd = [ - | `Vm_info - | `Vm_create of Vm.config - | `Vm_force_create of Vm.config - | `Vm_destroy +type unikernel_cmd = [ + | `Unikernel_info + | `Unikernel_create of Unikernel.config + | `Unikernel_force_create of Unikernel.config + | `Unikernel_destroy ] -let pp_vm_cmd ppf = function - | `Vm_info -> Fmt.string ppf "vm info" - | `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" +let pp_unikernel_cmd ppf = function + | `Unikernel_info -> Fmt.string ppf "unikernel info" + | `Unikernel_create config -> Fmt.pf ppf "unikernel create %a" Unikernel.pp_config config + | `Unikernel_force_create config -> Fmt.pf ppf "vm force create %a" Unikernel.pp_config config + | `Unikernel_destroy -> Fmt.string ppf "unikernel destroy" type policy_cmd = [ | `Policy_info @@ -85,7 +85,7 @@ type t = [ | `Console_cmd of console_cmd | `Stats_cmd of stats_cmd | `Log_cmd of log_cmd - | `Vm_cmd of vm_cmd + | `Unikernel_cmd of unikernel_cmd | `Policy_cmd of policy_cmd | `Block_cmd of block_cmd ] @@ -94,7 +94,7 @@ let pp ppf = function | `Console_cmd c -> pp_console_cmd ppf c | `Stats_cmd s -> pp_stats_cmd ppf s | `Log_cmd l -> pp_log_cmd ppf l - | `Vm_cmd v -> pp_vm_cmd ppf v + | `Unikernel_cmd v -> pp_unikernel_cmd ppf v | `Policy_cmd p -> pp_policy_cmd ppf p | `Block_cmd b -> pp_block_cmd ppf b @@ -120,8 +120,8 @@ type success = [ | `Empty | `String of string | `Policies of (Name.t * Policy.t) list - | `Vms of (Name.t * Vm.config) list - | `Blocks of (Name.t * int * bool) list + | `Unikernels of (Name.t * Unikernel.config) list + | `Block_devices of (Name.t * int * bool) list ] let pp_block ppf (id, size, active) = @@ -131,8 +131,8 @@ 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 Vm.pp_config)) ppf vms - | `Blocks blocks -> Fmt.(list ~sep:(unit "@.") pp_block) ppf blocks + | `Unikernels vms -> Fmt.(list ~sep:(unit "@.") (pair ~sep:(unit ": ") Name.pp Unikernel.pp_config)) ppf vms + | `Block_devices blocks -> Fmt.(list ~sep:(unit "@.") pp_block) ppf blocks type wire = header * [ | `Command of t @@ -149,7 +149,7 @@ let pp_wire ppf (header, data) = | `Data d -> pp_data ppf d let endpoint = function - | `Vm_cmd _ -> `Vmmd, `End + | `Unikernel_cmd _ -> `Vmmd, `End | `Policy_cmd _ -> `Vmmd, `End | `Block_cmd _ -> `Vmmd, `End | `Stats_cmd _ -> `Stats, `Read diff --git a/src/vmm_commands.mli b/src/vmm_commands.mli index 4d47075..8d655f8 100644 --- a/src/vmm_commands.mli +++ b/src/vmm_commands.mli @@ -26,11 +26,11 @@ type log_cmd = [ | `Log_subscribe of Ptime.t option ] -type vm_cmd = [ - | `Vm_info - | `Vm_create of Vm.config - | `Vm_force_create of Vm.config - | `Vm_destroy +type unikernel_cmd = [ + | `Unikernel_info + | `Unikernel_create of Unikernel.config + | `Unikernel_force_create of Unikernel.config + | `Unikernel_destroy ] type policy_cmd = [ @@ -49,7 +49,7 @@ type t = [ | `Console_cmd of console_cmd | `Stats_cmd of stats_cmd | `Log_cmd of log_cmd - | `Vm_cmd of vm_cmd + | `Unikernel_cmd of unikernel_cmd | `Policy_cmd of policy_cmd | `Block_cmd of block_cmd ] @@ -74,8 +74,8 @@ type success = [ | `Empty | `String of string | `Policies of (Name.t * Policy.t) list - | `Vms of (Name.t * Vm.config) list - | `Blocks of (Name.t * int * bool) list + | `Unikernels of (Name.t * Unikernel.config) list + | `Block_devices of (Name.t * int * bool) list ] type wire = header * [ diff --git a/src/vmm_core.ml b/src/vmm_core.ml index dbba94c..71d0000 100644 --- a/src/vmm_core.ml +++ b/src/vmm_core.ml @@ -146,33 +146,33 @@ module Policy = struct (String.Set.pp ~sep:Fmt.(unit ", ") Fmt.string) res.bridges end -module Vm = struct - type vmtype = [ `Hvt_amd64 | `Hvt_arm64 | `Hvt_amd64_compressed ] +module Unikernel = struct + type typ = [ `Hvt_amd64 | `Hvt_arm64 | `Hvt_amd64_compressed ] - let pp_vmtype ppf = function + let pp_typ 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" type config = { cpuid : int ; - requested_memory : int ; + memory : int ; block_device : string option ; - network : string list ; - vmimage : vmtype * Cstruct.t ; + network_interfaces : string list ; + image : typ * Cstruct.t ; argv : string list option ; } let pp_image ppf (typ, blob) = let l = Cstruct.len blob in - Fmt.pf ppf "%a: %d bytes" pp_vmtype typ l + 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 device %a@ bridge %a, image %a, argv %a" - vm.cpuid vm.requested_memory + vm.cpuid vm.memory Fmt.(option ~none:(unit "no") string) vm.block_device - Fmt.(list ~sep:(unit ", ") string) vm.network - pp_image vm.vmimage + Fmt.(list ~sep:(unit ", ") string) vm.network_interfaces + pp_image vm.image Fmt.(option ~none:(unit "no") (list ~sep:(unit " ") string)) vm.argv type t = { @@ -264,26 +264,26 @@ module Log = struct | `Login of Name.t * Ipaddr.V4.t * int | `Logout of Name.t * Ipaddr.V4.t * int | `Startup - | `Vm_start of Name.t * int * string list * string option - | `Vm_stop of Name.t * int * process_exit + | `Unikernel_start of Name.t * int * string list * string option + | `Unikernel_stop of Name.t * int * process_exit ] let name = function | `Startup -> [] | `Login (name, _, _) -> name | `Logout (name, _, _) -> name - | `Vm_start (name, _, _ ,_) -> name - | `Vm_stop (name, _, _) -> name + | `Unikernel_start (name, _, _ ,_) -> name + | `Unikernel_stop (name, _, _) -> name let pp_log_event ppf = function | `Startup -> Fmt.(pf ppf "startup") | `Login (name, ip, port) -> Fmt.pf ppf "%a login %a:%d" Name.pp name Ipaddr.V4.pp_hum ip port | `Logout (name, ip, port) -> Fmt.pf ppf "%a logout %a:%d" Name.pp name Ipaddr.V4.pp_hum ip port - | `Vm_start (name, pid, taps, block) -> + | `Unikernel_start (name, pid, taps, block) -> Fmt.pf ppf "%a started %d (tap %a, block %a)" Name.pp name pid Fmt.(list ~sep:(unit "; ") string) taps Fmt.(option ~none:(unit "no") string) block - | `Vm_stop (name, pid, code) -> + | `Unikernel_stop (name, pid, code) -> Fmt.pf ppf "%a stopped %d with %a" Name.pp name pid pp_process_exit code type t = Ptime.t * log_event diff --git a/src/vmm_core.mli b/src/vmm_core.mli index 9c0086b..e494363 100644 --- a/src/vmm_core.mli +++ b/src/vmm_core.mli @@ -53,20 +53,20 @@ module Policy : sig val pp : t Fmt.t end -module Vm : sig - type vmtype = [ `Hvt_amd64 | `Hvt_amd64_compressed | `Hvt_arm64 ] - val pp_vmtype : vmtype Fmt.t +module Unikernel : sig + type typ = [ `Hvt_amd64 | `Hvt_amd64_compressed | `Hvt_arm64 ] + val pp_typ : typ Fmt.t type config = { cpuid : int; - requested_memory : int; + memory : int; block_device : string option; - network : string list; - vmimage : vmtype * Cstruct.t; + network_interfaces : string list; + image : typ * Cstruct.t; argv : string list option; } - val pp_image : (vmtype * Cstruct.t) Fmt.t + val pp_image : (typ * Cstruct.t) Fmt.t val pp_config : config Fmt.t @@ -140,8 +140,8 @@ module Log : sig | `Login of Name.t * Ipaddr.V4.t * int | `Logout of Name.t * Ipaddr.V4.t * int | `Startup - | `Vm_start of Name.t * int * string list * string option - | `Vm_stop of Name.t * int * process_exit ] + | `Unikernel_start of Name.t * int * string list * string option + | `Unikernel_stop of Name.t * int * process_exit ] val name : log_event -> Name.t diff --git a/src/vmm_resources.ml b/src/vmm_resources.ml index 46b6f32..1099128 100644 --- a/src/vmm_resources.ml +++ b/src/vmm_resources.ml @@ -11,7 +11,7 @@ let flipped_set_mem set s = String.Set.mem s set type t = { policies : Policy.t Vmm_trie.t ; block_devices : (int * bool) Vmm_trie.t ; - unikernels : Vm.t Vmm_trie.t ; + unikernels : Unikernel.t Vmm_trie.t ; } let pp ppf t = @@ -23,7 +23,7 @@ let pp ppf t = Fmt.pf ppf "block device %a: %dMB (used %B)@." Name.pp id size used) () ; Vmm_trie.fold Name.root t.unikernels (fun id vm () -> - Fmt.pf ppf "vm %a: %a@." Name.pp id Vm.pp_config vm.Vm.config) () + Fmt.pf ppf "vm %a: %a@." Name.pp id Unikernel.pp_config vm.Unikernel.config) () let empty = { policies = Vmm_trie.empty ; @@ -40,7 +40,7 @@ let block_usage t name = let vm_usage t name = Vmm_trie.fold name t.unikernels - (fun _ vm (vms, memory) -> (succ vms, memory + vm.Vm.config.Vm.requested_memory)) + (fun _ vm (vms, memory) -> (succ vms, memory + vm.Unikernel.config.Unikernel.memory)) (0, 0) let find_vm t name = Vmm_trie.find name t.unikernels @@ -59,7 +59,7 @@ let set_block_usage t name active = Ok (fst (Vmm_trie.insert name (size, active) t)) let maybe_use_block t name vm active = - match vm.Vm.config.Vm.block_device with + match vm.Unikernel.config.Unikernel.block_device with | None -> Ok t | Some block -> let block_name = Name.block_name name block in @@ -87,14 +87,14 @@ let remove_block t name = match find_block t name with let block_devices = Vmm_trie.remove name t.block_devices in Ok { t with block_devices } -let check_policy (p : Policy.t) (running_vms, used_memory) (vm : Vm.config) = +let check_policy (p : Policy.t) (running_vms, used_memory) (vm : Unikernel.config) = if succ running_vms > p.Policy.vms then Error (`Msg "maximum amount of unikernels reached") - else if vm.Vm.requested_memory > p.Policy.memory - used_memory then + else if vm.Unikernel.memory > p.Policy.memory - used_memory then Error (`Msg "maximum allowed memory reached") - else if not (IS.mem vm.Vm.cpuid p.Policy.cpuids) then + else if not (IS.mem vm.Unikernel.cpuid p.Policy.cpuids) then Error (`Msg "CPUid is not allowed by policy") - else if not (List.for_all (flipped_set_mem p.Policy.bridges) vm.Vm.network) then + else if not (List.for_all (flipped_set_mem p.Policy.bridges) vm.Unikernel.network_interfaces) then Error (`Msg "network not allowed by policy") else Ok () @@ -106,7 +106,7 @@ let check_vm t name vm = | Some p -> let used = vm_usage t dom in check_policy p used vm - and block_ok = match vm.Vm.block_device with + and block_ok = match vm.Unikernel.block_device with | None -> Ok () | Some block -> let block_name = Name.block_name name block in @@ -126,7 +126,7 @@ let check_vm t name vm = vm_ok let insert_vm t name vm = - check_vm t name vm.Vm.config >>= fun () -> + check_vm t name vm.Unikernel.config >>= fun () -> match Vmm_trie.insert name vm t.unikernels with | unikernels, None -> maybe_use_block t.block_devices name vm true >>| fun block_devices -> @@ -209,8 +209,9 @@ let check_vms t name p = let bridges, cpuids = Vmm_trie.fold name t.unikernels (fun _ vm (bridges, cpuids) -> - let config = vm.Vm.config in - (String.Set.(union (of_list config.Vm.network) bridges), IS.add config.Vm.cpuid cpuids)) + let config = vm.Unikernel.config in + (String.Set.(union (of_list config.Unikernel.network_interfaces) bridges), + IS.add config.Unikernel.cpuid cpuids)) (String.Set.empty, IS.empty) in let policy_block = match p.Policy.block with None -> 0 | Some x -> x in diff --git a/src/vmm_resources.mli b/src/vmm_resources.mli index 1230eef..dea627f 100644 --- a/src/vmm_resources.mli +++ b/src/vmm_resources.mli @@ -17,7 +17,7 @@ open Vmm_core type t = private { policies : Policy.t Vmm_trie.t ; block_devices : (int * bool) Vmm_trie.t ; - unikernels : Vm.t Vmm_trie.t ; + unikernels : Unikernel.t Vmm_trie.t ; } @@ -25,7 +25,7 @@ type t = private { val empty : t (** [find_vm t id] is either [Some vm] or [None]. *) -val find_vm : t -> Name.t -> Vm.t option +val find_vm : t -> Name.t -> Unikernel.t option (** [find_policy t Name.t] is either [Some policy] or [None]. *) val find_policy : t -> Name.t -> Policy.t option @@ -35,11 +35,11 @@ val find_block : t -> Name.t -> (int * bool) option (** [check_vm t Name.t vm] checks whether [vm] under [Name.t] in [t] would be allowed under the current policies. *) -val check_vm : t -> Name.t -> Vm.config -> (unit, [> `Msg of string ]) result +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 an error. *) -val insert_vm : t -> Name.t -> Vm.t -> (t, [> `Msg of string]) result +val insert_vm : t -> Name.t -> Unikernel.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. *) diff --git a/src/vmm_tls.ml b/src/vmm_tls.ml index 06c56d6..67efd04 100644 --- a/src/vmm_tls.ml +++ b/src/vmm_tls.ml @@ -102,6 +102,6 @@ let handle _addr version chain = | `Console_cmd (`Console_subscribe _) | `Stats_cmd `Stats_subscribe | `Log_cmd (`Log_subscribe _) - | `Vm_cmd _ + | `Unikernel_cmd _ | `Policy_cmd `Policy_info -> Ok (name, policies, wire) | _ -> Error (`Msg "unexpected command") diff --git a/src/vmm_unix.ml b/src/vmm_unix.ml index be91da2..ae6f888 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.Vm.vmimage with + (match vm.Unikernel.image 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.Vm.network >>= fun taps -> + (Ok []) vm.Unikernel.network_interfaces >>= 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.Vm.taps + List.fold_left (fun r n -> r >>= fun () -> destroy_tap n) (Ok ()) vm.Unikernel.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.Vm.argv with None -> [] | Some xs -> xs - and mem = "--mem=" ^ string_of_int vm.Vm.requested_memory + and argv = match vm.Unikernel.argv with None -> [] | Some xs -> xs + and mem = "--mem=" ^ string_of_int vm.Unikernel.memory in - cpuset vm.Vm.cpuid >>= fun cpuset -> + cpuset vm.Unikernel.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.{ vm with vmimage = (fst vm.vmimage, Cstruct.create 0) } in - Ok Vm.{ config ; cmd ; pid ; taps ; stdout } + let config = Unikernel.{ vm with image = (fst vm.Unikernel.image, Cstruct.create 0) } in + Ok Unikernel.{ 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.Vm.pid 15 (* 15 is SIGTERM *) +let destroy vm = Unix.kill vm.Unikernel.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 7b7ecc4..f6606e3 100644 --- a/src/vmm_unix.mli +++ b/src/vmm_unix.mli @@ -4,13 +4,14 @@ open Rresult open Vmm_core -val prepare : Name.t -> Vm.config -> (string list, [> R.msg ]) result +val prepare : Name.t -> Unikernel.config -> (string list, [> R.msg ]) result -val shutdown : Name.t -> Vm.t -> (unit, [> R.msg ]) result +val exec : Name.t -> Unikernel.config -> string list -> Name.t option -> + (Unikernel.t, [> R.msg ]) result -val exec : Name.t -> Vm.config -> string list -> Name.t option -> (Vm.t, [> R.msg ]) result +val shutdown : Name.t -> Unikernel.t -> (unit, [> R.msg ]) result -val destroy : Vm.t -> unit +val destroy : Unikernel.t -> unit val close_no_err : Unix.file_descr -> unit diff --git a/src/vmm_vmmd.ml b/src/vmm_vmmd.ml index c6f881e..6d56fa1 100644 --- a/src/vmm_vmmd.ml +++ b/src/vmm_vmmd.ml @@ -34,7 +34,7 @@ let init wire_version = List.fold_left (fun r (id, size) -> match Vmm_resources.insert_block r id size with | Error (`Msg msg) -> - Logs.err (fun m -> m "couldn't insert block device %a (%dM): %s" Name.pp id size msg) ; + Logs.err (fun m -> m "couldn't insert block device %a (%dMB): %s" Name.pp id size msg) ; r | Ok r -> r) t.resources devs @@ -73,7 +73,7 @@ let handle_create t reply name vm_config = [ `Cons cons_out ], `Create (fun t task -> (* actually execute the vm *) - let block_device = match vm_config.Vm.block_device with + let block_device = match vm_config.Unikernel.block_device with | None -> None | Some block -> Some (Name.block_name name block) in @@ -82,11 +82,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.Vm.pid, vm.Vm.taps, None)) in + let t, out = log t name (`Unikernel_start (name, vm.Unikernel.pid, vm.Unikernel.taps, None)) in Ok (t, [ reply (`String "created VM") ; out ], name, vm))) let setup_stats t name vm = - let stat_out = `Stats_add (vm.Vm.pid, vm.Vm.taps) in + let stat_out = `Stats_add (vm.Unikernel.pid, vm.Unikernel.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)) @@ -94,17 +94,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 Vm.pp vm)) ; + | 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 Vm.pp vm) ; + Logs.warn (fun m -> m "%s while removing vm %a from resources" e Unikernel.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.Vm.pid, r)) + let t, logout = log t name (`Unikernel_stop (name, vm.Unikernel.pid, r)) in (t, [ `Stat (header, `Command (`Stats_cmd `Stats_remove)) ; logout ]) @@ -138,23 +138,23 @@ let handle_policy_cmd t reply id = function | _ -> Ok (t, [ reply (`Policies policies) ], `End) -let handle_vm_cmd t reply id msg_to_err = function - | `Vm_info -> +let handle_unikernel_cmd t reply id msg_to_err = function + | `Unikernel_info -> Logs.debug (fun m -> m "info %a" Name.pp id) ; let vms = Vmm_trie.fold id t.resources.Vmm_resources.unikernels - (fun id vm vms -> (id, vm.Vm.config) :: vms) + (fun id vm vms -> (id, vm.Unikernel.config) :: vms) [] in begin match vms with | [] -> Logs.debug (fun m -> m "info: couldn't find %a" Name.pp id) ; - Error (`Msg "info: not found") + Error (`Msg "info: no unikernel found") | _ -> - Ok (t, [ reply (`Vms vms) ], `End) + Ok (t, [ reply (`Unikernels vms) ], `End) end - | `Vm_create vm_config -> handle_create t reply id vm_config - | `Vm_force_create vm_config -> + | `Unikernel_create vm_config -> handle_create t reply id vm_config + | `Unikernel_force_create vm_config -> begin let resources = match Vmm_resources.remove_vm t.resources id with @@ -175,13 +175,13 @@ let handle_vm_cmd t reply id msg_to_err = function Ok (t, [], `Wait_and_create (task, fun t -> msg_to_err @@ handle_create t reply id vm_config)) end - | `Vm_destroy -> + | `Unikernel_destroy -> match Vmm_resources.find_vm t.resources id with | Some vm -> Vmm_unix.destroy vm ; let id_str = Name.to_string id in let out, next = - let s = reply (`String "destroyed vm") in + let s = reply (`String "destroyed unikernel") in match String.Map.find_opt id_str t.tasks with | None -> [ s ], `End | Some t -> [], `Wait (t, s) @@ -224,7 +224,7 @@ let handle_block_cmd t reply id = function Logs.debug (fun m -> m "block: couldn't find %a" Name.pp id) ; Error (`Msg "block: not found") | _ -> - Ok (t, [ reply (`Blocks blocks) ], `End) + Ok (t, [ reply (`Block_devices blocks) ], `End) let handle_command t (header, payload) = let msg_to_err = function @@ -238,7 +238,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 (`Vm_cmd vc) -> handle_vm_cmd t reply id msg_to_err vc + | `Command (`Unikernel_cmd vc) -> handle_unikernel_cmd t reply id msg_to_err 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)) ; diff --git a/src/vmm_vmmd.mli b/src/vmm_vmmd.mli index de6fab1..d12fc7b 100644 --- a/src/vmm_vmmd.mli +++ b/src/vmm_vmmd.mli @@ -1,5 +1,7 @@ (* (c) 2017, 2018 Hannes Mehnert, all rights reserved *) +open Vmm_core + type 'a t val init : Vmm_commands.version -> 'a t @@ -12,17 +14,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.t -> +val handle_shutdown : 'a t -> Name.t -> Unikernel.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.t, [> `Msg of string ]) result + [ `Create of 'c t -> 'c -> ('c t * out list * Name.t * Unikernel.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.t, [> Rresult.R.msg ]) result + [ `Create of 'd t -> 'd -> ('d t * out list * Name.t * Unikernel.t, [> Rresult.R.msg ]) result | `End ]) ] -val setup_stats : 'a t -> Vmm_core.Name.t -> Vmm_core.Vm.t -> 'a t * out +val setup_stats : 'a t -> Name.t -> Unikernel.t -> 'a t * out