reynir/albatross
1
0
Fork 0
Code Issues Pull requests Releases Wiki Activity

rework resources: now block, vms, and policies are in separate tries

Browse source
This commit is contained in:
Hannes Mehnert 2018-11-12 23:56:29 +01:00
parent b5c9cdea6a
commit 85372b0c7e
5 changed files with 251 additions and 224 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

19
src/vmm_core.ml
View file

@ -35,6 +35,11 @@ module Name = struct
let is_root x = x = [] let is_root x = x = []
let rec equal x y = match x, y with
| [], [] -> true
| x::xs, y::ys -> x = y && equal xs ys
| _ -> false
let [@inline always] valid_label s = let [@inline always] valid_label s =
String.length s < 20 && String.length s < 20 &&
String.length s > 0 && String.length s > 0 &&
@ -139,20 +144,6 @@ module Policy = struct
res.vms pp_is res.cpuids res.memory res.vms pp_is res.cpuids res.memory
Fmt.(option ~none:(unit "no") int) res.block Fmt.(option ~none:(unit "no") int) res.block
(String.Set.pp ~sep:Fmt.(unit ", ") Fmt.string) res.bridges (String.Set.pp ~sep:Fmt.(unit ", ") Fmt.string) res.bridges
let sub_block sub super =
match super, sub with
| None, None -> true
| Some _, None -> true
| Some x, Some y -> x >= y
| None, Some _ -> false
let is_sub ~super ~sub =
sub.vms <= super.vms &&
sub.memory <= super.memory &&
IS.subset sub.cpuids super.cpuids &&
String.Set.subset sub.bridges super.bridges &&
sub_block sub.block super.block
end end
module Vm = struct module Vm = struct

3
src/vmm_core.mli
View file

@ -17,6 +17,7 @@ module Name : sig
type t type t
val is_root : t -> bool val is_root : t -> bool
val equal : t -> t -> bool
val image_file : t -> Fpath.t val image_file : t -> Fpath.t
val fifo_file : t -> Fpath.t val fifo_file : t -> Fpath.t
@ -50,8 +51,6 @@ module Policy : sig
val equal : t -> t -> bool val equal : t -> t -> bool
val pp : t Fmt.t val pp : t Fmt.t
val is_sub : super:t -> sub:t -> bool
end end
module Vm : sig module Vm : sig

346
src/vmm_resources.ml
View file

