From 182e2ae10cdaa76e5b9fc31f6a42c2e8f052b0ba Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Sat, 13 Oct 2018 01:05:21 +0200 Subject: [PATCH] policies: vmmc now has more subcommands - policy [-n name] returns all policies in name and below - add_policy [-n name] [--cpu cpuid] [--mem mem] [--bridge bridge] [--block size] adds a policy - remove [-n name] removes policy at name policy is just the same which is in vmm_req_delegation, and vmm_resources now check them: - you cannot insert a subpolicy violating the prefix - you cannot insert a policy which would forbid current resource usage - you cannot insert a policy with which any subpolicy would be invalid - you can adjust (increase/decrease) a policy if the above invariants are kept implement "force create" directly in vmmd: much nicer to - check resource constraints, - kill vm potentially, - and create a new vm, all as single transaction. --- app/vmmc.ml | 170 ++++++++++++++++++++++++++++++++++++------ app/vmmd.ml | 104 +++++++++++++++----------- src/vmm_asn.ml | 32 ++++++++ src/vmm_asn.mli | 9 ++- src/vmm_core.ml | 21 ++++-- src/vmm_engine.ml | 96 ++++++++++++++++++------ src/vmm_resources.ml | 166 +++++++++++++++++------------------------ src/vmm_resources.mli | 48 ++++-------- src/vmm_trie.ml | 18 +++++ src/vmm_trie.mli | 2 + src/vmm_wire.ml | 164 +++++++++++----------------------------- 11 files changed, 483 insertions(+), 347 deletions(-) diff --git a/app/vmmc.ml b/app/vmmc.ml index d7ad5fa..2452939 100644 --- a/app/vmmc.ml +++ b/app/vmmc.ml @@ -2,6 +2,8 @@ open Lwt.Infix +open Astring + open Vmm_core let my_version = `WV2 @@ -62,19 +64,74 @@ let info_ _ opt_socket name = ) ; `Ok () -let really_destroy opt_socket name = - connect (socket `Vmmd opt_socket) >>= fun fd -> - let cmd = Vmm_wire.Vm.destroy my_command my_version name in - (Vmm_lwt.write_wire fd cmd >>= function - | Ok () -> - (process fd >|= function - | Error () -> () - | Ok _ -> Logs.app (fun m -> m "destroyed VM")) - | Error `Exception -> Lwt.return_unit) >>= fun () -> - Vmm_lwt.safe_close fd +let policy _ opt_socket name = + Lwt_main.run ( + connect (socket `Vmmd opt_socket) >>= fun fd -> + let policy = Vmm_wire.Vm.policy my_command my_version name in + (Vmm_lwt.write_wire fd policy >>= function + | Ok () -> + (process fd >|= function + | Error () -> () + | Ok data -> + match Vmm_wire.Vm.decode_policies data with + | Ok (policies, _) -> + List.iter (fun (id, policy) -> + Logs.app (fun m -> m "policy %a: %a" pp_id id pp_policy policy)) + policies + | Error (`Msg msg) -> + Logs.err (fun m -> m "error %s while decoding policies" msg)) + | Error `Exception -> Lwt.return_unit) >>= fun () -> + Vmm_lwt.safe_close fd + ) ; + `Ok () + +let remove_policy _ opt_socket name = + Lwt_main.run ( + connect (socket `Vmmd opt_socket) >>= fun fd -> + let cmd = Vmm_wire.Vm.remove_policy my_command my_version name in + (Vmm_lwt.write_wire fd cmd >>= function + | Ok () -> + (process fd >|= function + | Error () -> () + | Ok _ -> Logs.app (fun m -> m "removed policy")) + | Error `Exception -> Lwt.return_unit) >>= fun () -> + Vmm_lwt.safe_close fd) ; + `Ok () + +let add_policy _ opt_socket name vms memory cpus block bridges = + Lwt_main.run ( + connect (socket `Vmmd opt_socket) >>= fun fd -> + let bridges = match bridges with + | xs -> + let add m v = + let n = match v with `Internal n -> n | `External (n, _, _, _, _) -> n in + String.Map.add n v m + in + List.fold_left add String.Map.empty xs + and cpuids = IS.of_list cpus + in + let policy = { vms ; cpuids ; memory ; block ; bridges } in + let cmd = Vmm_wire.Vm.insert_policy my_command my_version name policy in + (Vmm_lwt.write_wire fd cmd >>= function + | Ok () -> + (process fd >|= function + | Error () -> () + | Ok _ -> Logs.app (fun m -> m "added policy")) + | Error `Exception -> Lwt.return_unit) >>= fun () -> + Vmm_lwt.safe_close fd) ; + `Ok () let destroy _ opt_socket name = - Lwt_main.run (really_destroy opt_socket name) ; + Lwt_main.run ( + connect (socket `Vmmd opt_socket) >>= fun fd -> + let cmd = Vmm_wire.Vm.destroy my_command my_version name in + (Vmm_lwt.write_wire fd cmd >>= function + | Ok () -> + (process fd >|= function + | Error () -> () + | Ok _ -> Logs.app (fun m -> m "destroyed VM")) + | Error `Exception -> Lwt.return_unit) >>= fun () -> + Vmm_lwt.safe_close fd) ; `Ok () let create _ opt_socket force name image cpuid requested_memory boot_params block_device network = @@ -93,19 +150,19 @@ let create _ opt_socket force name image cpuid requested_memory boot_params bloc vmimage ; argv } in Lwt_main.run ( - (if force then - really_destroy opt_socket name - else - Lwt.return_unit) >>= fun () -> connect (socket `Vmmd opt_socket) >>= fun fd -> - let vm = Vmm_wire.Vm.create my_command my_version vm_config in + let vm = + if force then + Vmm_wire.Vm.force_create my_command my_version vm_config + else + Vmm_wire.Vm.create my_command my_version vm_config + in (Vmm_lwt.write_wire fd vm >>= function | Error `Exception -> Lwt.return_unit | Ok () -> process fd >|= function | Ok _ -> Logs.app (fun m -> m "successfully started VM") | Error () -> ()) >>= fun () -> - Vmm_lwt.safe_close fd - ) ; + Vmm_lwt.safe_close fd ) ; `Ok () let console _ opt_socket name = @@ -315,6 +372,15 @@ let opt_vmname = let doc = "Name virtual machine." in Arg.(value & opt vm_c [] & info [ "n" ; "name"] ~doc) +let remove_policy_cmd = + let doc = "removes a policy" in + let man = + [`S "DESCRIPTION"; + `P "Removes a policy."] + in + Term.(ret (const remove_policy $ setup_log $ socket $ opt_vmname)), + Term.info "remove" ~doc ~man + let info_cmd = let doc = "information about VMs" in let man = @@ -324,14 +390,72 @@ let info_cmd = Term.(ret (const info_ $ setup_log $ socket $ opt_vmname)), Term.info "info" ~doc ~man +let policy_cmd = + let doc = "active policies" in + let man = + [`S "DESCRIPTION"; + `P "Shows information about policies."] + in + Term.(ret (const policy $ setup_log $ socket $ opt_vmname)), + Term.info "policy" ~doc ~man + +let cpus = + let doc = "CPUids to allow" in + Arg.(value & opt_all int [] & info [ "cpu" ] ~doc) + +let vms = + let doc = "Number of VMs to allow" in + Arg.(required & pos 0 (some int) None & info [] ~doc) + +let block = + let doc = "Block storage to allow" in + Arg.(value & opt (some int) None & info [ "block" ] ~doc) + +let mem = + let doc = "Memory to allow" in + Arg.(value & opt int 512 & info [ "mem" ] ~doc) + +let b = + let parse s = + match String.cuts ~sep:"/" s with + | [ name ; fst ; lst ; gw ; nm ] -> + begin match Ipaddr.V4.(of_string fst, of_string lst, of_string gw) with + | Some fst, Some lst, Some gw -> + (try + let nm = int_of_string nm in + if nm > 0 && nm <= 32 then + let net = Ipaddr.V4.Prefix.make nm gw in + if Ipaddr.V4.Prefix.mem fst net && Ipaddr.V4.Prefix.mem lst net then + `Ok (`External (name, fst, lst, gw, nm)) + else + `Error "first or last IP are not in subnet" + else + `Error "netmask must be > 0 and <= 32" + with Failure _ -> `Error "couldn't parse netmask") + | _ -> `Error "couldn't parse IP address" + end + | [ name ] -> `Ok (`Internal name) + | _ -> `Error "couldn't parse bridge (either 'name' or 'name/fstIP/lstIP/gwIP/netmask')" + in + (parse, Vmm_core.pp_bridge) + +let bridge = + let doc = "Bridge to provision" in + Arg.(value & opt_all b [] & info [ "bridge" ] ~doc) + +let add_policy_cmd = + let doc = "Add a policy" in + let man = + [`S "DESCRIPTION"; + `P "Adds a policy."] + in + Term.(ret (const add_policy $ setup_log $ socket $ opt_vmname $ vms $ mem $ cpus $ block $ bridge)), + Term.info "add_policy" ~doc ~man + let cpu = let doc = "CPUid" in Arg.(value & opt int 0 & info [ "cpu" ] ~doc) -let mem = - let doc = "Memory to provision" in - Arg.(value & opt int 512 & info [ "mem" ] ~doc) - let args = let doc = "Boot arguments" in Arg.(value & opt_all string [] & info [ "arg" ] ~doc) @@ -402,7 +526,7 @@ let default_cmd = Term.(ret (const help $ setup_log $ socket $ Term.man_format $ Term.choice_names $ Term.pure None)), Term.info "vmmc" ~version:"%%VERSION_NUM%%" ~doc ~man -let cmds = [ help_cmd ; info_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 ; console_cmd ; stats_cmd ; log_cmd ] let () = match Term.eval_choice default_cmd cmds diff --git a/app/vmmd.ml b/app/vmmd.ml index 0416557..fe5380e 100644 --- a/app/vmmd.ml +++ b/app/vmmd.ml @@ -22,7 +22,53 @@ type out = [ | `Log of Cstruct.t ] -let handle state out c_fd fd addr = +let state = ref (Vmm_engine.init ()) + +let create c_fd process cont = + Vmm_lwt.read_wire c_fd >>= function + | Ok (hdr, data) -> + if Vmm_wire.is_fail hdr then begin + Logs.err (fun m -> m "console failed with %s" (Cstruct.to_string data)) ; + Lwt.return_unit + end else if Vmm_wire.is_reply hdr then begin + (* assert hdr.id = id! *) + let await, wakeme = Lwt.wait () in + begin match cont !state await with + | Error (`Msg msg) -> + Logs.err (fun m -> m "create continuation failed %s" msg) ; + Lwt.return_unit + | Ok (state'', out, vm) -> + state := state'' ; + s := { !s with vm_created = succ !s.vm_created } ; + Lwt.async (fun () -> + Vmm_lwt.wait_and_clear vm.Vmm_core.pid vm.Vmm_core.stdout >>= fun r -> + let state', out' = Vmm_engine.handle_shutdown !state vm r in + s := { !s with vm_destroyed = succ !s.vm_destroyed } ; + state := state' ; + process out' >|= fun () -> + Lwt.wakeup wakeme ()) ; + process out >>= fun () -> + begin match Vmm_engine.setup_stats !state vm with + | Ok (state', out) -> + state := state' ; + process out (* TODO: need to read from stats socket! *) + | Error (`Msg e) -> + Logs.warn (fun m -> m "(ignored) error %s while setting up statistics" e) ; + Lwt.return_unit + end + end + end else begin + Logs.err (fun m -> m "reading from console %lx, %a" hdr.Vmm_wire.tag Cstruct.hexdump_pp data) ; + Lwt.return_unit + end + | Error (`Msg msg) -> + Logs.err (fun m -> m "error %s while reading from console" msg) ; + Lwt.return_unit + | Error _ -> + Logs.err (fun m -> m "error while reading from console") ; + Lwt.return_unit + +let handle out c_fd fd addr = (* out is for `Log | `Stat | `Cons (including reconnect semantics) *) (* need to handle data out (+ die on write failure) *) Logs.debug (fun m -> m "connection from %a" Vmm_lwt.pp_sockaddr addr) ; @@ -58,50 +104,19 @@ let handle state out c_fd fd addr = match next with | `End -> Lwt.return_unit | `Wait (task, out) -> task >>= fun () -> process out + | `Wait_and_create (state', task, next) -> + state := state' ; + task >>= fun () -> + let state', data, n = next !state in + state := state' ; + process data >>= fun () -> + (match n with + | `End -> Lwt.return_unit + | `Create cont -> create c_fd process cont) | `Create cont -> + create c_fd process cont (* data contained a write to console, we need to wait for its reply first *) - Vmm_lwt.read_wire c_fd >>= function - | Ok (hdr, data) -> - if Vmm_wire.is_fail hdr then begin - Logs.err (fun m -> m "console failed with %s" (Cstruct.to_string data)) ; - Lwt.return_unit - end else if Vmm_wire.is_reply hdr then begin - (* assert hdr.id = id! *) - let await, wakeme = Lwt.wait () in - begin match cont !state await with - | Error (`Msg msg) -> - Logs.err (fun m -> m "create continuation failed %s" msg) ; - Lwt.return_unit - | Ok (state'', out, vm) -> - state := state'' ; - s := { !s with vm_created = succ !s.vm_created } ; - Lwt.async (fun () -> - Vmm_lwt.wait_and_clear vm.Vmm_core.pid vm.Vmm_core.stdout >>= fun r -> - let state', out' = Vmm_engine.handle_shutdown !state vm r in - s := { !s with vm_destroyed = succ !s.vm_destroyed } ; - state := state' ; - process out' >|= fun () -> - Lwt.wakeup wakeme ()) ; - process out >>= fun () -> - begin match Vmm_engine.setup_stats !state vm with - | Ok (state', out) -> - state := state' ; - process out (* TODO: need to read from stats socket! *) - | Error (`Msg e) -> - Logs.warn (fun m -> m "(ignored) error %s while setting up statistics" e) ; - Lwt.return_unit - end - end - end else begin - Logs.err (fun m -> m "reading from console %lx, %a" hdr.Vmm_wire.tag Cstruct.hexdump_pp data) ; - Lwt.return_unit - end - | Error (`Msg msg) -> - Logs.err (fun m -> m "error %s while reading from console" msg) ; - Lwt.return_unit - | Error _ -> - Logs.err (fun m -> m "error while reading from console") ; - Lwt.return_unit ) >>= fun () -> + ) >>= fun () -> Vmm_lwt.safe_close fd let init_sock sock = @@ -162,7 +177,6 @@ let jump _ = (create_mbox `Log >|= function | None -> invalid_arg "cannot connect to log socket" | Some l -> l) >>= fun (l, _l_fd) -> - let state = ref (Vmm_engine.init ()) in let out = function | `Stat data -> (match s with None -> Lwt.return_unit | Some (s, _s_fd) -> Lwt_mvar.put s data) | `Log data -> Lwt_mvar.put l data @@ -172,7 +186,7 @@ let jump _ = let rec loop () = Lwt_unix.accept ss >>= fun (fd, addr) -> Lwt_unix.set_close_on_exec fd ; - Lwt.async (fun () -> handle state out c_fd fd addr) ; + Lwt.async (fun () -> handle out c_fd fd addr) ; loop () in loop ()) diff --git a/src/vmm_asn.ml b/src/vmm_asn.ml index d541d3b..46b623e 100644 --- a/src/vmm_asn.ml +++ b/src/vmm_asn.ml @@ -103,6 +103,38 @@ let strings_of_cstruct, strings_to_cstruct = let string_of_cstruct, string_to_cstruct = projections_of Asn.S.utf8_string +let policy_obj = + let f (cpuids, vms, memory, block, bridges) = + let bridges = match bridges with + | xs -> + let add m v = + let n = match v with `Internal n -> n | `External (n, _, _, _, _) -> n in + String.Map.add n v m + in + List.fold_left add String.Map.empty xs + and cpuids = IS.of_list cpuids + in + { vms ; cpuids ; memory ; block ; bridges } + and g policy = + (IS.elements policy.cpuids, policy.vms, policy.memory, policy.block, + snd @@ List.split @@ String.Map.bindings policy.bridges) + in + Asn.S.map f g @@ + Asn.S.(sequence5 + (required ~label:"cpuids" Asn.S.(sequence_of int)) + (required ~label:"vms" int) + (required ~label:"memory" int) + (optional ~label:"block" int) + (required ~label:"bridges" Asn.S.(sequence_of bridge))) + +let policy_of_cstruct, policy_to_cstruct = + let c = Asn.codec Asn.der policy_obj in + ((fun cs -> match Asn.decode c cs with + | Ok x -> Ok x + | Error (`Parse msg) -> Error (`Msg msg)), + Asn.encode c) + + let image = let f = function | `C1 x -> `Hvt_amd64, x diff --git a/src/vmm_asn.mli b/src/vmm_asn.mli index 7a571b5..f44b3e1 100644 --- a/src/vmm_asn.mli +++ b/src/vmm_asn.mli @@ -139,6 +139,13 @@ val strings_to_cstruct : string list -> Cstruct.t encoded [buffer] or an error. *) val strings_of_cstruct : Cstruct.t -> (string list, [> `Msg of string ]) result +(** [policy_to_cstruct xs] is the DER encoded policy. *) +val policy_to_cstruct : Vmm_core.policy -> Cstruct.t + +(** [policy_of_cstruct buffer] is either a decoded policy of the DER + encoded [buffer] or an error. *) +val policy_of_cstruct : Cstruct.t -> (Vmm_core.policy * Cstruct.t, [> `Msg of string ]) result + (** {1 Decoding functions} *) (** [contains_vm cert] is [true] if the certificate contains a virtual machine image. *) @@ -153,7 +160,7 @@ val vm_of_cert : Vmm_core.id -> X509.t -> (Vmm_core.vm_config, [> `Msg of string (** [crl_of_cert id cert] is either the decoded revocation list, or an error. *) val crl_of_cert : X509.t -> (X509.CRL.c, [> `Msg of string ]) result -(** [delegation_of_cert version cert] is either the decoded delegation, or an error. *) +(** [policy_of_cert version cert] is either the decoded policy, or an error. *) val policy_of_cert : version -> X509.t -> (Vmm_core.policy, [> `Msg of string ]) result (** [command_of_cert version cert] is either the decoded command, or an error. *) diff --git a/src/vmm_core.ml b/src/vmm_core.ml index 9c470b2..ae04661 100644 --- a/src/vmm_core.ml +++ b/src/vmm_core.ml @@ -7,13 +7,15 @@ open Rresult.R.Infix let tmpdir = Fpath.(v "/var" / "run" / "albatross") let dbdir = Fpath.(v "/var" / "db" / "albatross") -let socket_path = - let path name = Fpath.(to_string (tmpdir / "util" / name + "sock")) in - function - | `Console -> path "console" - | `Vmmd -> Fpath.(to_string (tmpdir / "vmmd.sock")) - | `Stats -> path "stat" - | `Log -> path "log" +let socket_path t = + let path name = Fpath.(tmpdir / "util" / name + "sock") in + let path = match t with + | `Console -> path "console" + | `Vmmd -> Fpath.(tmpdir / "vmmd" + "sock") + | `Stats -> path "stat" + | `Log -> path "log" + in + Fpath.to_string path let pp_socket ppf t = let name = socket_path t in @@ -95,6 +97,10 @@ let drop_super ~super ~sub = let is_sub_id ~super ~sub = match drop_super ~super ~sub with None -> false | Some _ -> true +let domain id = match List.rev id with + | _::prefix -> List.rev prefix + | [] -> [] + let pp_id ppf ids = Fmt.(pf ppf "%a" (list ~sep:(unit ".") string) ids) @@ -185,6 +191,7 @@ let good_bridge idxs nets = List.for_all (fun n -> String.Map.mem n nets) idxs let vm_matches_res (res : policy) (vm : vm_config) = + (* TODO block device *) res.vms >= 1 && IS.mem vm.cpuid res.cpuids && vm.requested_memory <= res.memory && good_bridge vm.network res.bridges diff --git a/src/vmm_engine.ml b/src/vmm_engine.ml index 7a4f0b9..cf52778 100644 --- a/src/vmm_engine.ml +++ b/src/vmm_engine.ml @@ -39,13 +39,15 @@ let log state (hdr, event) = Logs.debug (fun m -> m "LOG %a" Log.pp (hdr, event)) ; ({ state with log_counter }, `Log data) -let handle_create t hdr vm_config (* policies *) = - (if Vmm_resources.exists t.resources vm_config.vname then - Error (`Msg "VM with same name is already running") +let handle_create t hdr vm_config = + (match Vmm_resources.find_vm t.resources vm_config.vname with + | Some _ -> Error (`Msg "VM with same name is already running") + | None -> Ok ()) >>= fun () -> + Logs.debug (fun m -> m "now checking resource policies") ; + (if Vmm_resources.check_vm_policy t.resources vm_config then + Ok () else - Ok ()) >>= fun () -> - (* Logs.debug (fun m -> m "now checking dynamic policies") ; - Vmm_resources.check_dynamic t.resources vm_config policies >>= fun () -> *) + Error (`Msg "resource policies don't allow this")) >>= fun () -> (* prepare VM: save VM image to disk, create fifo, ... *) Vmm_unix.prepare vm_config >>= fun taps -> Logs.debug (fun m -> m "prepared vm with taps %a" Fmt.(list ~sep:(unit ",@ ") string) taps) ; @@ -56,7 +58,7 @@ let handle_create t hdr vm_config (* policies *) = (* actually execute the vm *) Vmm_unix.exec vm_config taps >>= fun vm -> Logs.debug (fun m -> m "exec()ed vm") ; - Vmm_resources.insert t.resources vm_config.vname vm >>= fun resources -> + Vmm_resources.insert_vm t.resources vm >>= fun resources -> let tasks = String.Map.add (string_of_id vm_config.vname) task t.tasks in let used_bridges = List.fold_left2 (fun b br ta -> @@ -81,13 +83,7 @@ let handle_shutdown t vm r = (match Vmm_unix.shutdown vm with | Ok () -> () | Error (`Msg e) -> Logs.warn (fun m -> m "%s while shutdown vm %a" e pp_vm vm)) ; - let resources = - match Vmm_resources.remove t.resources vm.config.vname vm with - | Ok resources -> resources - | Error (`Msg e) -> - Logs.warn (fun m -> m "%s while removing vm %a" e pp_vm vm) ; - t.resources - in + let resources = Vmm_resources.remove t.resources vm.config.vname in let used_bridges = List.fold_left2 (fun b br ta -> let old = match String.Map.find br b with @@ -118,25 +114,79 @@ let handle_command t hdr buf = Ok (t, [], `End) end else if not (Vmm_wire.version_eq hdr.Vmm_wire.version t.client_version) then Error (`Msg "unknown client version") - else Vmm_wire.decode_strings buf >>= fun (id, _off) -> + else Vmm_wire.decode_strings buf >>= fun (id, off) -> match Vmm_wire.Vm.int_to_op hdr.Vmm_wire.tag with | None -> Error (`Msg "unknown command") + | Some Vmm_wire.Vm.Remove_policy -> + Logs.debug (fun m -> m "remove policy %a" pp_id id) ; + let resources = Vmm_resources.remove t.resources id in + let success = Vmm_wire.success t.client_version hdr.Vmm_wire.id hdr.Vmm_wire.tag in + Ok ({ t with resources }, [ `Data success ], `End) + | Some Vmm_wire.Vm.Insert_policy -> + begin + Logs.debug (fun m -> m "insert policy %a" pp_id id) ; + Vmm_asn.policy_of_cstruct (Cstruct.shift buf off) >>= fun (policy, _) -> + Vmm_resources.insert_policy t.resources id policy >>= fun resources -> + let success = Vmm_wire.success t.client_version hdr.Vmm_wire.id hdr.Vmm_wire.tag in + Ok ({ t with resources }, [ `Data success ], `End) + end + | Some Vmm_wire.Vm.Policy -> + 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") + | _ -> + let out = Vmm_wire.Vm.policy_reply hdr.Vmm_wire.id t.client_version policies in + Ok (t, [ `Data out ], `End) + end | Some Vmm_wire.Vm.Info -> - Logs.debug (fun m -> m "info %a" pp_id id) ; - begin match Vmm_resources.find t.resources id with - | None -> + begin + Logs.debug (fun m -> m "info %a" pp_id id) ; + let vms = + Vmm_resources.fold t.resources id + (fun vm vms -> vm :: vms) + (fun _ _ vms-> vms) + [] + in + match vms with + | [] -> Logs.debug (fun m -> m "info: couldn't find %a" pp_id id) ; Error (`Msg "info: not found") - | Some x -> - let data = - Vmm_resources.fold (fun acc vm -> vm :: acc) [] x - in - let out = Vmm_wire.Vm.info_reply hdr.Vmm_wire.id t.client_version data in + | _ -> + let out = Vmm_wire.Vm.info_reply hdr.Vmm_wire.id t.client_version vms in Ok (t, [ `Data out ], `End) end | Some Vmm_wire.Vm.Create -> Vmm_wire.Vm.decode_vm_config buf >>= fun vm_config -> handle_create t hdr vm_config + | Some Vmm_wire.Vm.Force_create -> + Vmm_wire.Vm.decode_vm_config buf >>= fun vm_config -> + let resources = Vmm_resources.remove t.resources vm_config.vname in + if Vmm_resources.check_vm_policy resources vm_config then + begin match Vmm_resources.find_vm t.resources id with + | None -> handle_create t hdr 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 hdr 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 + (t, task, fun t -> + msg_to_err @@ handle_create t hdr vm_config)) + end + else + Error (`Msg "wouldn't match policy") | Some Vmm_wire.Vm.Destroy -> match Vmm_resources.find_vm t.resources id with | Some vm -> diff --git a/src/vmm_resources.ml b/src/vmm_resources.ml index e5e84d7..a3be201 100644 --- a/src/vmm_resources.ml +++ b/src/vmm_resources.ml @@ -1,8 +1,5 @@ (* (c) 2017 Hannes Mehnert, all rights reserved *) -open Astring -open Rresult.R.Infix - open Vmm_core type res_entry = { @@ -10,118 +7,93 @@ type res_entry = { used_memory : int ; } -let pp_res_entry ppf res = - Fmt.pf ppf "%d vms %d memory" res.running_vms res.used_memory - let empty_res = { running_vms = 0 ; used_memory = 0 } let check_resource (policy : policy) (vm : vm_config) (res : res_entry) = - succ res.running_vms <= policy.vms && res.used_memory + vm.requested_memory <= policy.memory + succ res.running_vms <= policy.vms && res.used_memory + vm.requested_memory <= policy.memory && + 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 } -let rem (vm : vm) (res : res_entry) = - { running_vms = pred res.running_vms ; - used_memory = res.used_memory - vm.config.requested_memory } - type entry = - | Leaf of vm - | Subtree of res_entry * entry String.Map.t + | Vm of vm + | Policy of policy -type t = entry String.Map.t +type t = entry Vmm_trie.t -let empty = String.Map.empty +let empty = Vmm_trie.empty -let check_dynamic m vm policies = - (* for each policy (string * delegation), we need to look that vm + dynamic <= delegation *) - let rec go m = function - | [] -> Ok () - | (nam,delegation)::rest -> - match String.Map.find nam m with - | None -> Ok () - | Some (Leaf _) -> Error (`Msg "didn't expect a leaf here") - | Some (Subtree (r, m)) -> - if check_resource delegation vm r then - go m rest - else - Error (`Msg ("overcommitted at " ^ nam)) - in - go m policies +let remove t name = Vmm_trie.remove name t -let rec pp_entry ppf = function - | Leaf vm -> pp_vm ppf vm - | Subtree (res, m) -> - Fmt.pf ppf "%a %a" - pp_res_entry res - Fmt.(list ~sep:(unit "@ ") (pair ~sep:(unit " -> ") string pp_entry)) - (String.Map.bindings m) +let fold t name f g acc = + Vmm_trie.fold name t (fun prefix entry acc -> + match entry with + | Vm vm -> f vm acc + | Policy p -> g prefix p acc) acc -let pp ppf map = - Fmt.pf ppf "%a" - Fmt.(list ~sep:(unit "@ ") (pair ~sep:(unit " -> ") string pp_entry)) - (String.Map.bindings map) +(* we should hide this type and confirm the following invariant: + - in case Vm, there are no siblings *) -let find t name = - let rec find r m = function - | [] -> Some (Subtree (r, m)) - | x::xs -> match String.Map.find x m with - | None -> None - | Some (Subtree (r, m)) -> find r m xs - | Some (Leaf vm) -> Some (Leaf vm) - in - find empty_res t name +let resource_usage t name = + Vmm_trie.fold name t (fun _ entry acc -> + match entry with + | Policy _ -> acc + | Vm vm -> add vm acc) + empty_res -let exists t name = match find t name with None -> false | Some _ -> true - -let find_vm t name = match find t name with - | Some (Leaf vm) -> Some vm +let find_vm t name = match Vmm_trie.find name t with + | Some (Vm vm) -> Some vm | _ -> None -let rec iter f = function - | Leaf vm -> f vm - | Subtree (_, m) -> List.iter (fun (_, e) -> iter f e) (String.Map.bindings m) +let check_vm_policy t vm = + let dom = domain vm.vname in + let res = resource_usage t dom in + match Vmm_trie.find dom t with + | None -> true + | Some (Vm _) -> assert false + | Some (Policy p) -> check_resource p vm res -let rec fold f acc = function - | Leaf vm -> f acc vm - | Subtree (_, m) -> - List.fold_left (fun acc (_, e) -> fold f acc e) acc (String.Map.bindings m) +let insert_vm t vm = + if check_vm_policy t vm.config then + match Vmm_trie.insert vm.config.vname (Vm vm) t with + | t', None -> Ok t' + | _, Some _ -> Error (`Msg "vm already exists") + else + Error (`Msg "resource policy mismatch") -let insert m name v = - let rec insert m = function - | [] -> Error (`Msg "ran out of labels during insert, this should not happen") - | [l] -> - begin match String.Map.find l m with - | None -> Ok (String.Map.add l (Leaf v) m) - | Some (Subtree _) -> Error (`Msg "found a subtree as last label") - | Some (Leaf _) -> Ok (String.Map.add l (Leaf v) m) - end - | l::ls -> - match String.Map.find l m with - | None -> - insert String.Map.empty ls >>= fun sub -> - Ok (String.Map.add l (Subtree (add v empty_res, sub)) m) - | Some (Subtree (r, m')) -> - insert m' ls >>= fun sub -> - Ok (String.Map.add l (Subtree (add v r, sub)) m) - | Some (Leaf _) -> Error (`Msg "should not happen: found leaf while still having labels") - in - insert m name +let check_policy_above t name p = + let above = Vmm_trie.collect name t in + List.for_all (fun (_, node) -> match node with + | Vm _ -> assert false + | Policy p' -> is_sub ~super:p' ~sub:p) + above -let remove m name vm = - let rec del m = function - | [] -> Error (`Msg "should not happen: empty labels in remove") - | [l] -> Ok (String.Map.remove l m) - | l::ls -> match String.Map.find l m with - | None -> Error (`Msg "should not happen: found nothing in remove while still had some labels") - | Some (Subtree (r, m')) -> - del m' ls >>= fun m' -> - if String.Map.is_empty m' then - Ok (String.Map.remove l m) - else - let res = rem vm r in - Ok (String.Map.add l (Subtree (res, m')) m) - | Some (Leaf _) -> Error (`Msg "should not happen: found a leaf, but had some labels") - in - del m name +let check_policy_below t name p = + Vmm_trie.fold name t (fun name entry res -> + match name with + | [] -> res + | _ -> + match res, entry with + | Ok p, Policy p' -> if is_sub ~super:p ~sub:p then Ok p' else Error () + | Ok p, Vm vm -> + (* TODO block device *) + if IS.mem vm.config.cpuid p.cpuids && good_bridge vm.config.network p.bridges then Ok p else Error () + | res, _ -> res) + (Ok p) + +let insert_policy t name p = + let dom = domain name in + match + check_policy_above t dom p, + check_policy_below t name p, + check_resource_policy p (resource_usage t dom) + with + | true, Ok _, true -> Ok (fst (Vmm_trie.insert name (Policy p) t)) + | false, _, _ -> Error (`Msg "policy violates other policies above") + | _, Error (), _ -> Error (`Msg "policy violates other policies below") + | _, _, false -> Error (`Msg "more resources used than policy would allow") diff --git a/src/vmm_resources.mli b/src/vmm_resources.mli index 08a12ca..9878c65 100644 --- a/src/vmm_resources.mli +++ b/src/vmm_resources.mli @@ -1,6 +1,6 @@ (* (c) 2017 Hannes Mehnert, all rights reserved *) -(** A tree data structure tracking dynamic resource usage. +(** A tree data structure including policies and dynamic usage. Considering delegation of resources to someone, and further delegation to others - using a process which is not controlled by the authority - @@ -14,43 +14,27 @@ (** The type of the resource tree. *) type t -(** The type of the resource tree entry. *) -type entry - (** [empty] is the empty tree. *) val empty : t -(** [pp ppf t] pretty prints the tree. *) -val pp : t Fmt.t - -(** [pp_entry ppf e] pretty prints the entry. *) -val pp_entry : entry Fmt.t - -(** [check_dynamic t vm delegates] checks whether creating [vm] would violate - the policies of the [delegates] with respect to the running vms. *) -val check_dynamic : t -> - Vmm_core.vm_config -> (string * Vmm_core.policy) list -> - (unit, [> `Msg of string ]) result - -(** [exists t id] is [true] if the [id] already exists, [false] otherwise. *) -val exists : t -> Vmm_core.id -> bool - -(** [find t id] is either [Some entry] or [None]. *) -val find : t -> Vmm_core.id -> entry option - (** [find_vm t id] is either [Some vm] or [None]. *) val find_vm : t -> Vmm_core.id -> Vmm_core.vm option -(** [iter f entry] applies [f] to each vm of [entry]. *) -val iter : (Vmm_core.vm -> unit) -> entry -> unit +(** [check_vm_policy t vm] checks whether [vm] under [id] in [t] would be + allowed under the current policies. *) +val check_vm_policy : t -> Vmm_core.vm_config -> bool -(** [fold f entry acc] folds [f] over [entry]. *) -val fold : ('a -> Vmm_core.vm -> 'a) -> 'a -> entry -> 'a +(** [insert_vm t vm] inserts [vm] under [id] in [t], and returns the new [t] or + an error. *) +val insert_vm : t -> Vmm_core.vm -> (t, [> `Msg of string]) result -(** [insert t id vm] inserts [vm] under [id] in [t], and returns the new [t] or - an error. It also updates the resource usages on the path. *) -val insert : t -> Vmm_core.id -> Vmm_core.vm -> (t, [> `Msg of string]) result +(** [insert_policy t id policy] inserts [policy] under [id] in [t], and returns + the new [t] or an error. *) +val insert_policy : t -> Vmm_core.id -> Vmm_core.policy -> (t, [> `Msg of string]) result -(** [remove t id vm] removes [id] from [t], and returns the new [t] or an - error. This also updates the resources usages on the path. *) -val remove : t -> Vmm_core.id -> Vmm_core.vm -> (t, [> `Msg of string]) result +(** [remove t id] removes [id] from [t]. *) +val remove : t -> Vmm_core.id -> t + +(** [fold t id f g acc] folds [f] and [g] below [id] over [t]. *) +val fold : t -> Vmm_core.id -> (Vmm_core.vm -> 'a -> 'a) -> + (Vmm_core.id -> Vmm_core.policy -> 'a -> 'a) -> 'a -> 'a diff --git a/src/vmm_trie.ml b/src/vmm_trie.ml index dc85b0a..ae1559b 100644 --- a/src/vmm_trie.ml +++ b/src/vmm_trie.ml @@ -77,3 +77,21 @@ let all t = acc' (String.Map.bindings m) in go [] [] t + +let fold id t f acc = + let rec explore (N (es, m)) prefix acc = + let acc' = + String.Map.fold (fun name node acc -> explore node (prefix@[name]) acc) + m acc + in + match es with + | None -> acc' + | Some e -> f prefix e acc' + and down prefix (N (es, m)) = + match prefix with + | [] -> explore (N (es, m)) [] acc + | x :: xs -> match String.Map.find_opt x m with + | None -> acc + | Some n -> down xs n + in + down id t diff --git a/src/vmm_trie.mli b/src/vmm_trie.mli index 5e2bca2..2564df1 100644 --- a/src/vmm_trie.mli +++ b/src/vmm_trie.mli @@ -13,3 +13,5 @@ val find : id -> 'a t -> 'a option val collect : id -> 'a t -> (id * 'a) list val all : 'a t -> (id * 'a) list + +val fold : id -> 'a t -> (id -> 'a -> 'b -> 'b) -> 'b -> 'b diff --git a/src/vmm_wire.ml b/src/vmm_wire.ml index e8356b5..47f81c8 100644 --- a/src/vmm_wire.ml +++ b/src/vmm_wire.ml @@ -546,19 +546,40 @@ module Vm = struct | Create | Destroy | Info - (* | Add_policy *) + | Policy + | Insert_policy + | Remove_policy + | Force_create let op_to_int = function | Create -> 0x0400l | Destroy -> 0x0401l | Info -> 0x0402l + | Policy -> 0x0403l + | Insert_policy -> 0x0404l + | Remove_policy -> 0x0405l + | Force_create -> 0x0406l let int_to_op = function | 0x0400l -> Some Create | 0x0401l -> Some Destroy | 0x0402l -> Some Info + | 0x0403l -> Some Policy + | 0x0404l -> Some Insert_policy + | 0x0405l -> Some Remove_policy + | 0x0406l -> Some Force_create | _ -> None + let policy id version name = + encode ~name version id (op_to_int Policy) + + let insert_policy id version name policy = + let body = Vmm_asn.policy_to_cstruct policy in + encode ~name ~body version id (op_to_int Insert_policy) + + let remove_policy id version name = + encode ~name version id (op_to_int Remove_policy) + let info id version name = encode ~name version id (op_to_int Info) @@ -575,6 +596,25 @@ module Vm = struct let body = encode_list encode_vm vms in reply ~body version id (op_to_int Info) + let policy_reply id version policies = + let body = encode_list + (fun (prefix, policy) -> + let name_cs = encode_strings prefix + and pol_cs = Vmm_asn.policy_to_cstruct policy in + Cstruct.append name_cs pol_cs) + policies + in + reply ~body version id (op_to_int Policy) + + let decode_policies buf = + decode_list (fun cs -> + decode_strings cs >>= fun (id, l) -> + cs_shift cs l >>= fun cs' -> + Vmm_asn.policy_of_cstruct cs' >>= fun (policy, cs'') -> + let off = Cstruct.len cs - Cstruct.len cs'' in + Ok ((id, policy), off)) + buf + let decode_vm cs = decode_strings cs >>= fun (id, l) -> cs_shift cs l >>= fun cs' -> @@ -632,124 +672,10 @@ module Vm = struct let body = encode_vm_config vm in encode ~name:vm.vname ~body version id (op_to_int Create) + let force_create id version vm = + let body = encode_vm_config vm in + encode ~name:vm.vname ~body version id (op_to_int Force_create) + let destroy id version name = encode ~name version id (op_to_int Destroy) end - -(* -module Client = struct - let cmd_to_int = function - | Info -> 0x0500l - | Destroy_vm -> 0x0501l - | Create_block -> 0x0502l - | Destroy_block -> 0x0503l - | Statistics -> 0x0504l - | Attach -> 0x0505l - | Detach -> 0x0506l - | Log -> 0x0507l - and cmd_of_int = function - | 0x0500l -> Some Info - | 0x0501l -> Some Destroy_vm - | 0x0502l -> Some Create_block - | 0x0503l -> Some Destroy_block - | 0x0504l -> Some Statistics - | 0x0505l -> Some Attach - | 0x0506l -> Some Detach - | 0x0507l -> Some Log - | _ -> None - - let cmd ?arg it id version = - let pay, length = may_enc_str arg - and tag = cmd_to_int it - in - let length = Int32.of_int length in - let hdr = create_header { length ; id ; version ; tag } in - Cstruct.(to_string (append hdr pay)) - - let log hdr event version = - let payload = - Cstruct.append - (Log.encode_log_hdr ~drop_context:true hdr) - (Log.encode_event event) - in - let length = cs_len payload in - let r = - Cstruct.append - (create_header { length ; id = 0L ; version ; tag = Log.(op_to_int Data) }) - payload - in - Cstruct.to_string r - - let stat data id version = - let length = Int32.of_int (String.length data) in - let hdr = create_header { length ; id ; version ; tag = Stats.(op_to_int Stat_reply) } in - Cstruct.to_string hdr ^ data - - let console off name payload version = - let name = match List.rev (id_of_string name) with - | leaf::_ -> leaf - | [] -> "none" - in - let nam, l = encode_string name in - let payload, length = - let p' = Astring.String.drop ~max:off payload in - p', l + String.length p' - in - let length = Int32.of_int length in - let hdr = - create_header { length ; id = 0L ; version ; tag = Console.(op_to_int Data) } - in - Cstruct.(to_string (append hdr nam)) ^ payload - - let encode_vm name vm = - let name = encode_string name - and cs = encode_string (Bos.Cmd.to_string vm.cmd) - and pid = encode_int vm.pid - and taps = encode_strings vm.taps - in - let tapc = encode_int (Cstruct.len taps) in - let r = Cstruct.concat [ name ; cs ; pid ; tapc ; taps ] in - Cstruct.to_string r - - let info data id version = - let length = String.length data in - let length = Int32.of_int length in - let hdr = create_header { length ; id ; version ; tag = success_tag } in - Cstruct.to_string hdr ^ data - - let decode_vm cs = - decode_string cs >>= fun (name, l) -> - decode_string (Cstruct.shift cs l) >>= fun (cmd, l') -> - decode_int (Cstruct.shift cs (l + l')) >>= fun pid -> - decode_int ~off:(l + l' + 4) cs >>= fun tapc -> - let taps = Cstruct.sub cs (l + l' + 12) tapc in - decode_strings taps >>= fun taps -> - Ok ((name, cmd, pid, taps), Cstruct.shift cs (l + l' + 12 + tapc)) - - let decode_info data = - let rec go acc buf = - if Cstruct.len buf = 0 then - Ok (List.rev acc) - else - decode_vm buf >>= fun (vm, rest) -> - go (vm :: acc) rest - in - go [] (Cstruct.of_string data) - - let decode_stat data = - Stats.decode_stats (Cstruct.of_string data) - - let decode_log data = - let cs = Cstruct.of_string data in - Log.decode_log_hdr cs >>= fun (hdr, rest) -> - Log.decode_event rest >>= fun event -> - Ok (hdr, event) - - let decode_console data = - let cs = Cstruct.of_string data in - decode_string cs >>= fun (name, l) -> - decode_ptime (Cstruct.shift cs l) >>= fun ts -> - decode_string (Cstruct.shift cs (l + 16)) >>= fun (line, _) -> - Ok (name, ts, line) -end - *)