Merge pull request xapi-project#4469 from lippirk/private/bena/UPD-750

[stockholm] backports

Author: Ben Anson

ocaml/xapi-consts/constants.ml

@@ -181,6 +181,8 @@ let hvm_boot_policy_bios_order = "BIOS order"
    Value is the boot string we send to qemu-dm (eg cd, dc, dcn, etc) *)
 let hvm_boot_params_order = "order"
 
+let hvm_default_boot_order = "cd"
+
 (* Key we put in VM.other_config when we upgrade a VM from Zurich/Geneva to Rio *)
 let vm_upgrade_time = "upgraded at"
 

ocaml/xapi/import_xva.ml

@@ -72,7 +72,13 @@ let make __context rpc session_id srid (vms, vdis) =
             other_platform
       in
       let hVM_boot_policy = if vm.is_hvm then "BIOS order" else "" in
-      let hVM_boot_params = if vm.is_hvm then [("order", "cd")] else [] in
+      let hVM_boot_params =
+        if vm.is_hvm then
+          let open Constants in
+          [(hvm_boot_params_order, hvm_default_boot_order)]
+        else
+          []
+      in
       let domain_type = Xapi_vm_helpers.derive_domain_type ~hVM_boot_policy in
       let vm_ref =
         Client.VM.create ~rpc ~session_id ~name_label:(vm.vm_name ^ " import")

ocaml/xapi/xapi_cluster.ml

@@ -84,7 +84,9 @@ let create ~__context ~pIF ~cluster_stack ~pool_auto_join ~token_timeout
           set_ha_cluster_stack ~__context ;
           cluster_ref
       | Error error ->
-          D.warn "Error occurred during Cluster.create" ;
+          D.warn
+            "Error occurred during Cluster.create. Shutting down cluster daemon" ;
+          Xapi_clustering.Daemon.disable ~__context ;
           handle_error error)
 
 let destroy ~__context ~self =
@@ -119,30 +121,6 @@ let get_network ~__context ~self = get_network_internal ~__context ~self
 (** Cluster.pool* functions are convenience wrappers for iterating low-level APIs over a pool.
     Concurrency checks are done in the implementation of these calls *)
 
