Merge pull request xapi-project#238 from jonludlam/CA-229331-ely-bugfix

CA-229331: Fixes to compute_evacuation_plan

Author: robhoes

ocaml/idl/datamodel.ml

@@ -2884,25 +2884,11 @@ let host_get_vms_which_prevent_evacuation = call
     ~in_product_since:rel_orlando
     ~name:"get_vms_which_prevent_evacuation"
     ~doc:"Return a set of VMs which prevent the host being evacuated, with per-VM error codes"
-    ~lifecycle:[
-      Published, rel_orlando, "The call returns for each VM all the reasons why a host cannot be evacuated";
-      Changed, rel_ely, "The call now retuns only one reason per VM."
-    ]
     ~params:[Ref _host, "self", "The host to query"]
     ~result:(Map(Ref _vm, Set(String)), "VMs which block evacuation together with reasons")
     ~allowed_roles:_R_READ_ONLY
     ()
 
-let host_get_vms_which_prevent_evacuation_all = call
-    ~in_product_since:rel_ely
-    ~name:"get_vms_which_prevent_evacuation_all"
-    ~doc:"Return a set of VMs which prevent the host being evacuated, with per-VM error codes. This call returns for each VM all the reasons why a host cannot be evacuated."
-    ~params:[Ref _host, "self", "The host to query"]
-    ~hide_from_docs:true
-    ~result:(Map(Ref _vm, Set(String)), "VMs which block evacuation together with reasons")
-    ~allowed_roles:_R_READ_ONLY
-    ()
-
 let host_evacuate = call
     ~in_product_since:rel_miami
     ~name:"evacuate"
@@ -4857,7 +4843,6 @@ let host =
                 host_forget_data_source_archives;
                 host_assert_can_evacuate;
                 host_get_vms_which_prevent_evacuation;
-                host_get_vms_which_prevent_evacuation_all;
                 host_get_uncooperative_resident_VMs;
                 host_get_uncooperative_domains;
                 host_evacuate;

ocaml/xapi/cli_operations.ml

@@ -3170,10 +3170,7 @@ let host_evacuate printer rpc session_id params =
 let host_get_vms_which_prevent_evacuation printer rpc session_id params =
   let uuid = List.assoc "uuid" params in
   let host = Client.Host.get_by_uuid rpc session_id uuid in
-  (* Although the API call get_vms_which_prevent_evacuation was changed within CA-220610
-    to return per VM only one reason why the host cannot be evacuated, it was decided
-    the CLI call should still return all the reasons *)
-  let vms = Client.Host.get_vms_which_prevent_evacuation_all rpc session_id host in
+  let vms = Client.Host.get_vms_which_prevent_evacuation rpc session_id host in
 
   let op (vm, error) =
     let error = String.concat "," error in

ocaml/xapi/message_forwarding.ml

@@ -2278,10 +2278,6 @@ module Forward = functor(Local: Custom_actions.CUSTOM_ACTIONS) -> struct
       info "Host.get_vms_which_prevent_evacuation: host = '%s'" (host_uuid ~__context self);
       Local.Host.get_vms_which_prevent_evacuation ~__context ~self
 
-    let get_vms_which_prevent_evacuation_all ~__context ~self =
-      info "Host.get_vms_which_prevent_evacuation_all: host = '%s'" (host_uuid ~__context self);
-      Local.Host.get_vms_which_prevent_evacuation_all ~__context ~self
-
     let evacuate ~__context ~host =
       info "Host.evacuate: host = '%s'" (host_uuid ~__context host);
       (* Block call if this would break our VM restart plan (because the body of this sets enabled to false) *)

ocaml/xapi/xapi_host.ml

@@ -225,7 +225,7 @@ let compute_evacuation_plan_no_wlb ~__context ~host =
   then
     begin
       List.iter (fun (vm, _) ->
-          Hashtbl.add plans vm (Error (Api_errors.no_hosts_available, [ Ref.string_of vm ])))
+          Hashtbl.replace plans vm (Error (Api_errors.no_hosts_available, [ Ref.string_of vm ])))
         all_user_vms ;
       plans
     end
