2018-11-02 23:05:10 +00:00
|
|
|
(* (c) 2017, 2018 Hannes Mehnert, all rights reserved *)
|
2017-05-26 14:30:34 +00:00
|
|
|
|
|
|
|
open Vmm_core
|
|
|
|
|
|
|
|
type res_entry = {
|
2018-04-03 20:58:31 +00:00
|
|
|
running_vms : int ;
|
|
|
|
used_memory : int ;
|
2018-11-10 00:02:07 +00:00
|
|
|
used_blockspace : int ;
|
2017-05-26 14:30:34 +00:00
|
|
|
}
|
|
|
|
|
2018-11-10 00:02:07 +00:00
|
|
|
let empty_res = { running_vms = 0 ; used_memory = 0 ; used_blockspace = 0 }
|
2017-05-26 14:30:34 +00:00
|
|
|
|
2018-10-12 18:34:00 +00:00
|
|
|
let check_resource (policy : policy) (vm : vm_config) (res : res_entry) =
|
2018-10-23 20:14:28 +00:00
|
|
|
succ res.running_vms <= policy.vms &&
|
|
|
|
res.used_memory + vm.requested_memory <= policy.memory &&
|
2018-10-12 23:05:21 +00:00
|
|
|
vm_matches_res policy vm
|
|
|
|
|
|
|
|
let check_resource_policy (policy : policy) (res : res_entry) =
|
2018-11-10 00:02:07 +00:00
|
|
|
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
|
2017-05-26 14:30:34 +00:00
|
|
|
|
|
|
|
type entry =
|
2018-10-12 23:05:21 +00:00
|
|
|
| Vm of vm
|
2018-11-10 00:02:07 +00:00
|
|
|
| Block of int * bool
|
2018-10-12 23:05:21 +00:00
|
|
|
| Policy of policy
|
|
|
|
|
2018-11-10 00:02:07 +00:00
|
|
|
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
|
|
|
|
|
2018-10-12 23:05:21 +00:00
|
|
|
type t = entry Vmm_trie.t
|
|
|
|
|
2018-10-28 18:04:24 +00:00
|
|
|
let pp ppf t =
|
|
|
|
Vmm_trie.fold [] t
|
2018-11-10 00:02:07 +00:00
|
|
|
(fun id ele () -> pp_entry id ppf ele) ()
|
2018-10-28 18:04:24 +00:00
|
|
|
|
2018-10-12 23:05:21 +00:00
|
|
|
let empty = Vmm_trie.empty
|
|
|
|
|
2018-11-10 00:02:07 +00:00
|
|
|
let fold t name f g h acc =
|
2018-10-12 23:05:21 +00:00
|
|
|
Vmm_trie.fold name t (fun prefix entry acc ->
|
|
|
|
match entry with
|
2018-10-22 23:02:14 +00:00
|
|
|
| Vm vm -> f prefix vm acc
|
2018-11-10 00:02:07 +00:00
|
|
|
| Policy p -> g prefix p acc
|
|
|
|
| Block (size, used) -> h prefix size used acc) acc
|
2018-10-12 23:05:21 +00:00
|
|
|
|
|
|
|
(* we should hide this type and confirm the following invariant:
|
|
|
|
- in case Vm, there are no siblings *)
|
|
|
|
|
|
|
|
let resource_usage t name =
|
2018-11-10 00:02:07 +00:00
|
|
|
Vmm_trie.fold name t (fun _ entry res ->
|
2018-10-12 23:05:21 +00:00
|
|
|
match entry with
|
2018-11-10 00:02:07 +00:00
|
|
|
| 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 })
|
2018-10-12 23:05:21 +00:00
|
|
|
empty_res
|
|
|
|
|
|
|
|
let find_vm t name = match Vmm_trie.find name t with
|
|
|
|
| Some (Vm vm) -> Some vm
|
2017-05-26 14:30:34 +00:00
|
|
|
| _ -> None
|
|
|
|
|
2018-10-28 18:41:06 +00:00
|
|
|
let find_policy t name = match Vmm_trie.find name t with
|
|
|
|
| Some (Policy p) -> Some p
|
|
|
|
| _ -> None
|
|
|
|
|
2018-11-10 00:02:07 +00:00
|
|
|
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))
|
|
|
|
|
2018-10-28 18:50:48 +00:00
|
|
|
let remove_vm t name = match find_vm t name with
|
|
|
|
| None -> Error (`Msg "unknown vm")
|
2018-11-10 00:02:07 +00:00
|
|
|
| Some vm -> set_block_usage false (Vmm_trie.remove name t) name vm
|
2018-10-28 18:50:48 +00:00
|
|
|
|
|
|
|
let remove_policy t name = match find_policy t name with
|
|
|
|
| None -> Error (`Msg "unknown policy")
|
|
|
|
| Some _ -> Ok (Vmm_trie.remove name t)
|
|
|
|
|
2018-11-10 00:02:07 +00:00
|
|
|
let remove_block t name = match find_block t name with
|
|
|
|
| None -> Error (`Msg "unknown block")
|
|
|
|
| Some _ -> Ok (Vmm_trie.remove name t)
|
|
|
|
|
2018-10-22 22:54:05 +00:00
|
|
|
let check_vm_policy t name vm =
|
|
|
|
let dom = domain name in
|
2018-10-12 23:05:21 +00:00
|
|
|
let res = resource_usage t dom in
|
|
|
|
match Vmm_trie.find dom t with
|
2018-10-29 16:14:51 +00:00
|
|
|
| None -> Ok true
|
|
|
|
| Some (Policy p) -> Ok (check_resource p vm res)
|
2018-11-10 00:02:07 +00:00
|
|
|
| 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
|
2018-10-12 23:05:21 +00:00
|
|
|
|
2018-10-22 22:54:05 +00:00
|
|
|
let insert_vm t name vm =
|
2018-10-29 16:14:51 +00:00
|
|
|
let open Rresult.R.Infix in
|
|
|
|
check_vm_policy t name vm.config >>= function
|
|
|
|
| false -> Error (`Msg "resource policy mismatch")
|
2018-11-10 00:02:07 +00:00
|
|
|
| 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")
|
2018-10-12 23:05:21 +00:00
|
|
|
|
|
|
|
let check_policy_above t name p =
|
|
|
|
let above = Vmm_trie.collect name t in
|
2018-11-02 23:05:10 +00:00
|
|
|
List.for_all (fun (id, node) -> match node with
|
2018-11-10 00:02:07 +00:00
|
|
|
| Policy p' -> is_sub ~super:p' ~sub:p
|
|
|
|
| x ->
|
|
|
|
Logs.err (fun m -> m "expected policy, found %a"
|
|
|
|
(pp_entry id) x) ;
|
|
|
|
false)
|
2018-10-12 23:05:21 +00:00
|
|
|
above
|
|
|
|
|
|
|
|
let check_policy_below t name p =
|
|
|
|
Vmm_trie.fold name t (fun name entry res ->
|
|
|
|
match name with
|
|
|
|
| [] -> res
|
|
|
|
| _ ->
|
|
|
|
match res, entry with
|
2018-11-02 23:05:10 +00:00
|
|
|
| Some p, Policy p' -> if is_sub ~super:p ~sub:p then Some p' else None
|
|
|
|
| Some p, Vm vm ->
|
2018-10-23 20:14:28 +00:00
|
|
|
let cfg = vm.config in
|
|
|
|
if IS.mem cfg.cpuid p.cpuids && good_bridge cfg.network p.bridges
|
2018-11-02 23:05:10 +00:00
|
|
|
then Some p
|
|
|
|
else None
|
2018-10-12 23:05:21 +00:00
|
|
|
| res, _ -> res)
|
2018-11-02 23:05:10 +00:00
|
|
|
(Some p)
|
2018-10-12 23:05:21 +00:00
|
|
|
|
|
|
|
let insert_policy t name p =
|
|
|
|
match
|
2018-11-02 23:05:10 +00:00
|
|
|
check_policy_above t (domain name) p,
|
2018-10-12 23:05:21 +00:00
|
|
|
check_policy_below t name p,
|
2018-11-02 23:05:10 +00:00
|
|
|
check_resource_policy p (resource_usage t name)
|
2018-10-12 23:05:21 +00:00
|
|
|
with
|
2018-11-02 23:05:10 +00:00
|
|
|
| true, Some _, true -> Ok (fst (Vmm_trie.insert name (Policy p) t))
|
2018-10-12 23:05:21 +00:00
|
|
|
| false, _, _ -> Error (`Msg "policy violates other policies above")
|
2018-11-02 23:05:10 +00:00
|
|
|
| _, None, _ -> Error (`Msg "policy violates other policies below")
|
2018-10-12 23:05:21 +00:00
|
|
|
| _, _, false -> Error (`Msg "more resources used than policy would allow")
|
2018-11-10 00:02:07 +00:00
|
|
|
|
|
|
|
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))
|