diff --git a/app/vmm_cli.ml b/app/vmm_cli.ml index b4e6aff..03f2d2c 100644 --- a/app/vmm_cli.ml +++ b/app/vmm_cli.ml @@ -120,9 +120,21 @@ let vm_name = let doc = "Name virtual machine." in Arg.(required & pos 0 (some vm_c) None & info [] ~doc ~docv:"VM") +let block_name = + let doc = "Name of block device." in + Arg.(required & pos 0 (some vm_c) None & info [] ~doc ~docv:"BLOCK") + let block_size = + let doc = "Block size in MB." in + Arg.(required & pos 1 (some int) None & info [] ~doc ~docv:"SIZE") + +let opt_block_name = + let doc = "Name of block device." in + Arg.(value & opt vm_c [] & info [ "name" ] ~doc) + +let opt_block_size = let doc = "Block storage to allow in MB" in - Arg.(value & opt (some int) None & info [ "block" ] ~doc) + Arg.(value & opt (some int) None & info [ "size" ] ~doc) let mem = let doc = "Memory to allow in MB" in diff --git a/app/vmm_stats_stubs.c b/app/vmm_stats_stubs.c index b6d8b5b..2773bda 100644 --- a/app/vmm_stats_stubs.c +++ b/app/vmm_stats_stubs.c @@ -40,11 +40,11 @@ CAMLprim value vmmanage_sysctl_rusage (value pid_r) { if (error < 0) uerror("sysctl", Nothing); + ru = p.ki_rusage; if (ru.ru_utime.tv_usec < 0 || ru.ru_utime.tv_usec > 999999999 || ru.ru_stime.tv_usec < 0 || ru.ru_stime.tv_usec > 999999999) uerror("sysctl", Nothing); - ru = p.ki_rusage; utime = caml_alloc(2, 0); Store_field (utime, 0, Val64(ru.ru_utime.tv_sec)); Store_field (utime, 1, Val_int(ru.ru_utime.tv_usec)); diff --git a/app/vmmc_bistro.ml b/app/vmmc_bistro.ml index 063e818..0f0440f 100644 --- a/app/vmmc_bistro.ml +++ b/app/vmmc_bistro.ml @@ -93,6 +93,15 @@ let stats _ endp cert key ca name = let event_log _ endp cert key ca name since = jump endp cert key ca name (`Log_cmd (`Log_subscribe since)) +let block_info _ endp cert key ca block_name = + jump endp cert key ca block_name (`Block_cmd `Block_info) + +let block_create _ endp cert key ca block_name block_size = + jump endp cert key ca block_name (`Block_cmd (`Block_add block_size)) + +let block_destroy _ endp cert key ca block_name = + jump endp cert key ca block_name (`Block_cmd `Block_remove) + let help _ _ man_format cmds = function | None -> `Help (`Pager, None) | Some t when List.mem t cmds -> `Help (man_format, Some t) @@ -159,7 +168,7 @@ let add_policy_cmd = [`S "DESCRIPTION"; `P "Adds a policy."] in - Term.(ret (const add_policy $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ vm_name $ vms $ mem $ cpus $ block_size $ bridge)), + Term.(ret (const add_policy $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ vm_name $ vms $ mem $ cpus $ opt_block_size $ bridge)), Term.info "add_policy" ~doc ~man let create_cmd = @@ -198,6 +207,33 @@ let log_cmd = Term.(ret (const event_log $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ opt_vm_name $ since)), Term.info "log" ~doc ~man +let block_info_cmd = + let doc = "Information about block devices" in + let man = + [`S "DESCRIPTION"; + `P "Block device information."] + in + Term.(ret (const block_info $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ opt_block_name)), + Term.info "block" ~doc ~man + +let block_create_cmd = + let doc = "Create a block device" in + let man = + [`S "DESCRIPTION"; + `P "Creation of a block device."] + in + Term.(ret (const block_create $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ block_name $ block_size)), + Term.info "create_block" ~doc ~man + +let block_destroy_cmd = + let doc = "Destroys a block device" in + let man = + [`S "DESCRIPTION"; + `P "Destroys a block device."] + in + Term.(ret (const block_destroy $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ block_name)), + Term.info "destroy_block" ~doc ~man + let help_cmd = let topic = let doc = "The topic to get help on. `topics' lists the topics." in @@ -220,7 +256,11 @@ let default_cmd = Term.(ret (const help $ setup_log $ destination $ Term.man_format $ Term.choice_names $ Term.pure None)), Term.info "vmmc_bistro" ~version:"%%VERSION_NUM%%" ~doc ~man -let cmds = [ help_cmd ; info_cmd ; policy_cmd ; remove_policy_cmd ; add_policy_cmd ; destroy_cmd ; create_cmd ; console_cmd ; stats_cmd ; log_cmd ] +let cmds = [ help_cmd ; info_cmd ; + policy_cmd ; remove_policy_cmd ; add_policy_cmd ; + destroy_cmd ; create_cmd ; + block_info_cmd ; block_create_cmd ; block_destroy_cmd ; + console_cmd ; stats_cmd ; log_cmd ] let () = match Term.eval_choice default_cmd cmds diff --git a/app/vmmc_local.ml b/app/vmmc_local.ml index 817f775..79c664b 100644 --- a/app/vmmc_local.ml +++ b/app/vmmc_local.ml @@ -72,6 +72,15 @@ let stats _ opt_socket name = let event_log _ opt_socket name since = jump opt_socket name (`Log_cmd (`Log_subscribe since)) +let block_info _ opt_socket block_name = + jump opt_socket block_name (`Block_cmd `Block_info) + +let block_create _ opt_socket block_name block_size = + jump opt_socket block_name (`Block_cmd (`Block_add block_size)) + +let block_destroy _ opt_socket block_name = + jump opt_socket block_name (`Block_cmd `Block_remove) + let help _ _ man_format cmds = function | None -> `Help (`Pager, None) | Some t when List.mem t cmds -> `Help (man_format, Some t) @@ -126,7 +135,7 @@ let add_policy_cmd = [`S "DESCRIPTION"; `P "Adds a policy."] in - Term.(ret (const add_policy $ setup_log $ socket $ vm_name $ vms $ mem $ cpus $ block_size $ bridge)), + Term.(ret (const add_policy $ setup_log $ socket $ vm_name $ vms $ mem $ cpus $ opt_block_size $ bridge)), Term.info "add_policy" ~doc ~man let create_cmd = @@ -165,6 +174,33 @@ let log_cmd = Term.(ret (const event_log $ setup_log $ socket $ opt_vm_name $ since)), Term.info "log" ~doc ~man +let block_info_cmd = + let doc = "Information about block devices" in + let man = + [`S "DESCRIPTION"; + `P "Block device information."] + in + Term.(ret (const block_info $ setup_log $ socket $ opt_block_name)), + Term.info "block" ~doc ~man + +let block_create_cmd = + let doc = "Create a block device" in + let man = + [`S "DESCRIPTION"; + `P "Creation of a block device."] + in + Term.(ret (const block_create $ setup_log $ socket $ block_name $ block_size)), + Term.info "create_block" ~doc ~man + +let block_destroy_cmd = + let doc = "Destroys a block device" in + let man = + [`S "DESCRIPTION"; + `P "Destroys a block device."] + in + Term.(ret (const block_destroy $ setup_log $ socket $ block_name)), + Term.info "destroy_block" ~doc ~man + let help_cmd = let topic = let doc = "The topic to get help on. `topics' lists the topics." in @@ -187,7 +223,11 @@ let default_cmd = Term.(ret (const help $ setup_log $ socket $ Term.man_format $ Term.choice_names $ Term.pure None)), Term.info "vmmc_local" ~version:"%%VERSION_NUM%%" ~doc ~man -let cmds = [ help_cmd ; info_cmd ; policy_cmd ; remove_policy_cmd ; add_policy_cmd ; destroy_cmd ; create_cmd ; console_cmd ; stats_cmd ; log_cmd ] +let cmds = [ help_cmd ; info_cmd ; + policy_cmd ; remove_policy_cmd ; add_policy_cmd ; + destroy_cmd ; create_cmd ; + block_info_cmd ; block_create_cmd ; block_destroy_cmd ; + console_cmd ; stats_cmd ; log_cmd ] let () = match Term.eval_choice default_cmd cmds diff --git a/app/vmmp_request.ml b/app/vmmp_request.ml index a339438..b69c389 100644 --- a/app/vmmp_request.ml +++ b/app/vmmp_request.ml @@ -54,6 +54,15 @@ let stats _ name = let event_log _ name since = jump name (`Log_cmd (`Log_subscribe since)) +let block_info _ block_name = + jump block_name (`Block_cmd `Block_info) + +let block_create _ block_name block_size = + jump block_name (`Block_cmd (`Block_add block_size)) + +let block_destroy _ block_name = + jump block_name (`Block_cmd `Block_remove) + let help _ man_format cmds = function | None -> `Help (`Pager, None) | Some t when List.mem t cmds -> `Help (man_format, Some t) @@ -104,7 +113,7 @@ let add_policy_cmd = [`S "DESCRIPTION"; `P "Adds a policy."] in - Term.(ret (const add_policy $ setup_log $ vm_name $ vms $ mem $ cpus $ block_size $ bridge)), + Term.(ret (const add_policy $ setup_log $ vm_name $ vms $ mem $ cpus $ opt_block_size $ bridge)), Term.info "add_policy" ~doc ~man let create_cmd = @@ -143,6 +152,33 @@ let log_cmd = Term.(ret (const event_log $ setup_log $ opt_vm_name $ since)), Term.info "log" ~doc ~man +let block_info_cmd = + let doc = "Information about block devices" in + let man = + [`S "DESCRIPTION"; + `P "Block device information."] + in + Term.(ret (const block_info $ setup_log $ opt_block_name)), + Term.info "block" ~doc ~man + +let block_create_cmd = + let doc = "Create a block device" in + let man = + [`S "DESCRIPTION"; + `P "Creation of a block device."] + in + Term.(ret (const block_create $ setup_log $ block_name $ block_size)), + Term.info "create_block" ~doc ~man + +let block_destroy_cmd = + let doc = "Destroys a block device" in + let man = + [`S "DESCRIPTION"; + `P "Destroys a block device."] + in + Term.(ret (const block_destroy $ setup_log $ block_name)), + Term.info "destroy_block" ~doc ~man + let help_cmd = let topic = let doc = "The topic to get help on. `topics' lists the topics." in @@ -165,7 +201,11 @@ let default_cmd = Term.(ret (const help $ setup_log $ Term.man_format $ Term.choice_names $ Term.pure None)), Term.info "vmmc_local" ~version:"%%VERSION_NUM%%" ~doc ~man -let cmds = [ help_cmd ; info_cmd ; policy_cmd ; remove_policy_cmd ; add_policy_cmd ; destroy_cmd ; create_cmd ; console_cmd ; stats_cmd ; log_cmd ] +let cmds = [ help_cmd ; info_cmd ; + policy_cmd ; remove_policy_cmd ; add_policy_cmd ; + destroy_cmd ; create_cmd ; + block_info_cmd ; block_create_cmd ; block_destroy_cmd ; + console_cmd ; stats_cmd ; log_cmd ] let () = match Term.eval_choice default_cmd cmds diff --git a/src/vmm_asn.ml b/src/vmm_asn.ml index 8a6e81f..6bb8341 100644 --- a/src/vmm_asn.ml +++ b/src/vmm_asn.ml @@ -305,6 +305,22 @@ let policy_cmd = (explicit 1 policy) (explicit 2 null)) +let block_cmd = + let f = function + | `C1 () -> `Block_info + | `C2 size -> `Block_add size + | `C3 () -> `Block_remove + and g = function + | `Block_info -> `C1 () + | `Block_add size -> `C2 size + | `Block_remove -> `C3 () + in + Asn.S.map f g @@ + Asn.S.(choice3 + (explicit 0 null) + (explicit 1 int) + (explicit 2 null)) + let version = let f data = match data with | 2 -> `AV2 @@ -321,20 +337,23 @@ let wire_command = | `C3 log -> `Log_cmd log | `C4 vm -> `Vm_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 | `Policy_cmd c -> `C5 c + | `Block_cmd c -> `C6 c in Asn.S.map f g @@ - Asn.S.(choice5 + Asn.S.(choice6 (explicit 0 console_cmd) (explicit 1 stats_cmd) (explicit 2 log_cmd) (explicit 3 vm_cmd) - (explicit 4 policy_cmd)) + (explicit 4 policy_cmd) + (explicit 5 block_cmd)) let data = let f = function @@ -378,14 +397,16 @@ let success = | `C2 str -> `String str | `C3 policies -> `Policies policies | `C4 vms -> `Vms vms + | `C5 blocks -> `Blocks blocks and g = function | `Empty -> `C1 () | `String s -> `C2 s | `Policies ps -> `C3 ps | `Vms vms -> `C4 vms + | `Blocks blocks -> `C5 blocks in Asn.S.map f g @@ - Asn.S.(choice4 + Asn.S.(choice5 (explicit 0 null) (explicit 1 utf8_string) (explicit 2 (sequence_of @@ -395,7 +416,12 @@ let success = (explicit 3 (sequence_of (sequence2 (required ~label:"name" (sequence_of utf8_string)) - (required ~label:"vm_config" vm_config))))) + (required ~label:"vm_config" vm_config)))) + (explicit 4 (sequence_of + (sequence3 + (required ~label:"name" (sequence_of utf8_string)) + (required ~label:"size" int) + (required ~label:"active" bool))))) let payload = let f = function diff --git a/src/vmm_commands.ml b/src/vmm_commands.ml index d760e51..0cc4fc2 100644 --- a/src/vmm_commands.ml +++ b/src/vmm_commands.ml @@ -55,8 +55,8 @@ type vm_cmd = [ let pp_vm_cmd ppf = function | `Vm_info -> Fmt.string ppf "vm info" - | `Vm_create vm_config -> Fmt.pf ppf "create %a" pp_vm_config vm_config - | `Vm_force_create vm_config -> Fmt.pf ppf "force create %a" pp_vm_config vm_config + | `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_destroy -> Fmt.string ppf "vm destroy" type policy_cmd = [ @@ -67,15 +67,27 @@ type policy_cmd = [ let pp_policy_cmd ppf = function | `Policy_info -> Fmt.string ppf "policy info" - | `Policy_add policy -> Fmt.pf ppf "add policy: %a" pp_policy policy + | `Policy_add policy -> Fmt.pf ppf "policy add %a" pp_policy policy | `Policy_remove -> Fmt.string ppf "policy remove" +type block_cmd = [ + | `Block_info + | `Block_add of int + | `Block_remove +] + +let pp_block_cmd ppf = function + | `Block_info -> Fmt.string ppf "block info" + | `Block_add size -> Fmt.pf ppf "block add %d" size + | `Block_remove -> Fmt.string ppf "block remove" + type t = [ | `Console_cmd of console_cmd | `Stats_cmd of stats_cmd | `Log_cmd of log_cmd | `Vm_cmd of vm_cmd | `Policy_cmd of policy_cmd + | `Block_cmd of block_cmd ] let pp ppf = function @@ -84,6 +96,7 @@ let pp ppf = function | `Log_cmd l -> pp_log_cmd ppf l | `Vm_cmd v -> pp_vm_cmd ppf v | `Policy_cmd p -> pp_policy_cmd ppf p + | `Block_cmd b -> pp_block_cmd ppf b type data = [ | `Console_data of Ptime.t * string @@ -103,13 +116,23 @@ type header = { id : id ; } -type success = [ `Empty | `String of string | `Policies of (id * policy) list | `Vms of (id * vm_config) list ] +type success = [ + | `Empty + | `String of string + | `Policies of (id * policy) list + | `Vms of (id * vm_config) list + | `Blocks of (id * int * bool) list +] + +let pp_block ppf (id, size, active) = + Fmt.pf ppf "block %a size %d MB active %B" pp_id id size active 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 ": ") pp_id pp_policy)) ppf ps | `Vms vms -> Fmt.(list ~sep:(unit "@.") (pair ~sep:(unit ": ") pp_id pp_vm_config)) ppf vms + | `Blocks blocks -> Fmt.(list ~sep:(unit "@.") pp_block) ppf blocks type wire = header * [ | `Command of t @@ -128,6 +151,7 @@ let pp_wire ppf (header, data) = let endpoint = function | `Vm_cmd _ -> `Vmmd, `End | `Policy_cmd _ -> `Vmmd, `End + | `Block_cmd _ -> `Vmmd, `End | `Stats_cmd _ -> `Stats, `Read | `Console_cmd _ -> `Console, `Read | `Log_cmd _ -> `Log, `Read diff --git a/src/vmm_commands.mli b/src/vmm_commands.mli index d9c773b..461565d 100644 --- a/src/vmm_commands.mli +++ b/src/vmm_commands.mli @@ -39,12 +39,20 @@ type policy_cmd = [ | `Policy_remove ] +type block_cmd = [ + | `Block_info + | `Block_add of int + | `Block_remove +] + type t = [ | `Console_cmd of console_cmd | `Stats_cmd of stats_cmd | `Log_cmd of log_cmd | `Vm_cmd of vm_cmd - | `Policy_cmd of policy_cmd ] + | `Policy_cmd of policy_cmd + | `Block_cmd of block_cmd +] val pp : t Fmt.t @@ -67,6 +75,7 @@ type success = [ | `String of string | `Policies of (id * policy) list | `Vms of (id * vm_config) list + | `Blocks of (id * int * bool) list ] type wire = header * [ diff --git a/src/vmm_core.ml b/src/vmm_core.ml index 66cd193..d2319d5 100644 --- a/src/vmm_core.ml +++ b/src/vmm_core.ml @@ -1,4 +1,4 @@ -(* (c) 2017 Hannes Mehnert, all rights reserved *) +(* (c) 2017, 2018 Hannes Mehnert, all rights reserved *) open Astring @@ -6,6 +6,7 @@ open Rresult.R.Infix let tmpdir = Fpath.(v "/var" / "run" / "albatross") let dbdir = Fpath.(v "/var" / "db" / "albatross") +let blockdir = Fpath.(dbdir / "block") type service = [ `Console | `Log | `Stats | `Vmmd ] @@ -60,6 +61,8 @@ let domain id = match List.rev id with | _::prefix -> List.rev prefix | [] -> [] +let block_name vm_name dev = List.rev (dev :: List.rev (domain vm_name)) + let pp_id ppf ids = Fmt.(pf ppf "(%d)%a" (List.length ids) (list ~sep:(unit ".") string) ids) @@ -194,8 +197,9 @@ type vm = { } let pp_vm ppf vm = - Fmt.pf ppf "pid %d@ taps %a cmdline %a" + 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 translate_tap vm tap = diff --git a/src/vmm_core.mli b/src/vmm_core.mli index 0db3d44..d4815c7 100644 --- a/src/vmm_core.mli +++ b/src/vmm_core.mli @@ -2,6 +2,7 @@ val tmpdir : Fpath.t val dbdir : Fpath.t +val blockdir : Fpath.t type service = [ `Console | `Log | `Stats | `Vmmd ] @@ -20,12 +21,13 @@ module IM : sig end type id = string list -val string_of_id : string list -> string -val id_of_string : string -> string list -val drop_super : super:string list -> sub:string list -> string list option -val is_sub_id : super:string list -> sub:string list -> bool -val domain : 'a list -> 'a list +val string_of_id : id -> string +val id_of_string : string -> id +val drop_super : super:id -> sub:id -> id option +val is_sub_id : super:id -> sub:id -> bool +val domain : id -> id val pp_id : id Fmt.t +val block_name : id -> string -> id type bridge = [ `External of string * Ipaddr.V4.t * Ipaddr.V4.t * Ipaddr.V4.t * int diff --git a/src/vmm_resources.ml b/src/vmm_resources.ml index a83a306..bd9eeb0 100644 --- a/src/vmm_resources.ml +++ b/src/vmm_resources.ml @@ -5,9 +5,10 @@ open Vmm_core type res_entry = { running_vms : int ; used_memory : int ; + used_blockspace : int ; } -let empty_res = { running_vms = 0 ; used_memory = 0 } +let empty_res = { running_vms = 0 ; used_memory = 0 ; used_blockspace = 0 } let check_resource (policy : policy) (vm : vm_config) (res : res_entry) = succ res.running_vms <= policy.vms && @@ -15,41 +16,47 @@ let check_resource (policy : policy) (vm : vm_config) (res : res_entry) = vm_matches_res policy vm let check_resource_policy (policy : policy) (res : res_entry) = - res.running_vms <= policy.vms && res.used_memory <= policy.memory - -let add (vm : vm) (res : res_entry) = - { running_vms = succ res.running_vms ; - used_memory = vm.config.requested_memory + res.used_memory } + res.running_vms <= policy.vms && res.used_memory <= policy.memory && + match policy.block with + | None -> res.used_blockspace = 0 + | Some mb -> res.used_blockspace <= mb type entry = | Vm of vm + | Block of int * bool | Policy of policy +let pp_entry id ppf = function + | Vm vm -> Fmt.pf ppf "vm %a: %a@." pp_id id pp_vm_config vm.config + | Policy p -> Fmt.pf ppf "policy %a: %a@." pp_id id pp_policy p + | Block (size, used) -> Fmt.pf ppf "block device %a: %dMB (used %B)@." pp_id id size used + type t = entry Vmm_trie.t let pp ppf t = Vmm_trie.fold [] t - (fun id ele () -> match ele with - | Vm vm -> Fmt.pf ppf "vm %a: %a@." pp_id id pp_vm_config vm.config - | Policy p -> Fmt.pf ppf "policy %a: %a@." pp_id id pp_policy p) - () + (fun id ele () -> pp_entry id ppf ele) () let empty = Vmm_trie.empty -let fold t name f g acc = +let fold t name f g h acc = Vmm_trie.fold name t (fun prefix entry acc -> match entry with | Vm vm -> f prefix vm acc - | Policy p -> g prefix p acc) acc + | Policy p -> g prefix p acc + | Block (size, used) -> h prefix size used acc) acc (* we should hide this type and confirm the following invariant: - in case Vm, there are no siblings *) let resource_usage t name = - Vmm_trie.fold name t (fun _ entry acc -> + Vmm_trie.fold name t (fun _ entry res -> match entry with - | Policy _ -> acc - | Vm vm -> add vm acc) + | Policy _ -> res + | 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 }) empty_res let find_vm t name = match Vmm_trie.find name t with @@ -60,42 +67,61 @@ let find_policy t name = match Vmm_trie.find name t with | Some (Policy p) -> Some p | _ -> None +let find_block t name = match Vmm_trie.find name t with + | Some (Block (size, active)) -> Some (size, active) + | _ -> None + +let set_block_usage active t name vm = + match vm.config.block_device with + | None -> Ok t + | Some block -> + let block_name = block_name name block in + match find_block t block_name with + | None -> Error (`Msg "unknown block device") + | Some (size, curr) -> + if curr = active then + Error (`Msg "failed because the requested block usage was already set") + else + Ok (fst (Vmm_trie.insert block_name (Block (size, active)) t)) + let remove_vm t name = match find_vm t name with | None -> Error (`Msg "unknown vm") - | Some _ -> Ok (Vmm_trie.remove name t) + | Some vm -> set_block_usage false (Vmm_trie.remove name t) name vm let remove_policy t name = match find_policy t name with | None -> Error (`Msg "unknown policy") | Some _ -> Ok (Vmm_trie.remove name t) +let remove_block t name = match find_block t name with + | None -> Error (`Msg "unknown block") + | Some _ -> Ok (Vmm_trie.remove name t) + 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 -> Ok true - | Some (Vm vm) -> - Logs.err (fun m -> m "id %a, expected policy, got vm %a" pp_id dom pp_vm vm) ; - Rresult.R.error_msgf "expected policy, found vm for %a" pp_id dom | Some (Policy p) -> Ok (check_resource p vm res) + | Some x -> + Logs.err (fun m -> m "id %a, expected policy, got %a" pp_id dom (pp_entry dom) x) ; + Rresult.R.error_msgf "expected policy for %a" pp_id dom let insert_vm t name vm = let open Rresult.R.Infix in check_vm_policy t name vm.config >>= function - | true -> - begin match Vmm_trie.insert name (Vm vm) t with - | t', None -> Ok t' - | _, Some _ -> Error (`Msg "vm already exists") - end | 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 + | _, Some _ -> Error (`Msg "vm already exists") let check_policy_above t name p = let above = Vmm_trie.collect name t in List.for_all (fun (id, node) -> match node with - | Vm vm -> - Logs.err (fun m -> m "found vm %a, expecting a policy at %a" - pp_vm vm pp_id id) ; - false - | Policy p' -> is_sub ~super:p' ~sub:p) + | Policy p' -> is_sub ~super:p' ~sub:p + | x -> + Logs.err (fun m -> m "expected policy, found %a" + (pp_entry id) x) ; + false) above let check_policy_below t name p = @@ -123,3 +149,23 @@ let insert_policy t name p = | false, _, _ -> Error (`Msg "policy violates other policies above") | _, None, _ -> Error (`Msg "policy violates other policies below") | _, _, false -> Error (`Msg "more resources used than policy would allow") + +let check_block_policy t name size = + match find_block t name with + | Some _ -> Error (`Msg "block device with same name already exists") + | None -> + let dom = domain name in + let res = resource_usage t dom in + let res' = { res with used_blockspace = res.used_blockspace + size } in + match Vmm_trie.find dom t with + | None -> Ok true + | Some (Policy p) -> Ok (check_resource_policy p res') + | Some x -> + Logs.err (fun m -> m "id %a, expected policy, got %a" pp_id dom (pp_entry dom) x) ; + Rresult.R.error_msgf "expected policy for %a" pp_id dom + +let insert_block t name size = + let open Rresult.R.Infix in + check_block_policy t name size >>= function + | false -> Error (`Msg "resource policy mismatch") + | true -> Ok (fst (Vmm_trie.insert name (Block (size, false)) t)) diff --git a/src/vmm_resources.mli b/src/vmm_resources.mli index e38a12b..bbcf25d 100644 --- a/src/vmm_resources.mli +++ b/src/vmm_resources.mli @@ -23,11 +23,14 @@ val find_vm : t -> Vmm_core.id -> Vmm_core.vm option (** [find_policy t id] is either [Some policy] or [None]. *) val find_policy : t -> Vmm_core.id -> Vmm_core.policy option -(** [check_vm_policy t vm] checks whether [vm] under [id] in [t] would be +(** [find_block t id] is either [Some (size, active)] or [None]. *) +val find_block : t -> Vmm_core.id -> (int * bool) option + +(** [check_vm_policy t id vm] checks whether [vm] under [id] in [t] would be allowed under the current policies. *) val check_vm_policy : t -> Vmm_core.id -> Vmm_core.vm_config -> (bool, [> `Msg of string ]) result -(** [insert_vm t vm] inserts [vm] under [id] in [t], and returns the new [t] or +(** [insert_vm t id vm] inserts [vm] under [id] in [t], and returns the new [t] or an error. *) val insert_vm : t -> Vmm_core.id -> Vmm_core.vm -> (t, [> `Msg of string]) result @@ -35,16 +38,28 @@ val insert_vm : t -> Vmm_core.id -> Vmm_core.vm -> (t, [> `Msg of string]) resul the new [t] or an error. *) val insert_policy : t -> Vmm_core.id -> Vmm_core.policy -> (t, [> `Msg of string]) result +(** [check_block_policy t id size] checks whether [size] under [id] in [t] would be + allowed under the current policies. *) +val check_block_policy : t -> Vmm_core.id -> int -> (bool, [> `Msg of string ]) result + +(** [insert_block t id size] inserts [size] under [id] in [t], and returns the new [t] or + an error. *) +val insert_block : t -> Vmm_core.id -> int -> (t, [> `Msg of string]) result + (** [remove_vm t id] removes vm [id] from [t]. *) val remove_vm : t -> Vmm_core.id -> (t, [> `Msg of string ]) result (** [remove_policy t id] removes policy [id] from [t]. *) val remove_policy : t -> Vmm_core.id -> (t, [> `Msg of string ]) result -(** [fold t id f g acc] folds [f] and [g] below [id] over [t]. *) +(** [remove_block t id] removes block [id] from [t]. *) +val remove_block : t -> Vmm_core.id -> (t, [> `Msg of string ]) result + +(** [fold t id f_vm f_policy f_block acc] folds [f_vm], [f_policy] and [f_block] below [id] over [t]. *) val fold : t -> Vmm_core.id -> (Vmm_core.id -> Vmm_core.vm -> 'a -> 'a) -> - (Vmm_core.id -> Vmm_core.policy -> 'a -> 'a) -> 'a -> 'a + (Vmm_core.id -> Vmm_core.policy -> 'a -> 'a) -> + (Vmm_core.id -> int -> bool -> 'a -> 'a) -> 'a -> 'a (** [pp] is a pretty printer for [t]. *) val pp : t Fmt.t diff --git a/src/vmm_unix.ml b/src/vmm_unix.ml index 17fa587..d356e2f 100644 --- a/src/vmm_unix.ml +++ b/src/vmm_unix.ml @@ -145,17 +145,24 @@ let cpuset cpu = Ok ([ "taskset" ; "-c" ; cpustring ]) | x -> Error (`Msg ("unsupported operating system " ^ x)) -let exec name vm taps = - let net = List.map (fun t -> "--net=" ^ t) taps in - let argv = match vm.argv with None -> [] | Some xs -> xs in - (match taps with - | [] -> Ok Fpath.(dbdir / "solo5-hvt.none") - | [_] -> Ok Fpath.(dbdir / "solo5-hvt.net") - | _ -> Error (`Msg "cannot handle multiple network interfaces")) >>= fun bin -> +let block_device_name name = Fpath.(blockdir / string_of_id name) + +let exec name vm taps block = + (match taps, block with + | [], None -> Ok "none" + | [_], None -> Ok "net" + | [], Some _ -> Ok "block" + | [_], Some _ -> Ok "block-net" + | _, _ -> 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_device_name dev) ] + and argv = match vm.argv with None -> [] | Some xs -> xs + and mem = "--mem=" ^ string_of_int vm.requested_memory + in cpuset vm.cpuid >>= fun cpuset -> - let mem = "--mem=" ^ string_of_int vm.requested_memory in let cmd = - Bos.Cmd.(of_list cpuset % p bin % mem %% of_list net % + Bos.Cmd.(of_list cpuset % p Fpath.(dbdir / "solo5-hvt" + bin) % mem %% + of_list net %% of_list block % "--" % p (image_file name) %% of_list argv) in let line = Bos.Cmd.to_list cmd in @@ -178,3 +185,47 @@ let exec name vm taps = 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 bytes_of_mb size = + let res = size lsl 20 in + if res > size then + Ok res + else + Error (`Msg "overflow while computing bytes") + +let create_block name size = + let block_name = block_device_name name in + Bos.OS.File.exists block_name >>= function + | true -> Error (`Msg "file already exists") + | false -> + bytes_of_mb size >>= fun size' -> + Bos.OS.File.truncate block_name size' + +let destroy_block name = + Bos.OS.File.delete (block_device_name name) + +let mb_of_bytes size = + if size = 0 || size land 0xFFFFF <> 0 then + Error (`Msg "size is either 0 or not MB aligned") + else + Ok (size lsr 20) + +let find_block_devices () = + Bos.OS.Dir.contents ~rel:true blockdir >>= fun files -> + List.fold_left (fun acc file -> + acc >>= fun acc -> + let path = Fpath.append blockdir file in + Bos.OS.File.exists path >>= function + | false -> + Logs.warn (fun m -> m "file %a doesn't exist, but was listed" Fpath.pp path) ; + Ok acc + | true -> + Bos.OS.Path.stat path >>= fun stats -> + match mb_of_bytes stats.Unix.st_size with + | Error (`Msg msg) -> + Logs.warn (fun m -> m "file %a error: %s" Fpath.pp path msg) ; + Ok acc + | Ok size -> + let id = id_of_string (Fpath.to_string file) in + Ok ((id, size) :: acc)) + (Ok []) files diff --git a/src/vmm_unix.mli b/src/vmm_unix.mli index bc99008..6596007 100644 --- a/src/vmm_unix.mli +++ b/src/vmm_unix.mli @@ -8,8 +8,14 @@ val prepare : id -> vm_config -> (string list, [> R.msg ]) result val shutdown : id -> vm -> (unit, [> R.msg ]) result -val exec : id -> vm_config -> string list -> (vm, [> R.msg ]) result +val exec : id -> vm_config -> string list -> string list option -> (vm, [> R.msg ]) result val destroy : vm -> unit val close_no_err : Unix.file_descr -> unit + +val create_block : id -> int -> (unit, [> R.msg ]) result + +val destroy_block : id -> (unit, [> R.msg ]) result + +val find_block_devices : unit -> ((id * int) list, [> R.msg ]) result diff --git a/src/vmm_vmmd.ml b/src/vmm_vmmd.ml index 7e1abe8..b7bb7c9 100644 --- a/src/vmm_vmmd.ml +++ b/src/vmm_vmmd.ml @@ -16,14 +16,30 @@ type 'a t = { tasks : 'a String.Map.t ; } -let init wire_version = { - wire_version ; - console_counter = 1L ; - stats_counter = 1L ; - log_counter = 1L ; - resources = Vmm_resources.empty ; - tasks = String.Map.empty ; -} +let init wire_version = + let t = { + wire_version ; + console_counter = 1L ; + stats_counter = 1L ; + log_counter = 1L ; + resources = Vmm_resources.empty ; + tasks = String.Map.empty ; + } in + match Vmm_unix.find_block_devices () with + | Error (`Msg msg) -> + Logs.warn (fun m -> m "couldn't find block devices %s" msg) ; + t + | Ok devs -> + let resources = + 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" pp_id id size msg) ; + r + | Ok r -> r) + t.resources devs + in + { t with resources } type service_out = [ | `Stat of Vmm_commands.wire @@ -40,15 +56,23 @@ let log t id event = Logs.debug (fun m -> m "log %a" Log.pp data) ; ({ t with log_counter }, `Log (header, `Data (`Log_data data))) -let handle_create t hdr vm_config = - let name = hdr.Vmm_commands.id in +let handle_create t reply name vm_config = (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") ; (Vmm_resources.check_vm_policy t.resources name vm_config >>= function - | false -> Error (`Msg "resource policies don't allow this") + | false -> Error (`Msg "resource policies don't allow creation of this VM") | true -> Ok ()) >>= fun () -> + (match vm_config.block_device with + | None -> Ok None + | Some dev -> + let block_device_name = block_name name dev in + Logs.debug (fun m -> m "looking for block device %a" pp_id block_device_name) ; + match Vmm_resources.find_block t.resources block_device_name with + | Some (_, false) -> Ok (Some block_device_name) + | Some (_, true) -> Error (`Msg "block device is busy") + | None -> Error (`Msg "cannot find block device") ) >>= fun block_device -> (* prepare VM: save VM image to disk, create fifo, ... *) Vmm_unix.prepare name vm_config >>= fun taps -> Logs.debug (fun m -> m "prepared vm with taps %a" Fmt.(list ~sep:(unit ",@ ") string) taps) ; @@ -60,14 +84,13 @@ let handle_create t hdr vm_config = [ `Cons cons_out ], `Create (fun t task -> (* actually execute the vm *) - Vmm_unix.exec name vm_config taps >>= fun vm -> + 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 tasks = String.Map.add (string_of_id 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 data = `Success (`String "created VM") in - Ok (t, [ `Data (hdr, data) ; out ], name, vm))) + 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 @@ -92,108 +115,147 @@ let handle_shutdown t name vm r = in (t, [ `Stat (header, `Command (`Stats_cmd `Stats_remove)) ; logout ]) +let handle_policy_cmd t reply id = function + | `Policy_remove -> + Logs.debug (fun m -> m "remove policy %a" pp_id id) ; + Vmm_resources.remove_policy t.resources id >>= fun resources -> + Ok ({ t with resources }, [ reply (`String "removed policy") ], `End) + | `Policy_add policy -> + Logs.debug (fun m -> m "insert policy %a" pp_id id) ; + let same_policy = match Vmm_resources.find_policy t.resources id with + | None -> false + | Some p' -> eq_policy policy p' + in + if same_policy then + Ok (t, [ reply (`String "no modification of policy") ], `Loop) + else + Vmm_resources.insert_policy t.resources id policy >>= fun resources -> + Ok ({ t with resources }, [ reply (`String "added policy") ], `Loop) + | `Policy_info -> + Logs.debug (fun m -> m "policy %a" pp_id id) ; + let policies = + Vmm_resources.fold t.resources id + (fun _ _ policies -> policies) + (fun prefix policy policies-> (prefix, policy) :: policies) + (fun _ _ _ policies -> policies) + [] + in + match policies with + | [] -> + Logs.debug (fun m -> m "policies: couldn't find %a" pp_id id) ; + Error (`Msg "policy: not found") + | _ -> + Ok (t, [ reply (`Policies policies) ], `End) + +let handle_vm_cmd t reply id msg_to_err = function + | `Vm_info -> + Logs.debug (fun m -> m "info %a" pp_id id) ; + let vms = + Vmm_resources.fold t.resources id + (fun id vm vms -> (id, vm.config) :: vms) + (fun _ _ vms-> vms) + (fun _ _ _ vms -> vms) + [] + in + begin match vms with + | [] -> + Logs.debug (fun m -> m "info: couldn't find %a" pp_id id) ; + Error (`Msg "info: not found") + | _ -> + Ok (t, [ reply (`Vms vms) ], `End) + end + | `Vm_create vm_config -> handle_create t reply id vm_config + | `Vm_force_create vm_config -> + begin + let resources = + match Vmm_resources.remove_vm t.resources id with + | Error _ -> t.resources + | Ok r -> r + in + Vmm_resources.check_vm_policy resources id vm_config >>= function + | false -> Error (`Msg "wouldn't match policy") + | true -> match Vmm_resources.find_vm t.resources id with + | None -> handle_create t reply id vm_config + | Some vm -> + Vmm_unix.destroy vm ; + let id_str = string_of_id id in + match String.Map.find_opt id_str t.tasks with + | None -> handle_create t reply id vm_config + | Some task -> + let tasks = String.Map.remove id_str t.tasks in + let t = { t with tasks } in + Ok (t, [], `Wait_and_create + (task, fun t -> msg_to_err @@ handle_create t reply id vm_config)) + end + | `Vm_destroy -> + match Vmm_resources.find_vm t.resources id with + | Some vm -> + Vmm_unix.destroy vm ; + let id_str = string_of_id id in + let out, next = + let s = reply (`String "destroyed vm") in + match String.Map.find_opt id_str t.tasks with + | None -> [ s ], `End + | Some t -> [], `Wait (t, s) + in + let tasks = String.Map.remove id_str t.tasks in + Ok ({ t with tasks }, out, next) + | None -> Error (`Msg "destroy: not found") + +let handle_block_cmd t reply id = function + | `Block_remove -> + Logs.debug (fun m -> m "removing block %a" pp_id id) ; + begin match Vmm_resources.find_block t.resources id with + | None -> Error (`Msg "remove block: not found") + | Some (_, true) -> Error (`Msg "remove block: is in use") + | Some (_, false) -> + Vmm_unix.destroy_block id >>= fun () -> + Vmm_resources.remove_block t.resources id >>= fun resources -> + Ok ({ t with resources }, [ reply (`String "removed block") ], `End) + end + | `Block_add size -> + begin + Logs.debug (fun m -> m "insert block %a: %dMB" pp_id id size) ; + match Vmm_resources.find_block t.resources id with + | Some _ -> Error (`Msg "block device with same name already exists") + | None -> + Vmm_resources.check_block_policy t.resources id size >>= function + | false -> Error (`Msg "adding block device would violate policy") + | true -> + Vmm_unix.create_block id size >>= fun () -> + Vmm_resources.insert_block t.resources id size >>= fun resources -> + Ok ({ t with resources }, [ reply (`String "added block device") ], `Loop) + end + | `Block_info -> + Logs.debug (fun m -> m "block %a" pp_id id) ; + let blocks = + Vmm_resources.fold t.resources id + (fun _ _ blocks -> blocks) + (fun _ _ blocks-> blocks) + (fun prefix size active blocks -> (prefix, size, active) :: blocks) + [] + in + match blocks with + | [] -> + Logs.debug (fun m -> m "block: couldn't find %a" pp_id id) ; + Error (`Msg "block: not found") + | _ -> + Ok (t, [ reply (`Blocks blocks) ], `End) + let handle_command t (header, payload) = let msg_to_err = function | Ok x -> x | Error (`Msg msg) -> Logs.err (fun m -> m "error while processing command: %s" msg) ; (t, [ `Data (header, `Failure msg) ], `End) + and reply x = `Data (header, `Success x) + and id = header.Vmm_commands.id in - let reply x = `Data (header, `Success x) in msg_to_err ( - let id = header.Vmm_commands.id in match payload with - | `Command (`Policy_cmd pc) -> - begin match pc with - | `Policy_remove -> - Logs.debug (fun m -> m "remove policy %a" pp_id header.Vmm_commands.id) ; - Vmm_resources.remove_policy t.resources id >>= fun resources -> - Ok ({ t with resources }, [ reply (`String "removed policy") ], `End) - | `Policy_add policy -> - Logs.debug (fun m -> m "insert policy %a" pp_id id) ; - let same_policy = match Vmm_resources.find_policy t.resources id with - | None -> false - | Some p' -> eq_policy policy p' - in - if same_policy then - Ok (t, [ reply (`String "no modification of policy") ], `Loop) - else - Vmm_resources.insert_policy t.resources id policy >>= fun resources -> - Ok ({ t with resources }, [ reply (`String "added policy") ], `Loop) - | `Policy_info -> - begin - Logs.debug (fun m -> m "policy %a" pp_id id) ; - let policies = - Vmm_resources.fold t.resources id - (fun _ _ policies -> policies) - (fun prefix policy policies-> (prefix, policy) :: policies) - [] - in - match policies with - | [] -> - Logs.debug (fun m -> m "policies: couldn't find %a" pp_id id) ; - Error (`Msg "policy: not found") - | _ -> - Ok (t, [ reply (`Policies policies) ], `End) - end - end - | `Command (`Vm_cmd vc) -> - begin match vc with - | `Vm_info -> - Logs.debug (fun m -> m "info %a" pp_id id) ; - let vms = - Vmm_resources.fold t.resources id - (fun id vm vms -> (id, vm.config) :: vms) - (fun _ _ vms-> vms) - [] - in - begin match vms with - | [] -> - Logs.debug (fun m -> m "info: couldn't find %a" pp_id id) ; - Error (`Msg "info: not found") - | _ -> - Ok (t, [ reply (`Vms vms) ], `End) - end - | `Vm_create vm_config -> - handle_create t header vm_config - | `Vm_force_create vm_config -> - begin - let resources = - match Vmm_resources.remove_vm t.resources id with - | Error _ -> t.resources - | Ok r -> r - in - Vmm_resources.check_vm_policy resources id vm_config >>= function - | false -> Error (`Msg "wouldn't match policy") - | true -> match Vmm_resources.find_vm t.resources id with - | None -> handle_create t header vm_config - | Some vm -> - Vmm_unix.destroy vm ; - let id_str = string_of_id id in - match String.Map.find_opt id_str t.tasks with - | None -> handle_create t header vm_config - | Some task -> - let tasks = String.Map.remove id_str t.tasks in - let t = { t with tasks } in - Ok (t, [], `Wait_and_create - (task, fun t -> msg_to_err @@ handle_create t header vm_config)) - end - | `Vm_destroy -> - begin match Vmm_resources.find_vm t.resources id with - | Some vm -> - Vmm_unix.destroy vm ; - let id_str = string_of_id id in - let out, next = - let s = reply (`String "destroyed vm") in - match String.Map.find_opt id_str t.tasks with - | None -> [ s ], `End - | Some t -> [], `Wait (t, s) - in - let tasks = String.Map.remove id_str t.tasks in - Ok ({ t with tasks }, out, next) - | None -> Error (`Msg "destroy: not found") - end - end + | `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 (`Block_cmd bc) -> handle_block_cmd t reply id bc | _ -> Logs.err (fun m -> m "ignoring %a" Vmm_commands.pp_wire (header, payload)) ; Error (`Msg "unknown command"))