@@ -269,8 +269,8 @@ let compute_evacuation_plan_no_wlb ~__context ~host =
       let plan = Xapi_ha_vm_failover.compute_evacuation_plan ~__context (List.length all_hosts) target_hosts migratable_vms in
       (* Check if the plan was actually complete: if some VMs are missing it means there wasn't enough memory *)
       let vms_handled = List.map fst plan in
-      let vms_missing = List.filter (fun x -> not(List.mem x vms_handled)) (List.map fst protected_vms) in
-      List.iter (fun vm -> Hashtbl.add plans vm (Error (Api_errors.host_not_enough_free_memory, [ Ref.string_of vm ]))) vms_missing;
+      let vms_missing = List.filter (fun x -> not(List.mem x vms_handled)) (List.map fst migratable_vms) in
+      List.iter (fun vm -> Hashtbl.replace plans vm (Error (Api_errors.host_not_enough_free_memory, [ Ref.string_of vm ]))) vms_missing;
 
       (* Now for each VM we did place, verify storage and network visibility. *)
       List.iter (fun (vm, host) ->
@@ -279,7 +279,7 @@ let compute_evacuation_plan_no_wlb ~__context ~host =
             try Xapi_vm_helpers.assert_can_boot_here ~__context ~self:vm ~host ~snapshot ~do_memory_check:false ()
             with (Api_errors.Server_error (code, params)) -> Hashtbl.replace plans vm (Error (code, params))
           end;
-          if not(Hashtbl.mem plans vm) then Hashtbl.add plans vm (Migrate host)
+          if not(Hashtbl.mem plans vm) then Hashtbl.replace plans vm (Migrate host)
         ) plan;
       plans
     end
@@ -292,22 +292,10 @@ let assert_can_evacuate ~__context ~host =
   if errors <> []
   then raise (Api_errors.Server_error (Api_errors.cannot_evacuate_host, [ String.concat "|" errors ]))
 
-(* New Orlando style function which returns a Map *)
-let get_vms_which_prevent_evacuation_all ~__context ~self =
-  let plans = compute_evacuation_plan_no_wlb ~__context ~host:self in
-  Hashtbl.fold (fun vm plan acc -> match plan with Error(code, params) -> (vm, (code :: params)) :: acc | _ -> acc) plans []
-
 (* New Orlando style function which returns a Map *)
 let get_vms_which_prevent_evacuation ~__context ~self =
   let plans = compute_evacuation_plan_no_wlb ~__context ~host:self in
-  let get_error_per_vm vm plan acc =
-    match plan with
-    | Error(code, params) ->
-      if List.exists (fun (x,_) -> x = vm) acc then acc
-      else (vm, (code :: params)) :: acc
-    | _ -> acc
-  in
-  Hashtbl.fold get_error_per_vm plans []
+  Hashtbl.fold (fun vm plan acc -> match plan with Error(code, params) -> (vm, (code :: params)) :: acc | _ -> acc) plans []
 
 let compute_evacuation_plan_wlb ~__context ~self =
   (* We treat xapi as primary when it comes to "hard" errors, i.e. those that aren't down to memory constraints.  These are things like

ocaml/xapi/xapi_host.mli

@@ -42,9 +42,6 @@ val notify : __context:Context.t -> ty:string -> params:string -> unit
 val assert_can_evacuate : __context:Context.t -> host:API.ref_host -> unit
 val get_vms_which_prevent_evacuation :
   __context:Context.t -> self:API.ref_host -> (API.ref_VM * string list) list
-val get_vms_which_prevent_evacuation_all :
-  __context:Context.t -> self:API.ref_host -> (API.ref_VM * string list) list
-
 val evacuate : __context:Context.t -> host:API.ref_host -> unit
 val retrieve_wlb_evacuate_recommendations :
   __context:Context.t -> self:API.ref_host -> (API.ref_VM * string list) list