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

src/vmm_core.ml

@@ -35,6 +35,11 @@ module Name = struct
 
   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 =
     String.length s < 20 &&
     String.length s > 0 &&
@@ -139,20 +144,6 @@ module Policy = struct
       res.vms pp_is res.cpuids res.memory
       Fmt.(option ~none:(unit "no") int) res.block
       (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
 
 module Vm = struct

src/vmm_core.mli

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

src/vmm_resources.ml

@@ -2,182 +2,234 @@
 
 open Astring
 
+open Rresult.R.Infix
+
 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 =
-  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
   | None -> Ok t
   | Some block ->
     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")
-  | 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
   | 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
   | 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 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 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 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 }

src/vmm_resources.mli

@@ -11,55 +11,56 @@
     that Alice, Bob, and Charlie are able to run 2 virtual machines in total,
     rather than 2 each. *)
 
+open Vmm_core
+
 (** 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. *)
 val empty : t
 
 (** [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]. *)
-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]. *)
-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. *)
-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
     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
    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. *)
-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
     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]. *)
-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]. *)
-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]. *)
-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]. *)
 val pp : t Fmt.t

src/vmm_vmmd.ml

@@ -61,18 +61,7 @@ let handle_create t reply name vm_config =
    | Some _ -> Error (`Msg "VM with same name is already running")
    | None -> Ok ()) >>= fun () ->
   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, ... *)
   Vmm_unix.prepare name vm_config >>= fun 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 ],
       `Create (fun t task ->
           (* 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 ->
           Logs.debug (fun m -> m "exec()ed vm") ;
           Vmm_resources.insert_vm t.resources name vm >>= fun resources ->
@@ -134,10 +127,8 @@ let handle_policy_cmd t reply id = function
   | `Policy_info ->
     Logs.debug (fun m -> m "policy %a" Name.pp id) ;
     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 _ _ _ policies -> policies)
         []
     in
     match policies with
@@ -151,10 +142,8 @@ let handle_vm_cmd t reply id msg_to_err = function
   | `Vm_info ->
     Logs.debug (fun m -> m "info %a" Name.pp id) ;
     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 _ _ vms-> vms)
-        (fun _ _ _ vms -> vms)
         []
     in
     begin match vms with
@@ -172,20 +161,19 @@ let handle_vm_cmd t reply id msg_to_err = function
         | Error _ -> t.resources
         | Ok r -> r
       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
-        | 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
   | `Vm_destroy ->
     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
       | Some _ -> Error (`Msg "block device with same name already exists")
       | 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
   | `Block_info ->
     Logs.debug (fun m -> m "block %a" Name.pp id) ;
     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
     match blocks with