diff --git a/src/vmm_core.ml b/src/vmm_core.ml index 431ac8c..f56c20b 100644 --- a/src/vmm_core.ml +++ b/src/vmm_core.ml @@ -2,8 +2,6 @@ open Astring -open Rresult.R.Infix - let tmpdir = Fpath.(v "/var" / "run" / "albatross") let sockdir = Fpath.(tmpdir / "util") @@ -114,31 +112,8 @@ end 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 - ] - let eq_int (a : int) (b : 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 - - 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 t = { vms : int ; cpuids : IS.t ; @@ -209,22 +184,6 @@ module Vm = struct pp_image vm.vmimage Fmt.(option ~none:(unit "no") (list ~sep:(unit " ") string)) vm.argv - let vm_matches_res (res : Policy.t) (vm : config) = - res.Policy.vms >= 1 && IS.mem vm.cpuid res.Policy.cpuids && - vm.requested_memory <= res.Policy.memory && - List.for_all (fun nw -> String.Set.mem nw res.Policy.bridges) vm.network - - let check_policies vm res = - let rec climb = function - | super :: sub :: xs -> - if Policy.is_sub ~super ~sub then climb (sub :: xs) - else Error (`Msg "policy violation") - | [x] -> Ok x - | [] -> Error (`Msg "empty resource list") - in - climb res >>= fun res -> - if vm_matches_res res vm then Ok () else Error (`Msg "VM does not match policy") - type t = { config : config ; cmd : Bos.Cmd.t ; diff --git a/src/vmm_core.mli b/src/vmm_core.mli index d373af9..21364fb 100644 --- a/src/vmm_core.mli +++ b/src/vmm_core.mli @@ -71,11 +71,6 @@ module Vm : sig val pp_config : config Fmt.t - val vm_matches_res : Policy.t -> config -> bool - - val check_policies : - config -> Policy.t list -> (unit, [> `Msg of string ]) Result.result - type t = { config : config; cmd : Bos.Cmd.t; diff --git a/src/vmm_resources.ml b/src/vmm_resources.ml index 9bcefc8..fd36683 100644 --- a/src/vmm_resources.ml +++ b/src/vmm_resources.ml @@ -12,10 +12,15 @@ type res_entry = { let empty_res = { running_vms = 0 ; used_memory = 0 ; used_blockspace = 0 } +let vm_matches_res (res : Policy.t) (vm : Vm.config) = + res.Policy.vms >= 1 && IS.mem vm.Vm.cpuid res.Policy.cpuids && + vm.Vm.requested_memory <= res.Policy.memory && + List.for_all (fun nw -> String.Set.mem nw res.Policy.bridges) vm.Vm.network + let check_resource (p : Policy.t) (vm : Vm.config) (res : res_entry) = succ res.running_vms <= p.Policy.vms && res.used_memory + vm.Vm.requested_memory <= p.Policy.memory && - Vm.vm_matches_res p vm + vm_matches_res p vm let check_resource_policy (p : Policy.t) (res : res_entry) = res.running_vms <= p.Policy.vms && res.used_memory <= p.Policy.memory &&