xenopsd: propagate missing CPUID feature to API error

Signed-off-by: Edwin Török <[email protected]>

ocaml/xapi-idl/xen/xenops_interface.ml

@@ -653,6 +653,27 @@ module XenopsAPI (R : RPC) = struct
         @-> returning (Param.mk Types.bool) err
         )
 
+    type compat_message = string option [@@deriving rpcty]
+
+    let is_compatible_msg =
+      let vm_policy_p =
+        Param.mk ~description:["VM CPU policy"] ~name:"vm_policy" CPU_policy.vm
+      in
+      let host_policy_p =
+        Param.mk ~description:["Host CPU policy"] ~name:"host_policy"
+          CPU_policy.host
+      in
+      declare "HOST.is_compatible"
+        [
+          "Check whether a VM can live-migrate to or resume on a host, and \
+           returns the reason why it cannot"
+        ]
+        (debug_info_p
+        @-> vm_policy_p
+        @-> host_policy_p
+        @-> returning (Param.mk compat_message) err
+        )
+
     let set_numa_affinity_policy =
       let numa_affinity_policy_p =
         Param.mk

ocaml/xapi/cpuid_helpers.ml

@@ -126,16 +126,22 @@ let assert_vm_is_compatible ~__context ~vm ~host ?remote () =
            features %s"
           (Xenops_interface.CPU_policy.to_string vm_cpu_features)
           (Xenops_interface.CPU_policy.to_string host_cpu_features) ;
-        if not (Xenopsd.HOST.is_compatible dbg vm_cpu_features host_cpu_features)
-        then (
-          debug
-            "VM CPU features (%s) are not compatible with host CPU features (%s)\n"
-            (Xenops_interface.CPU_policy.to_string vm_cpu_features)
-            (Xenops_interface.CPU_policy.to_string host_cpu_features) ;
-          fail
-            "VM last booted on a CPU with features this host's CPU does not \
-             have."
-        )
+        match
+          Xenopsd.HOST.is_compatible_msg dbg vm_cpu_features host_cpu_features
+        with
+        | None ->
+            ()
+        | Some missing ->
+            debug
+              "VM CPU features (%s) are not compatible with host CPU features \
+               (%s)\n"
+              (Xenops_interface.CPU_policy.to_string vm_cpu_features)
+              (Xenops_interface.CPU_policy.to_string host_cpu_features) ;
+            fail
+              ("VM last booted on a CPU with features this host's CPU does not \
+                have: "
+              ^ missing
+              )
       )
     with Not_found ->
       fail

ocaml/xenopsd/lib/xenops_server.ml

@@ -3486,7 +3486,18 @@ module HOST = struct
           (CPU_policy.to_string vm_policy)
           (CPU_policy.to_string host_policy) ;
         let module B = (val get_backend () : S) in
-        B.HOST.is_compatible vm_policy host_policy
+        B.HOST.is_compatible_msg vm_policy host_policy |> Option.is_none
+      )
+      ()
+
+  let is_compatible_msg _ dbg vm_policy host_policy =
+    Debug.with_thread_associated dbg
+      (fun () ->
+        debug "HOST.is_compatible_msg %s %s"
+          (CPU_policy.to_string vm_policy)
+          (CPU_policy.to_string host_policy) ;
+        let module B = (val get_backend () : S) in
+        B.HOST.is_compatible_msg vm_policy host_policy
       )
       ()
 end
@@ -4118,6 +4129,7 @@ let _ =
   Server.HOST.update_guest_agent_features (HOST.update_guest_agent_features ()) ;
   Server.HOST.combine_cpu_policies (HOST.combine_cpu_policies ()) ;
   Server.HOST.is_compatible (HOST.is_compatible ()) ;
+  Server.HOST.is_compatible_msg (HOST.is_compatible_msg ()) ;
   Server.VM.add (VM.add ()) ;
   Server.VM.remove (VM.remove ()) ;
   Server.VM.migrate (VM.migrate ()) ;

ocaml/xenopsd/lib/xenops_server_plugin.ml

@@ -68,7 +68,8 @@ module type S = sig
     val combine_cpu_policies :
       [`host] CPU_policy.t -> [`host] CPU_policy.t -> [`host] CPU_policy.t
 
-    val is_compatible : [`vm] CPU_policy.t -> [`host] CPU_policy.t -> bool
+    val is_compatible_msg :
+      [`vm] CPU_policy.t -> [`host] CPU_policy.t -> string option
   end
 
   module VM : sig

ocaml/xenopsd/lib/xenops_server_skeleton.ml

@@ -54,7 +54,7 @@ module HOST = struct
 
   let combine_cpu_policies _ _ = CPU_policy.of_string `host ""
 
-  let is_compatible _ _ = false
+  let is_compatible_msg _ _ = Some "unimplemented"
 end
 
 module VM = struct

ocaml/xenopsd/xc/xenops_server_xen.ml

@@ -1111,36 +1111,33 @@ module HOST = struct
     |> string_of_features
     |> CPU_policy.of_string `host
 
-  let is_compatible vm_policy host_policy =
+  let is_compatible_msg vm_policy host_policy =
     let open Cpuid in
     let is_compatible' vm host =
       let vm' = zero_extend vm (Array.length host) in
       let compatible = is_subset vm' host in
       if not compatible then
-        info
-          "The VM's CPU policy is not compatible with the target host's. The \
-           host is missing: %s"
-          (diff vm' host |> string_of_features) ;
-      compatible
+        Some (diff vm' host |> string_of_features)
+      else
+        None
     in
     let check v h =
-      try
-        match Xenctrlext.policy_is_compatible v h with
-        | None ->
-            true
-        | Some s ->
-            info
-              "The VM's CPU policy is not compatible with the target host's. \
-               The host is missing: %s"
-              s ;
-            false
+      try Xenctrlext.policy_is_compatible v h
       with Xenctrlext.Unix_error (Unix.ENOSYS, _) ->
         debug "policy_is_compatible: ENOSYS; fallback to OCaml implementation" ;
         is_compatible' v h
     in
     let vm = vm_policy |> CPU_policy.to_string |> features_of_string in
     let host = host_policy |> CPU_policy.to_string |> features_of_string in
-    check vm host
+    let msg = check vm host in
+    msg
+    |> Option.iter (fun s ->
+           info
+             "The VM's CPU policy is not compatible with the target host's. \
+              The host is missing: %s"
+             s
+       ) ;
+    msg
 end
 
 let dB_m = Mutex.create ()