diff --git a/src/vmm_resources.ml b/src/vmm_resources.ml index 0bfdd3a..4df3791 100644 --- a/src/vmm_resources.ml +++ b/src/vmm_resources.ml @@ -36,8 +36,6 @@ let pp ppf t = let empty = Vmm_trie.empty -let remove t name = Vmm_trie.remove name t - let fold t name f g acc = Vmm_trie.fold name t (fun prefix entry acc -> match entry with @@ -62,6 +60,14 @@ let find_policy t name = match Vmm_trie.find name t with | Some (Policy p) -> Some p | _ -> None +let remove_vm t name = match find_vm t name with + | None -> Error (`Msg "unknown vm") + | Some _ -> Ok (Vmm_trie.remove name t) + +let remove_policy t name = match find_policy t name with + | None -> Error (`Msg "unknown policy") + | Some _ -> Ok (Vmm_trie.remove name t) + let check_vm_policy t name vm = let dom = domain name in let res = resource_usage t dom in diff --git a/src/vmm_resources.mli b/src/vmm_resources.mli index 607e6eb..a0eb877 100644 --- a/src/vmm_resources.mli +++ b/src/vmm_resources.mli @@ -35,8 +35,11 @@ val insert_vm : t -> Vmm_core.id -> Vmm_core.vm -> (t, [> `Msg of string]) resul the new [t] or an error. *) val insert_policy : t -> Vmm_core.id -> Vmm_core.policy -> (t, [> `Msg of string]) result -(** [remove t id] removes [id] from [t]. *) -val remove : t -> Vmm_core.id -> t +(** [remove_vm t id] removes vm [id] from [t]. *) +val remove_vm : t -> Vmm_core.id -> (t, [> `Msg of string ]) result + +(** [remove_policy t id] removes policy [id] from [t]. *) +val remove_policy : t -> Vmm_core.id -> (t, [> `Msg of string ]) result (** [fold t id f g acc] folds [f] and [g] below [id] over [t]. *) val fold : t -> Vmm_core.id -> diff --git a/src/vmm_vmmd.ml b/src/vmm_vmmd.ml index 33e813c..fd6cead 100644 --- a/src/vmm_vmmd.ml +++ b/src/vmm_vmmd.ml @@ -80,7 +80,12 @@ let handle_shutdown t name vm r = (match Vmm_unix.shutdown name vm with | Ok () -> () | Error (`Msg e) -> Logs.warn (fun m -> m "%s while shutdown vm %a" e pp_vm vm)) ; - let resources = Vmm_resources.remove t.resources name in + let resources = match Vmm_resources.remove_vm t.resources name with + | Error (`Msg e) -> + Logs.warn (fun m -> m "%s while removing vm %a from resources" e pp_vm vm) ; + t.resources + | Ok resources -> resources + in let header = Vmm_commands.{ version = t.wire_version ; sequence = t.stats_counter ; id = name } in let tasks = String.Map.remove (string_of_id name) t.tasks in let t = { t with stats_counter = Int64.succ t.stats_counter ; resources ; tasks } in @@ -103,7 +108,7 @@ let handle_command t (header, payload) = begin match pc with | `Policy_remove -> Logs.debug (fun m -> m "remove policy %a" pp_id header.Vmm_commands.id) ; - let resources = Vmm_resources.remove t.resources id in + Vmm_resources.remove_policy t.resources id >>= fun resources -> Ok ({ t with resources }, [ reply (`String "removed policy") ], `End) | `Policy_add policy -> Logs.debug (fun m -> m "insert policy %a" pp_id id) ; @@ -153,7 +158,7 @@ let handle_command t (header, payload) = | `Vm_create vm_config -> handle_create t header vm_config | `Vm_force_create vm_config -> - let resources = Vmm_resources.remove t.resources id in + Vmm_resources.remove_vm t.resources id >>= fun resources -> if Vmm_resources.check_vm_policy resources id vm_config then begin match Vmm_resources.find_vm t.resources id with | None -> handle_create t header vm_config