@ -2,182 +2,234 @@
open Astring open Astring
open Rresult.R.Infix
open Vmm_core open Vmm_core
type res_entry = { let flipped_set_mem set s = String.Set.mem s set
running_vms : int ;
used_memory : int ; type t = {
used_blockspace : int ; policies : Policy.t Vmm_trie.t ;
block_devices : (int * bool) Vmm_trie.t ;
unikernels : Vm.t Vmm_trie.t ;
} }
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_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 &&
match p.Policy.block with
| None -> res.used_blockspace = 0
| Some mb -> res.used_blockspace <= mb
type entry =
| Vm of Vm.t
| Block of int * bool
| Policy of Policy.t
let pp_entry id ppf = function
| Vm vm -> Fmt.pf ppf "vm %a: %a@." Name.pp id Vm.pp_config vm.Vm.config
| 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
let pp ppf t = let pp ppf t =
Vmm_trie.fold Name.root t Vmm_trie.fold Name.root t.policies
(fun id ele () -> pp_entry id ppf ele) () (fun id p () ->
Fmt.pf ppf "policy %a: %a@." Name.pp id Policy.pp p) () ;
Vmm_trie.fold Name.root t.block_devices
(fun id (size, used) () ->
Fmt.pf ppf "block device %a: %dMB (used %B)@." Name.pp id size used) () ;
Vmm_trie.fold Name.root t.unikernels
(fun id vm () ->
Fmt.pf ppf "vm %a: %a@." Name.pp id Vm.pp_config vm.Vm.config) ()
let empty = Vmm_trie.empty let empty = {
policies = Vmm_trie.empty ;
block_devices = Vmm_trie.empty ;
unikernels = Vmm_trie.empty
}
let fold t name f g h acc = (* we should confirm the following invariant: Vm or Block have no siblings *)
Vmm_trie.fold name t (fun prefix entry acc ->
match entry with
| Vm vm -> f prefix vm 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: let block_usage t name =
- in case Vm, there are no siblings *) Vmm_trie.fold name t.block_devices
(fun _ (size, _) blockspace -> blockspace + size)
0
let resource_usage t name = let vm_usage t name =
Vmm_trie.fold name t (fun _ entry res -> Vmm_trie.fold name t.unikernels
match entry with (fun _ vm (vms, memory) -> (succ vms, memory + vm.Vm.config.Vm.requested_memory))
| Policy _ -> res (0, 0)
| Block (size, _) -> { res with used_blockspace = res.used_blockspace + size }
| Vm vm ->
{ res with running_vms = succ res.running_vms ;
used_memory = vm.Vm.config.Vm.requested_memory + res.used_memory })
empty_res
let find_vm t name = match Vmm_trie.find name t with let find_vm t name = Vmm_trie.find name t.unikernels
| Some (Vm vm) -> Some vm
| _ -> None
let find_policy t name = match Vmm_trie.find name t with let find_policy t name = Vmm_trie.find name t.policies
| Some (Policy p) -> Some p
| _ -> None
let find_block t name = match Vmm_trie.find name t with let find_block t name = Vmm_trie.find name t.block_devices
| Some (Block (size, active)) -> Some (size, active)
| _ -> None
let set_block_usage active t name vm = let set_block_usage t name active =
match Vmm_trie.find name t 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 name (size, active) t))
let maybe_use_block t name vm active =
match vm.Vm.config.Vm.block_device with match vm.Vm.config.Vm.block_device with
| None -> Ok t | None -> Ok t
| Some block -> | Some block ->
let block_name = Name.block_name name block in let block_name = Name.block_name name block in
match find_block t block_name with set_block_usage t block_name active
| 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 let remove_vm t name = match find_vm t name with
| None -> Error (`Msg "unknown vm") | None -> Error (`Msg "unknown vm")
| Some vm -> set_block_usage false (Vmm_trie.remove name t) name vm | Some vm ->
maybe_use_block t.block_devices name vm false >>| fun block_devices ->
let unikernels = Vmm_trie.remove name t.unikernels in
{ t with block_devices ; unikernels }
let remove_policy t name = match find_policy t name with let remove_policy t name = match find_policy t name with
| None -> Error (`Msg "unknown policy") | None -> Error (`Msg "unknown policy")
| Some _ -> Ok (Vmm_trie.remove name t) | Some _ ->
let policies = Vmm_trie.remove name t.policies in
Ok { t with policies }
let remove_block t name = match find_block t name with let remove_block t name = match find_block t name with
| None -> Error (`Msg "unknown block") | None -> Error (`Msg "unknown block")
| Some _ -> Ok (Vmm_trie.remove name t) | Some (_, active) ->
if active then
Error (`Msg "block device in use")
else
let block_devices = Vmm_trie.remove name t.block_devices in
Ok { t with block_devices }
let check_vm_policy t name vm = let check_policy (p : Policy.t) (running_vms, used_memory) (vm : Vm.config) =
let dom = Name.domain name in if succ running_vms > p.Policy.vms then
let res = resource_usage t dom in Error (`Msg "maximum amount of unikernels reached")
match Vmm_trie.find dom t with else if vm.Vm.requested_memory > p.Policy.memory - used_memory then
| None -> Ok true Error (`Msg "maximum allowed memory reached")
| Some (Policy p) -> Ok (check_resource p vm res) else if not (IS.mem vm.Vm.cpuid p.Policy.cpuids) then
| Some x -> Error (`Msg "CPUid is not allowed by policy")
Logs.err (fun m -> m "id %a, expected policy, got %a" Name.pp dom (pp_entry dom) x) ; else if not (List.for_all (flipped_set_mem p.Policy.bridges) vm.Vm.network) then
Rresult.R.error_msgf "expected policy for %a" Name.pp dom Error (`Msg "network not allowed by policy")
else Ok ()
let check_vm t name vm =
let policy_ok =
let dom = Name.domain name in
match find_policy t dom with
| None -> Ok ()
| Some p ->
let used = vm_usage t dom in
check_policy p used vm
and block_ok = match vm.Vm.block_device with
| None -> Ok ()
| Some block ->
let block_name = Name.block_name name block in
match find_block t block_name with
| None -> Error (`Msg "block device not found")
| Some (_, active) ->
if active then
Error (`Msg "block device already in use")
else
Ok ()
and vm_ok = match find_vm t name with
| None -> Ok ()
| Some _ -> Error (`Msg "vm with same name already exists")
in
policy_ok >>= fun () ->
block_ok >>= fun () ->
vm_ok
let insert_vm t name vm = let insert_vm t name vm =
let open Rresult.R.Infix in check_vm t name vm.Vm.config >>= fun () ->
check_vm_policy t name vm.Vm.config >>= function match Vmm_trie.insert name vm t.unikernels with
| false -> Error (`Msg "resource policy mismatch") | unikernels, None ->
| true -> match Vmm_trie.insert name (Vm vm) t with maybe_use_block t.block_devices name vm true >>| fun block_devices ->
| t', None -> set_block_usage true t' name vm { t with unikernels ; block_devices }
| _, Some _ -> Error (`Msg "vm already exists") | _, Some _ -> Error (`Msg "vm already exists")
let check_policy_above t name p = let check_block t name size =
let above = Vmm_trie.collect name t in let block_ok = match find_block t name with
List.for_all (fun (id, node) -> match node with | Some _ -> Error (`Msg "block device with same name already exists")
| Policy p' -> Policy.is_sub ~super:p' ~sub:p | None -> Ok ()
| x -> and policy_ok =
Logs.err (fun m -> m "expected policy, found %a"
(pp_entry id) x) ;
false)
above
let check_policy_below t name p =
Vmm_trie.fold name t (fun name entry res ->
if Name.is_root name then
res
else
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.Vm.config in
if
IS.mem cfg.Vm.cpuid p.Policy.cpuids &&
List.for_all (fun net -> String.Set.mem net p.Policy.bridges) cfg.Vm.network
then Some p
else None
| _, res -> res)
(Some p)
let insert_policy t name p =
match
check_policy_above t (Name.domain name) p,
check_policy_below t name p,
check_resource_policy p (resource_usage t name)
with
| true, Some _, true -> Ok (fst (Vmm_trie.insert name (Policy p) t))
| 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 = Name.domain name in let dom = Name.domain name in
let res = resource_usage t dom in match find_policy t dom with
let res' = { res with used_blockspace = res.used_blockspace + size } in | None -> Ok ()
match Vmm_trie.find dom t with | Some p ->
| None -> Ok true let used = block_usage t dom in
| Some (Policy p) -> Ok (check_resource_policy p res') match p.Policy.block with
| Some x -> | None -> Error (`Msg "no block devices are allowed by policy")
Logs.err (fun m -> m "id %a, expected policy, got %a" Name.pp dom (pp_entry dom) x) ; | Some limit ->
Rresult.R.error_msgf "expected policy for %a" Name.pp dom if size <= limit - used then
Ok ()
else
Error (`Msg "block device policy limit reached")
in
block_ok >>= fun () ->
policy_ok
let insert_block t name size = let insert_block t name size =
let open Rresult.R.Infix in check_block t name size >>= fun () ->
check_block_policy t name size >>= function let block_devices = fst (Vmm_trie.insert name (size, false) t.block_devices) in
| false -> Error (`Msg "resource policy mismatch") Ok { t with block_devices }
| true -> Ok (fst (Vmm_trie.insert name (Block (size, false)) t))
let sub_policy ~super ~sub =
let sub_block sub super =
match super, sub with
| None, None -> true
| Some _, None -> true
| Some x, Some y -> x >= y
| None, Some _ -> false
in
if super.Policy.vms < sub.Policy.vms then
Error (`Msg "policy above allows fewer unikernels")
else if super.Policy.memory < sub.Policy.memory then
Error (`Msg "policy above allows fewer memory")
else if not (IS.subset sub.Policy.cpuids super.Policy.cpuids) then
Error (`Msg "policy above allows fewer cpuids")
else if not (String.Set.subset sub.Policy.bridges super.Policy.bridges) then
Error (`Msg "policy above allows fewer bridges")
else if not (sub_block sub.Policy.block super.Policy.block) then
Error (`Msg "policy above allows fewer block storage")
else
Ok ()
let check_policies_above t name sub =
let rec go prefix =
if Name.is_root prefix then
Ok ()
else
match find_policy t prefix with
| None -> go (Name.domain prefix)
| Some super ->
sub_policy ~super ~sub >>= fun () ->
go (Name.domain prefix)
in
go (Name.domain name)
let check_policies_below t curname super =
Vmm_trie.fold curname t.policies (fun name policy res ->
res >>= fun () ->
if Name.equal curname name then
res
else
sub_policy ~super ~sub:policy)
(Ok ())
let check_vms t name p =
let (vms, used_memory) = vm_usage t name
and block = block_usage t name
in
let bridges, cpuids =
Vmm_trie.fold name t.unikernels
(fun _ vm (bridges, cpuids) ->
let config = vm.Vm.config in
(String.Set.(union (of_list config.Vm.network) bridges), IS.add config.Vm.cpuid cpuids))
(String.Set.empty, IS.empty)
in
let policy_block = match p.Policy.block with None -> 0 | Some x -> x in
if not (IS.subset cpuids p.Policy.cpuids) then
Error (`Msg "used CPUid is not allowed by policy")
else if not (String.Set.subset bridges p.Policy.bridges) then
Error (`Msg "used network not allowed by policy")
else if vms > p.Policy.vms then
Error (`Msg "policy would not allow amount of running unikernels")
else if used_memory > p.Policy.memory then
Error (`Msg "policy would not allow used memory")
else if block > policy_block then
Error (`Msg "policy would not allow used block storage")
else
Ok ()
let insert_policy t name p =
check_policies_above t name p >>= fun () ->
check_policies_below t name p >>= fun () ->
check_vms t name p >>= fun () ->
let policies = fst (Vmm_trie.insert name p t.policies) in
Ok { t with policies }

41
src/vmm_resources.mli
View file

@ -11,55 +11,56 @@
that Alice, Bob, and Charlie are able to run 2 virtual machines in total, that Alice, Bob, and Charlie are able to run 2 virtual machines in total,
rather than 2 each. *) rather than 2 each. *)
open Vmm_core
(** The type of the resource tree. *) (** The type of the resource tree. *)
type t type t = private {
policies : Policy.t Vmm_trie.t ;
block_devices : (int * bool) Vmm_trie.t ;
unikernels : Vm.t Vmm_trie.t ;
}
(** [empty] is the empty tree. *) (** [empty] is the empty tree. *)
val empty : t val empty : t
(** [find_vm t id] is either [Some vm] or [None]. *) (** [find_vm t id] is either [Some vm] or [None]. *)
val find_vm : t -> Vmm_core.Name.t -> Vmm_core.Vm.t option val find_vm : t -> Name.t -> Vm.t option
(** [find_policy t Name.t] is either [Some policy] or [None]. *) (** [find_policy t Name.t] is either [Some policy] or [None]. *)
val find_policy : t -> Vmm_core.Name.t -> Vmm_core.Policy.t option val find_policy : t -> Name.t -> Policy.t option
(** [find_block t Name.t] is either [Some (size, active)] or [None]. *) (** [find_block t Name.t] is either [Some (size, active)] or [None]. *)
val find_block : t -> Vmm_core.Name.t -> (int * bool) option val find_block : t -> Name.t -> (int * bool) option
(** [check_vm_policy t Name.t vm] checks whether [vm] under [Name.t] in [t] would be (** [check_vm t Name.t vm] checks whether [vm] under [Name.t] in [t] would be
allowed under the current policies. *) allowed under the current policies. *)
val check_vm_policy : t -> Vmm_core.Name.t -> Vmm_core.Vm.config -> (bool, [> `Msg of string ]) result val check_vm : t -> Name.t -> Vm.config -> (unit, [> `Msg of string ]) result
(** [insert_vm t Name.t vm] inserts [vm] under [Name.t] in [t], and returns the new [t] or (** [insert_vm t Name.t vm] inserts [vm] under [Name.t] in [t], and returns the new [t] or
an error. *) an error. *)
val insert_vm : t -> Vmm_core.Name.t -> Vmm_core.Vm.t -> (t, [> `Msg of string]) result val insert_vm : t -> Name.t -> Vm.t -> (t, [> `Msg of string]) result
(** [insert_policy t Name.t policy] inserts [policy] under [Name.t] in [t], and returns (** [insert_policy t Name.t policy] inserts [policy] under [Name.t] in [t], and returns
the new [t] or an error. *) the new [t] or an error. *)
val insert_policy : t -> Vmm_core.Name.t -> Vmm_core.Policy.t -> (t, [> `Msg of string]) result val insert_policy : t -> Name.t -> Policy.t -> (t, [> `Msg of string]) result
(** [check_block_policy t Name.t size] checks whether [size] under [Name.t] in [t] would be (** [check_block t Name.t size] checks whether [size] under [Name.t] in [t] would be
allowed under the current policies. *) allowed under the current policies. *)
val check_block_policy : t -> Vmm_core.Name.t -> int -> (bool, [> `Msg of string ]) result val check_block : t -> Name.t -> int -> (unit, [> `Msg of string ]) result
(** [insert_block t Name.t size] inserts [size] under [Name.t] in [t], and returns the new [t] or (** [insert_block t Name.t size] inserts [size] under [Name.t] in [t], and returns the new [t] or
an error. *) an error. *)
val insert_block : t -> Vmm_core.Name.t -> int -> (t, [> `Msg of string]) result val insert_block : t -> Name.t -> int -> (t, [> `Msg of string]) result
(** [remove_vm t Name.t] removes vm [Name.t] from [t]. *) (** [remove_vm t Name.t] removes vm [Name.t] from [t]. *)
val remove_vm : t -> Vmm_core.Name.t -> (t, [> `Msg of string ]) result val remove_vm : t -> Name.t -> (t, [> `Msg of string ]) result
(** [remove_policy t Name.t] removes policy [Name.t] from [t]. *) (** [remove_policy t Name.t] removes policy [Name.t] from [t]. *)
val remove_policy : t -> Vmm_core.Name.t -> (t, [> `Msg of string ]) result val remove_policy : t -> Name.t -> (t, [> `Msg of string ]) result
(** [remove_block t Name.t] removes block [Name.t] from [t]. *) (** [remove_block t Name.t] removes block [Name.t] from [t]. *)
val remove_block : t -> Vmm_core.Name.t -> (t, [> `Msg of string ]) result val remove_block : t -> 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.t -> '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]. *) (** [pp] is a pretty printer for [t]. *)
val pp : t Fmt.t val pp : t Fmt.t