-let pool_create ~__context ~network ~cluster_stack ~token_timeout
-    ~token_timeout_coefficient =
-  validate_params ~token_timeout ~token_timeout_coefficient ;
-  let master = Helpers.get_master ~__context in
-  let slave_hosts = Xapi_pool_helpers.get_slaves_list ~__context in
-  let pIF, _ = pif_of_host ~__context network master in
-  let cluster =
-    Helpers.call_api_functions ~__context (fun rpc session_id ->
-        Client.Client.Cluster.create ~rpc ~session_id ~pIF ~cluster_stack
-          ~pool_auto_join:true ~token_timeout ~token_timeout_coefficient)
-  in
-  List.iter
-    (fun host ->
-      (* Cluster.create already created cluster_host on master, so we only iterate through slaves *)
-      Helpers.call_api_functions ~__context (fun rpc session_id ->
-          let pif, _ = pif_of_host ~__context network host in
-          let cluster_host_ref =
-            Client.Client.Cluster_host.create ~rpc ~session_id ~cluster ~host
-              ~pif
-          in
-          D.debug "Created Cluster_host: %s" (Ref.string_of cluster_host_ref)))
-    slave_hosts ;
-  cluster
-
 let foreach_cluster_host ~__context ~self
     ~(fn :
           rpc:(Rpc.call -> Rpc.response)
@@ -212,6 +190,42 @@ let pool_destroy ~__context ~self =
   Helpers.call_api_functions ~__context (fun rpc session_id ->
       Client.Client.Cluster.destroy ~rpc ~session_id ~self)
 
+let pool_create ~__context ~network ~cluster_stack ~token_timeout
+    ~token_timeout_coefficient =
+  validate_params ~token_timeout ~token_timeout_coefficient ;
+  let master = Helpers.get_master ~__context in
+  let slave_hosts = Xapi_pool_helpers.get_slaves_list ~__context in
+  let pIF, _ = pif_of_host ~__context network master in
+  let cluster =
+    Helpers.call_api_functions ~__context (fun rpc session_id ->
+        Client.Client.Cluster.create ~rpc ~session_id ~pIF ~cluster_stack
+          ~pool_auto_join:true ~token_timeout ~token_timeout_coefficient)
+  in
+  try
+    List.iter
+      (fun host ->
+        (* Cluster.create already created cluster_host on master, so we only iterate through slaves *)
+        Helpers.call_api_functions ~__context (fun rpc session_id ->
+            let pif, _ = pif_of_host ~__context network host in
+            let cluster_host_ref =
+              Client.Client.Cluster_host.create ~rpc ~session_id ~cluster ~host
+                ~pif
+            in
+            D.debug "Created Cluster_host: %s" (Ref.string_of cluster_host_ref)))
+      slave_hosts ;
+    cluster
+  with e ->
+    error "pool_create failed. exception='%s'" (Printexc.to_string e) ;
+    info "pool_create attempting cleanup of cluster=%s"
+      (Ref.short_string_of cluster) ;
+    ( try pool_force_destroy ~__context ~self:cluster
+      with e ->
+        error "pool_create attempt to clean up cluster=%s failed. ex='%s'"
+          (Ref.short_string_of cluster)
+          (Printexc.to_string e)
+    ) ;
+    raise e
+
 let pool_resync ~__context ~(self : API.ref_Cluster) =
   List.iter
     (fun host ->

ocaml/xapi/xapi_vm_lifecycle.ml

@@ -821,10 +821,13 @@ let force_state_reset_keep_current_operations ~__context ~self ~value:state =
            Db.VGPU.set_scheduled_to_be_resident_on ~__context ~self:vgpu
              ~value:Ref.null ;
            Db.VGPU.set_PCI ~__context ~self:vgpu ~value:Ref.null) ;
-    (* release PCIs *)
-    List.iter
-      (fun pci -> Db.PCI.remove_attached_VMs ~__context ~self:pci ~value:self)
-      (Db.VM.get_attached_PCIs ~__context ~self) ;
+    Db.VM.get_attached_PCIs ~__context ~self
+    |> List.iter (fun pci ->
+           if Db.is_valid_ref __context pci then
+             Db.PCI.remove_attached_VMs ~__context ~self:pci ~value:self
+           else
+             (* XSI-995 pci does not exist, so remove it from the vm record *)
+             Db.VM.remove_attached_PCIs ~__context ~self ~value:pci) ;
     List.iter
       (fun pci ->
         (* The following should not be necessary if many-to-many relations in the DB

ocaml/xapi/xapi_xenops.ml

@@ -195,6 +195,14 @@ let find f map default feature =
 
 let string = find (fun x -> x)
 
+let assume_default_if_null_empty map default feature =
+  match List.assoc_opt feature map with
+  | None | Some "" ->
+      D.info "assuming default setting %s=%s" feature default ;
+      default
+  | Some x ->
+      x
+
 let int = find int_of_string
 
 let bool = find (function "1" -> true | "0" -> false | x -> bool_of_string x)
@@ -398,7 +406,12 @@ let builder_of_vm ~__context (vmref, vm) timeoffset pci_passthrough vgpu =
     ; vnc_ip= None (*None PR-1255*)
     ; pci_emulations
     ; pci_passthrough
-    ; boot_order= string vm.API.vM_HVM_boot_params "cd" "order"
+    ; boot_order=
+        (* XSI-804 avoid boot orders which are the empty string, as qemu
+         * will silently fail to start the VM *)
+        (let open Constants in
+        assume_default_if_null_empty vm.API.vM_HVM_boot_params
+          hvm_default_boot_order hvm_boot_params_order)
     ; qemu_disk_cmdline= bool vm.API.vM_platform false "qemu_disk_cmdline"
     ; qemu_stubdom= false
     ; (* Obsolete: implementation removed *)

scripts/bugtool-plugin/xapi/stuff.xml

@@ -6,6 +6,5 @@
 <command label="diagnostic_db_stats">@BINDIR@/xe diagnostic-db-stats</command>
 <command label="diagnostic_net_stats">@BINDIR@/xe diagnostic-net-stats</command>
 <command label="host_data_source_list">@BINDIR@/xe host-data-source-list host=$(@BINDIR@/xe pool-list params=master --minimal)</command>
-<command label="vm_data_source_list">@BINDIR@/xe vm-list power-state=running --minimal | tr , '\n' | xargs --verbose -n 1 -I {} @BINDIR@/xe vm-data-source-list uuid={} 2>&amp;1</command>
 <command label="sr_data_source_list">@BINDIR@/xe sr-list --minimal | tr , '\n' | xargs --verbose -n 1 -I {} @BINDIR@/xe sr-data-source-list uuid={} 2>&amp;1</command>
 </collect>