From 561ba5c5dfa69fc64aa9d8267239c70861dec552 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Sun, 11 Nov 2018 03:09:37 +0100 Subject: [PATCH] put Policy in a submodule --- app/vmm_cli.ml | 5 +- app/vmmd_tls.ml | 2 +- src/vmm_asn.ml | 9 ++- src/vmm_commands.ml | 8 +-- src/vmm_commands.mli | 4 +- src/vmm_core.ml | 151 +++++++++++++++++++++--------------------- src/vmm_core.mli | 47 ++++++------- src/vmm_resources.ml | 31 +++++---- src/vmm_resources.mli | 6 +- src/vmm_tls.mli | 2 +- src/vmm_vmmd.ml | 2 +- 11 files changed, 134 insertions(+), 133 deletions(-) diff --git a/app/vmm_cli.ml b/app/vmm_cli.ml index 57973e1..a9ce21d 100644 --- a/app/vmm_cli.ml +++ b/app/vmm_cli.ml @@ -39,8 +39,7 @@ let policy vms memory cpus block bridges = List.fold_left add String.Map.empty bridges and cpuids = IS.of_list cpus in - { vms ; cpuids ; memory ; block ; bridges } - + Policy.{ vms ; cpuids ; memory ; block ; bridges } open Cmdliner @@ -83,7 +82,7 @@ let bridge = | [ name ] -> `Ok (`Internal name) | _ -> `Error "couldn't parse bridge (either specify 'name' or 'name/firstIP/lastIP/gatewayIP/netmask')" in - (parse, pp_bridge) + (parse, Policy.pp_bridge) let vm_c = let parse s = match Name.of_string s with diff --git a/app/vmmd_tls.ml b/app/vmmd_tls.ml index 13efaa0..c3e6046 100644 --- a/app/vmmd_tls.ml +++ b/app/vmmd_tls.ml @@ -71,7 +71,7 @@ let handle ca (tls, addr) = match r with | Error (`Msg msg) -> Lwt.return (Error (`Msg msg)) | Ok () -> - Logs.debug (fun m -> m "adding policy for %a: %a" Vmm_core.Name.pp id Vmm_core.pp_policy policy) ; + Logs.debug (fun m -> m "adding policy for %a: %a" Vmm_core.Name.pp id Vmm_core.Policy.pp policy) ; let header = Vmm_commands.{version = my_version ; sequence = !command ; name = id } in command := Int64.succ !command ; Vmm_lwt.write_wire fd (header, `Command (`Policy_cmd (`Policy_add policy))) >>= function diff --git a/src/vmm_asn.ml b/src/vmm_asn.ml index f3523bf..f854a96 100644 --- a/src/vmm_asn.ml +++ b/src/vmm_asn.ml @@ -58,10 +58,13 @@ let policy = List.fold_left add String.Map.empty xs and cpuids = IS.of_list cpuids in - { vms ; cpuids ; memory ; block ; bridges } + Policy.{ 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) + (IS.elements policy.Policy.cpuids, + policy.Policy.vms, + policy.Policy.memory, + policy.Policy.block, + snd @@ List.split @@ String.Map.bindings policy.Policy.bridges) in Asn.S.map f g @@ Asn.S.(sequence5 diff --git a/src/vmm_commands.ml b/src/vmm_commands.ml index 9793378..8204db3 100644 --- a/src/vmm_commands.ml +++ b/src/vmm_commands.ml @@ -61,13 +61,13 @@ let pp_vm_cmd ppf = function type policy_cmd = [ | `Policy_info - | `Policy_add of policy + | `Policy_add of Policy.t | `Policy_remove ] let pp_policy_cmd ppf = function | `Policy_info -> Fmt.string ppf "policy info" - | `Policy_add policy -> Fmt.pf ppf "policy add %a" pp_policy policy + | `Policy_add policy -> Fmt.pf ppf "policy add %a" Policy.pp policy | `Policy_remove -> Fmt.string ppf "policy remove" type block_cmd = [ @@ -119,7 +119,7 @@ type header = { type success = [ | `Empty | `String of string - | `Policies of (Name.t * policy) list + | `Policies of (Name.t * Policy.t) list | `Vms of (Name.t * vm_config) list | `Blocks of (Name.t * int * bool) list ] @@ -130,7 +130,7 @@ let pp_block ppf (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 ": ") Name.pp pp_policy)) ppf ps + | `Policies ps -> Fmt.(list ~sep:(unit "@.") (pair ~sep:(unit ": ") Name.pp Policy.pp)) ppf ps | `Vms vms -> Fmt.(list ~sep:(unit "@.") (pair ~sep:(unit ": ") Name.pp pp_vm_config)) ppf vms | `Blocks blocks -> Fmt.(list ~sep:(unit "@.") pp_block) ppf blocks diff --git a/src/vmm_commands.mli b/src/vmm_commands.mli index cc569ab..19c7324 100644 --- a/src/vmm_commands.mli +++ b/src/vmm_commands.mli @@ -35,7 +35,7 @@ type vm_cmd = [ type policy_cmd = [ | `Policy_info - | `Policy_add of policy + | `Policy_add of Policy.t | `Policy_remove ] @@ -73,7 +73,7 @@ type header = { type success = [ | `Empty | `String of string - | `Policies of (Name.t * policy) list + | `Policies of (Name.t * Policy.t) list | `Vms of (Name.t * vm_config) list | `Blocks of (Name.t * int * bool) list ] diff --git a/src/vmm_core.ml b/src/vmm_core.ml index 9002d2a..b6a9a79 100644 --- a/src/vmm_core.ml +++ b/src/vmm_core.ml @@ -22,7 +22,6 @@ let pp_socket ppf t = let name = socket_path t in Fmt.pf ppf "socket: %s" name - module I = struct type t = int let compare : int -> int -> int = compare @@ -119,86 +118,88 @@ module Name = struct Fmt.(pf ppf "[name %a]" (list ~sep:(unit ".") string) ids) end -let pp_is ppf is = Fmt.pf ppf "%a" Fmt.(list ~sep:(unit ",") int) (IS.elements is) +module Policy = struct + let pp_is ppf is = Fmt.pf ppf "%a" Fmt.(list ~sep:(unit ",") int) (IS.elements is) -type bridge = [ - | `Internal of string - | `External of string * Ipaddr.V4.t * Ipaddr.V4.t * Ipaddr.V4.t * int -] + type bridge = [ + | `Internal of string + | `External of string * Ipaddr.V4.t * Ipaddr.V4.t * Ipaddr.V4.t * int + ] -let eq_int (a : int) (b : int) = a = b + let eq_int (a : int) (b : int) = a = b -let eq_bridge b1 b2 = match b1, b2 with - | `Internal a, `Internal a' -> String.equal a a' - | `External (name, ip_start, ip_end, ip_gw, netmask), - `External (name', ip_start', ip_end', ip_gw', netmask') -> - let eq_ip a b = Ipaddr.V4.compare a b = 0 in - String.equal name name' && - eq_ip ip_start ip_start' && - eq_ip ip_end ip_end' && - eq_ip ip_gw ip_gw' && - eq_int netmask netmask' - | _ -> false - -let pp_bridge ppf = function - | `Internal name -> Fmt.pf ppf "%s (internal)" name - | `External (name, l, h, gw, nm) -> - Fmt.pf ppf "%s: %a - %a, GW: %a/%d" - name Ipaddr.V4.pp_hum l Ipaddr.V4.pp_hum h Ipaddr.V4.pp_hum gw nm - -type policy = { - vms : int ; - cpuids : IS.t ; - memory : int ; - block : int option ; - bridges : bridge String.Map.t ; -} - -let eq_policy p1 p2 = - let eq_opt a b = match a, b with - | None, None -> true - | Some a, Some b -> eq_int a b + let equal_bridge b1 b2 = match b1, b2 with + | `Internal a, `Internal a' -> String.equal a a' + | `External (name, ip_start, ip_end, ip_gw, netmask), + `External (name', ip_start', ip_end', ip_gw', netmask') -> + let eq_ip a b = Ipaddr.V4.compare a b = 0 in + String.equal name name' && + eq_ip ip_start ip_start' && + eq_ip ip_end ip_end' && + eq_ip ip_gw ip_gw' && + eq_int netmask netmask' | _ -> false - in - eq_int p1.vms p2.vms && - IS.equal p1.cpuids p2.cpuids && - eq_int p1.memory p2.memory && - eq_opt p1.block p2.block && - String.Map.equal eq_bridge p1.bridges p2.bridges -let pp_policy ppf res = - Fmt.pf ppf "policy: %d vms %a cpus %d MB memory %a MB block bridges: %a" - res.vms pp_is res.cpuids res.memory - Fmt.(option ~none:(unit "no") int) res.block - Fmt.(list ~sep:(unit ", ") pp_bridge) - (List.map snd (String.Map.bindings res.bridges)) + let pp_bridge ppf = function + | `Internal name -> Fmt.pf ppf "%s (internal)" name + | `External (name, l, h, gw, nm) -> + Fmt.pf ppf "%s: %a - %a, GW: %a/%d" + name Ipaddr.V4.pp_hum l Ipaddr.V4.pp_hum h Ipaddr.V4.pp_hum gw nm -let sub_bridges super sub = - String.Map.for_all (fun idx v -> - match String.Map.find idx super, v with - | None, _ -> false - | Some (`Internal nam), `Internal nam' -> String.compare nam nam' = 0 - | Some (`External (nam, supf, supl, gw, nm)), - `External (nam', subf, subl, gw', nm') -> - String.compare nam nam' = 0 && nm = nm' && - Ipaddr.V4.compare supf subf <= 0 && Ipaddr.V4.compare supl subl >= 0 && - Ipaddr.V4.compare gw gw' = 0 - | _ -> false) - sub + type t = { + vms : int ; + cpuids : IS.t ; + memory : int ; + block : int option ; + bridges : bridge String.Map.t ; + } -let sub_block super sub = - match super, sub with - | None, None -> true - | Some _, None -> true - | Some x, Some y -> x >= y - | None, Some _ -> false + let equal p1 p2 = + let eq_opt a b = match a, b with + | None, None -> true + | Some a, Some b -> eq_int a b + | _ -> false + in + eq_int p1.vms p2.vms && + IS.equal p1.cpuids p2.cpuids && + eq_int p1.memory p2.memory && + eq_opt p1.block p2.block && + String.Map.equal equal_bridge p1.bridges p2.bridges -let sub_cpu super sub = IS.subset sub super + let pp ppf res = + Fmt.pf ppf "policy: %d vms %a cpus %d MB memory %a MB block bridges: %a" + res.vms pp_is res.cpuids res.memory + Fmt.(option ~none:(unit "no") int) res.block + Fmt.(list ~sep:(unit ", ") pp_bridge) + (List.map snd (String.Map.bindings res.bridges)) -let is_sub ~super ~sub = - sub.vms <= super.vms && sub_cpu super.cpuids sub.cpuids && - sub.memory <= super.memory && - sub_bridges super.bridges sub.bridges && sub_block super.block sub.block + let sub_bridges super sub = + String.Map.for_all (fun idx v -> + match String.Map.find idx super, v with + | None, _ -> false + | Some (`Internal nam), `Internal nam' -> String.compare nam nam' = 0 + | Some (`External (nam, supf, supl, gw, nm)), + `External (nam', subf, subl, gw', nm') -> + String.compare nam nam' = 0 && nm = nm' && + Ipaddr.V4.compare supf subf <= 0 && Ipaddr.V4.compare supl subl >= 0 && + Ipaddr.V4.compare gw gw' = 0 + | _ -> false) + sub + + let sub_block super sub = + match super, sub with + | None, None -> true + | Some _, None -> true + | Some x, Some y -> x >= y + | None, Some _ -> false + + let sub_cpu super sub = IS.subset sub super + + let is_sub ~super ~sub = + sub.vms <= super.vms && sub_cpu super.cpuids sub.cpuids && + sub.memory <= super.memory && + sub_bridges super.bridges sub.bridges && sub_block super.block sub.block +end type vm_config = { cpuid : int ; @@ -225,15 +226,15 @@ let good_bridge idxs nets = (* TODO: uniqueness of n -- it should be an ordered set? *) List.for_all (fun n -> String.Map.mem n nets) idxs -let vm_matches_res (res : policy) (vm : vm_config) = - res.vms >= 1 && IS.mem vm.cpuid res.cpuids && +let vm_matches_res (res : Policy.t) (vm : vm_config) = + res.Policy.vms >= 1 && IS.mem vm.cpuid res.Policy.cpuids && vm.requested_memory <= res.memory && good_bridge vm.network res.bridges let check_policies vm res = let rec climb = function | super :: sub :: xs -> - if is_sub ~super ~sub then climb (sub :: xs) + if Policy.is_sub ~super ~sub then climb (sub :: xs) else Error (`Msg "policy violation") | [x] -> Ok x | [] -> Error (`Msg "empty resource list") diff --git a/src/vmm_core.mli b/src/vmm_core.mli index 1b5b72c..42eb4c7 100644 --- a/src/vmm_core.mli +++ b/src/vmm_core.mli @@ -5,15 +5,12 @@ type service = [ `Console | `Log | `Stats | `Vmmd ] val socket_path : service -> string val pp_socket : service Fmt.t -module I : sig type t = int val compare : int -> int -> int end - module IS : sig - include Set.S with type elt = I.t + include Set.S with type elt = int end -val pp_is : IS.t Fmt.t module IM : sig - include Map.S with type key = I.t + include Map.S with type key = int end module Name : sig @@ -41,31 +38,29 @@ module Name : sig val block_name : t -> string -> t end -type bridge = - [ `External of string * Ipaddr.V4.t * Ipaddr.V4.t * Ipaddr.V4.t * int - | `Internal of string ] +module Policy : sig + type bridge = + [ `External of string * Ipaddr.V4.t * Ipaddr.V4.t * Ipaddr.V4.t * int + | `Internal of string ] -val eq_bridge : bridge -> bridge -> bool + val equal_bridge : bridge -> bridge -> bool -val pp_bridge : bridge Fmt.t + val pp_bridge : bridge Fmt.t -type policy = { - vms : int; - cpuids : IS.t; - memory : int; - block : int option; - bridges : bridge Astring.String.Map.t; -} + type t = { + vms : int; + cpuids : IS.t; + memory : int; + block : int option; + bridges : bridge Astring.String.Map.t; + } -val eq_policy : policy -> policy -> bool + val equal : t -> t -> bool -val pp_policy : policy Fmt.t + val pp : t Fmt.t -val sub_bridges : bridge Astring.String.map -> bridge Astring.String.map -> bool - -val sub_block : 'a option -> 'a option -> bool -val sub_cpu : IS.t -> IS.t -> bool -val is_sub : super:policy -> sub:policy -> bool + val is_sub : super:t -> sub:t -> bool +end type vmtype = [ `Hvt_amd64 | `Hvt_amd64_compressed | `Hvt_arm64 ] val pp_vmtype : vmtype Fmt.t @@ -84,10 +79,10 @@ val pp_image : (vmtype * Cstruct.t) Fmt.t val pp_vm_config : vm_config Fmt.t val good_bridge : string list -> 'a Astring.String.map -> bool -val vm_matches_res : policy -> vm_config -> bool +val vm_matches_res : Policy.t -> vm_config -> bool val check_policies : - vm_config -> policy list -> (unit, [> `Msg of string ]) Result.result + vm_config -> Policy.t list -> (unit, [> `Msg of string ]) Result.result type vm = { config : vm_config; diff --git a/src/vmm_resources.ml b/src/vmm_resources.ml index 0181476..e98e6e2 100644 --- a/src/vmm_resources.ml +++ b/src/vmm_resources.ml @@ -10,25 +10,25 @@ type res_entry = { 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 && - res.used_memory + vm.requested_memory <= policy.memory && - vm_matches_res policy vm +let check_resource (p : Policy.t) (vm : vm_config) (res : res_entry) = + succ res.running_vms <= p.Policy.vms && + res.used_memory + vm.requested_memory <= p.Policy.memory && + vm_matches_res p vm -let check_resource_policy (policy : policy) (res : res_entry) = - res.running_vms <= policy.vms && res.used_memory <= policy.memory && - match policy.block with +let check_resource_policy (p : Policy.t) (res : res_entry) = + res.running_vms <= p.Policy.vms && res.used_memory <= p.Policy.memory && + match p.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 + | Policy of Policy.t let pp_entry id ppf = function | Vm vm -> Fmt.pf ppf "vm %a: %a@." Name.pp id pp_vm_config vm.config - | Policy p -> Fmt.pf ppf "policy %a: %a@." Name.pp id pp_policy p + | Policy p -> Fmt.pf ppf "policy %a: %a@." Name.pp id Policy.pp p | Block (size, used) -> Fmt.pf ppf "block device %a: %dMB (used %B)@." Name.pp id size used type t = entry Vmm_trie.t @@ -117,7 +117,7 @@ let insert_vm t name vm = let check_policy_above t name p = let above = Vmm_trie.collect name t in List.for_all (fun (id, node) -> match node with - | Policy p' -> is_sub ~super:p' ~sub:p + | Policy p' -> Policy.is_sub ~super:p' ~sub:p | x -> Logs.err (fun m -> m "expected policy, found %a" (pp_entry id) x) ; @@ -129,14 +129,17 @@ let check_policy_below t name p = if Name.is_root name then res else - match res, entry with - | Some p, Policy p' -> if is_sub ~super:p ~sub:p then Some p' else None - | Some p, Vm vm -> + match entry, res with + | Policy p', Some p -> + if Policy.is_sub ~super:p ~sub:p' + then Some p' + else None + | Vm vm, Some p -> let cfg = vm.config in if IS.mem cfg.cpuid p.cpuids && good_bridge cfg.network p.bridges then Some p else None - | res, _ -> res) + | _, res -> res) (Some p) let insert_policy t name p = diff --git a/src/vmm_resources.mli b/src/vmm_resources.mli index dc4023c..d812927 100644 --- a/src/vmm_resources.mli +++ b/src/vmm_resources.mli @@ -21,7 +21,7 @@ val empty : t val find_vm : t -> Vmm_core.Name.t -> Vmm_core.vm option (** [find_policy t Name.t] is either [Some policy] or [None]. *) -val find_policy : t -> Vmm_core.Name.t -> Vmm_core.policy option +val find_policy : t -> Vmm_core.Name.t -> Vmm_core.Policy.t option (** [find_block t Name.t] is either [Some (size, active)] or [None]. *) val find_block : t -> Vmm_core.Name.t -> (int * bool) option @@ -36,7 +36,7 @@ val insert_vm : t -> Vmm_core.Name.t -> Vmm_core.vm -> (t, [> `Msg of string]) r (** [insert_policy t Name.t policy] inserts [policy] under [Name.t] in [t], and returns the new [t] or an error. *) -val insert_policy : t -> Vmm_core.Name.t -> Vmm_core.policy -> (t, [> `Msg of string]) result +val insert_policy : t -> Vmm_core.Name.t -> Vmm_core.Policy.t -> (t, [> `Msg of string]) result (** [check_block_policy t Name.t size] checks whether [size] under [Name.t] in [t] would be allowed under the current policies. *) @@ -58,7 +58,7 @@ val remove_block : t -> Vmm_core.Name.t -> (t, [> `Msg of string ]) result (** [fold t Name.t f_vm f_policy f_block acc] folds [f_vm], [f_policy] and [f_block] below [Name.t] over [t]. *) val fold : t -> Vmm_core.Name.t -> (Vmm_core.Name.t -> Vmm_core.vm -> 'a -> 'a) -> - (Vmm_core.Name.t -> Vmm_core.policy -> 'a -> 'a) -> + (Vmm_core.Name.t -> Vmm_core.Policy.t -> 'a -> 'a) -> (Vmm_core.Name.t -> int -> bool -> 'a -> 'a) -> 'a -> 'a (** [pp] is a pretty printer for [t]. *) diff --git a/src/vmm_tls.mli b/src/vmm_tls.mli index 64bdd80..807e590 100644 --- a/src/vmm_tls.mli +++ b/src/vmm_tls.mli @@ -6,5 +6,5 @@ val wire_command_of_cert : Vmm_commands.version -> X509.t -> val handle : 'a -> Vmm_commands.version -> X509.t list -> - (Vmm_core.Name.t * (Vmm_core.Name.t * Vmm_core.policy) list * Vmm_commands.t, + (Vmm_core.Name.t * (Vmm_core.Name.t * Vmm_core.Policy.t) list * Vmm_commands.t, [> `Msg of string ]) Result.result diff --git a/src/vmm_vmmd.ml b/src/vmm_vmmd.ml index 92813a6..93c768d 100644 --- a/src/vmm_vmmd.ml +++ b/src/vmm_vmmd.ml @@ -124,7 +124,7 @@ let handle_policy_cmd t reply id = function Logs.debug (fun m -> m "insert policy %a" Name.pp id) ; let same_policy = match Vmm_resources.find_policy t.resources id with | None -> false - | Some p' -> eq_policy policy p' + | Some p' -> Policy.equal policy p' in if same_policy then Ok (t, [ reply (`String "no modification of policy") ], `Loop)