66
src/vmm_vmmd.ml
View file

@ -61,18 +61,7 @@ let handle_create t reply name vm_config =
| Some _ -> Error (`Msg "VM with same name is already running") | Some _ -> Error (`Msg "VM with same name is already running")
| None -> Ok ()) >>= fun () -> | None -> Ok ()) >>= fun () ->
Logs.debug (fun m -> m "now checking resource policies") ; Logs.debug (fun m -> m "now checking resource policies") ;
(Vmm_resources.check_vm_policy t.resources name vm_config >>= function Vmm_resources.check_vm t.resources name vm_config >>= fun () ->
| false -> Error (`Msg "resource policies don't allow creation of this VM")
| true -> Ok ()) >>= fun () ->
(match vm_config.Vm.block_device with
| None -> Ok None
| Some dev ->
let block_device_name = Name.block_name name dev in
Logs.debug (fun m -> m "looking for block device %a" Name.pp 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, ... *) (* prepare VM: save VM image to disk, create fifo, ... *)
Vmm_unix.prepare name vm_config >>= fun taps -> Vmm_unix.prepare name vm_config >>= fun taps ->
Logs.debug (fun m -> m "prepared vm with taps %a" Fmt.(list ~sep:(unit ",@ ") string) taps) ; Logs.debug (fun m -> m "prepared vm with taps %a" Fmt.(list ~sep:(unit ",@ ") string) taps) ;
@ -84,6 +73,10 @@ let handle_create t reply name vm_config =
[ `Cons cons_out ], [ `Cons cons_out ],
`Create (fun t task -> `Create (fun t task ->
(* actually execute the vm *) (* actually execute the vm *)
let block_device = match vm_config.Vm.block_device with
| None -> None
| Some block -> Some (Name.block_name name block)
in
Vmm_unix.exec name vm_config taps block_device >>= fun vm -> Vmm_unix.exec name vm_config taps block_device >>= fun vm ->
Logs.debug (fun m -> m "exec()ed vm") ; Logs.debug (fun m -> m "exec()ed vm") ;
Vmm_resources.insert_vm t.resources name vm >>= fun resources -> Vmm_resources.insert_vm t.resources name vm >>= fun resources ->
@ -134,10 +127,8 @@ let handle_policy_cmd t reply id = function
| `Policy_info -> | `Policy_info ->
Logs.debug (fun m -> m "policy %a" Name.pp id) ; Logs.debug (fun m -> m "policy %a" Name.pp id) ;
let policies = let policies =
Vmm_resources.fold t.resources id Vmm_trie.fold id t.resources.Vmm_resources.policies
(fun _ _ policies -> policies)
(fun prefix policy policies-> (prefix, policy) :: policies) (fun prefix policy policies-> (prefix, policy) :: policies)
(fun _ _ _ policies -> policies)
[] []
in in
match policies with match policies with
@ -151,10 +142,8 @@ let handle_vm_cmd t reply id msg_to_err = function
| `Vm_info -> | `Vm_info ->
Logs.debug (fun m -> m "info %a" Name.pp id) ; Logs.debug (fun m -> m "info %a" Name.pp id) ;
let vms = let vms =
Vmm_resources.fold t.resources id Vmm_trie.fold id t.resources.Vmm_resources.unikernels
(fun id vm vms -> (id, vm.Vm.config) :: vms) (fun id vm vms -> (id, vm.Vm.config) :: vms)
(fun _ _ vms-> vms)
(fun _ _ _ vms -> vms)
[] []
in in
begin match vms with begin match vms with
@ -172,20 +161,19 @@ let handle_vm_cmd t reply id msg_to_err = function
| Error _ -> t.resources | Error _ -> t.resources
| Ok r -> r | Ok r -> r
in in
Vmm_resources.check_vm_policy resources id vm_config >>= function Vmm_resources.check_vm resources id vm_config >>= fun () ->
| false -> Error (`Msg "wouldn't match policy") match Vmm_resources.find_vm t.resources id with
| 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 = Name.to_string id in
match String.Map.find_opt id_str t.tasks with
| None -> handle_create t reply id vm_config | None -> handle_create t reply id vm_config
| Some vm -> | Some task ->
Vmm_unix.destroy vm ; let tasks = String.Map.remove id_str t.tasks in
let id_str = Name.to_string id in let t = { t with tasks } in
match String.Map.find_opt id_str t.tasks with Ok (t, [], `Wait_and_create
| None -> handle_create t reply id vm_config (task, fun t -> msg_to_err @@ 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 end
| `Vm_destroy -> | `Vm_destroy ->
match Vmm_resources.find_vm t.resources id with match Vmm_resources.find_vm t.resources id with
@ -219,20 +207,16 @@ let handle_block_cmd t reply id = function
match Vmm_resources.find_block t.resources id with match Vmm_resources.find_block t.resources id with
| Some _ -> Error (`Msg "block device with same name already exists") | Some _ -> Error (`Msg "block device with same name already exists")
| None -> | None ->
Vmm_resources.check_block_policy t.resources id size >>= function Vmm_resources.check_block t.resources id size >>= fun () ->
| false -> Error (`Msg "adding block device would violate policy") Vmm_unix.create_block id size >>= fun () ->
| true -> Vmm_resources.insert_block t.resources id size >>= fun resources ->
Vmm_unix.create_block id size >>= fun () -> Ok ({ t with resources }, [ reply (`String "added block device") ], `Loop)
Vmm_resources.insert_block t.resources id size >>= fun resources ->
Ok ({ t with resources }, [ reply (`String "added block device") ], `Loop)
end end
| `Block_info -> | `Block_info ->
Logs.debug (fun m -> m "block %a" Name.pp id) ; Logs.debug (fun m -> m "block %a" Name.pp id) ;
let blocks = let blocks =
Vmm_resources.fold t.resources id Vmm_trie.fold id t.resources.Vmm_resources.block_devices
(fun _ _ blocks -> blocks) (fun prefix (size, active) blocks -> (prefix, size, active) :: blocks)
(fun _ _ blocks-> blocks)
(fun prefix size active blocks -> (prefix, size, active) :: blocks)
[] []
in in
match blocks with match blocks with