CP-39744, CA-370858: Block actions depending on unimplemented VTPM functionality

ocaml/tests/test_platformdata.ml

@@ -149,7 +149,7 @@ module SanityCheck = Generic.MakeStateless (struct
   module Io = struct
     type input_t =
       (string * string) list
-      * Xenops_types.Vm.firmware_type option
+      * Xenops_types.Vm.firmware_type
       * bool
       * int64
       * int64
@@ -164,7 +164,7 @@ module SanityCheck = Generic.MakeStateless (struct
          = %Ld,\n\
         \          vcpu_at_startup = %Ld, domain_type = %s)"
         (platformdata |> Test_printers.(assoc_list string string))
-        (firmware |> Test_printers.option firmware_type_printer)
+        (firmware |> firmware_type_printer)
         filter vcpu_max vcpu_startup
         (Record_util.domain_type_to_string domain_type)
 
@@ -187,8 +187,8 @@ module SanityCheck = Generic.MakeStateless (struct
       ) =
     try
       Ok
-        (Vm_platform.sanity_check ~platformdata ?firmware ~vcpu_max
-           ~vcpu_at_startup ~domain_type ~filter_out_unknowns ()
+        (Vm_platform.sanity_check ~platformdata ~firmware ~vcpu_max
+           ~vcpu_at_startup ~domain_type ~filter_out_unknowns
         )
     with e -> Error e
 
@@ -209,7 +209,7 @@ module SanityCheck = Generic.MakeStateless (struct
             ; ("whatever", "def")
             ; ("viridian", "true")
             ]
-          , None
+          , Bios
           , true
           , 0L
           , 0L
@@ -218,28 +218,28 @@ module SanityCheck = Generic.MakeStateless (struct
         , Ok (usb_defaults @ [("pae", "true"); ("viridian", "true")])
         )
       ; (* Check that usb and usb_tablet are turned on by default. *)
-        (([], None, false, 0L, 0L, `pv), Ok usb_defaults)
+        (([], Bios, false, 0L, 0L, `pv), Ok usb_defaults)
       ; (* Check that an invalid tsc_mode gets filtered out. *)
-        (([("tsc_mode", "17")], None, false, 0L, 0L, `pv), Ok usb_defaults)
+        (([("tsc_mode", "17")], Bios, false, 0L, 0L, `pv), Ok usb_defaults)
       ; (* Check that an invalid parallel port gets filtered out. *)
-        ( ([("parallel", "/dev/random")], None, false, 0L, 0L, `pv)
+        ( ([("parallel", "/dev/random")], Bios, false, 0L, 0L, `pv)
         , Ok usb_defaults
         )
       ; (* Check that we can't set usb_tablet to true if usb is false. *)
-        ( ([("usb", "false"); ("usb_tablet", "true")], None, false, 0L, 0L, `pv)
+        ( ([("usb", "false"); ("usb_tablet", "true")], Bios, false, 0L, 0L, `pv)
         , Ok [("usb", "false"); ("usb_tablet", "false")]
         )
       ; (* Check that we can fully disable usb. *)
-        ( ([("usb", "false"); ("usb_tablet", "false")], None, false, 0L, 0L, `pv)
+        ( ([("usb", "false"); ("usb_tablet", "false")], Bios, false, 0L, 0L, `pv)
         , Ok [("usb", "false"); ("usb_tablet", "false")]
         )
       ; (* Check that we can disable the parallel port. *)
-        ( ([("parallel", "none")], None, false, 0L, 0L, `pv)
+        ( ([("parallel", "none")], Bios, false, 0L, 0L, `pv)
         , Ok (usb_defaults @ [("parallel", "none")])
         )
       ; (* Check that a set of valid fields is unchanged (apart from
-           			 * the ordering, which changes due to the implementation of
-           			 * List.update_assoc). *)
+           the ordering, which changes due to the implementation of
+           List.update_assoc). *)
         ( ( [
               ("parallel", "/dev/parport2")
             ; ("pae", "true")
@@ -248,7 +248,7 @@ module SanityCheck = Generic.MakeStateless (struct
             ; ("viridian", "true")
             ; ("usb", "true")
             ]
-          , None
+          , Bios
           , false
           , 0L
           , 0L
@@ -265,66 +265,66 @@ module SanityCheck = Generic.MakeStateless (struct
             ]
         )
       ; (* Check that combination of valid and invalid fields is dealt with
-           			 * correctly. *)
+           correctly. *)
         ( ( [
               ("pae", "true")
             ; ("parallel", "/dev/parport0")
             ; ("tsc_mode", "blah")
             ]
-          , None
+          , Bios
           , false
           , 0L
           , 0L
           , `pv
           )
         , Ok (usb_defaults @ [("pae", "true"); ("parallel", "/dev/parport0")])
         )
-      ; (* Check VCPUs configuration - hvm success scenario*)
-        ( ([("cores-per-socket", "3")], None, false, 6L, 6L, `hvm)
+      ; (* Check VCPUs configuration - hvm success scenario *)
+        ( ([("cores-per-socket", "3")], Bios, false, 6L, 6L, `hvm)
         , Ok (usb_defaults @ [("cores-per-socket", "3")])
         )
-      ; (* Check VCPUs configuration - pvm success scenario*)
-        ( ([("cores-per-socket", "3")], None, false, 0L, 0L, `pv)
+      ; (* Check VCPUs configuration - pvm success scenario *)
+        ( ([("cores-per-socket", "3")], Bios, false, 0L, 0L, `pv)
         , Ok (usb_defaults @ [("cores-per-socket", "3")])
         )
-      ; (* Check VCPUs configuration - hvm failure scenario*)
-        ( ([("cores-per-socket", "4")], None, false, 6L, 6L, `hvm)
+      ; (* Check VCPUs configuration - hvm failure scenario *)
+        ( ([("cores-per-socket", "4")], Bios, false, 6L, 6L, `hvm)
         , Error
             (Api_errors.Server_error
                (Api_errors.vcpu_max_not_cores_per_socket_multiple, ["6"; "4"])
             )
         )
       ; (* Check VCPUs configuration - hvm failure scenario*)
-        ( ([("cores-per-socket", "0")], None, false, 6L, 6L, `hvm)
+        ( ([("cores-per-socket", "0")], Bios, false, 6L, 6L, `hvm)
         , Error
             (Api_errors.Server_error
                (Api_errors.vcpu_max_not_cores_per_socket_multiple, ["6"; "0"])
             )
         )
       ; (* Check VCPUs configuration - hvm failure scenario*)
-        ( ([("cores-per-socket", "-1")], None, false, 6L, 6L, `hvm)
+        ( ([("cores-per-socket", "-1")], Bios, false, 6L, 6L, `hvm)
         , Error
             (Api_errors.Server_error
                (Api_errors.vcpu_max_not_cores_per_socket_multiple, ["6"; "-1"])
             )
         )
       ; (* Check VCPUs configuration - hvm failure scenario*)
-        ( ([("cores-per-socket", "abc")], None, false, 6L, 5L, `hvm)
+        ( ([("cores-per-socket", "abc")], Bios, false, 6L, 5L, `hvm)
         , Error
             (Api_errors.Server_error
                (Api_errors.invalid_value, ["platform:cores-per-socket"; "abc"])
             )
         )
       ; (* Check BIOS configuration - qemu trad *)
-        make_firmware_ok "qemu-trad" (Some Bios)
-      ; make_firmware_ok "qemu-upstream" (Some Bios)
-      ; make_firmware_ok "qemu-upstream-compat" (Some Bios)
+        make_firmware_ok "qemu-trad" Bios
+      ; make_firmware_ok "qemu-upstream" Bios
+      ; make_firmware_ok "qemu-upstream-compat" Bios
       ; (* Check UEFI configuration - qemu upstream *)
-        make_firmware_ok "qemu-upstream" (Some uefi)
-      ; make_firmware_ok "qemu-upstream-compat" (Some uefi)
-      ; make_firmware_ok "qemu-upstream-uefi" (Some uefi)
+        make_firmware_ok "qemu-upstream" uefi
+      ; make_firmware_ok "qemu-upstream-compat" uefi
+      ; make_firmware_ok "qemu-upstream-uefi" uefi
       ; (* Check UEFI configuration - qemu-trad incompatibility *)
-        ( ([("device-model", "qemu-trad")], Some uefi, false, 0L, 0L, `hvm)
+        ( ([("device-model", "qemu-trad")], uefi, false, 0L, 0L, `hvm)
         , Error
             (Api_errors.Server_error
                ( Api_errors.invalid_value
@@ -336,13 +336,7 @@ module SanityCheck = Generic.MakeStateless (struct
             )
         )
       ; (* Check BIOS configuration - qemu-upstream-uefi incompatibility *)
-        ( ( [("device-model", "qemu-upstream-uefi")]
-          , Some Bios
-          , false
-          , 0L
-          , 0L
-          , `hvm
-          )
+        ( ([("device-model", "qemu-upstream-uefi")], Bios, false, 0L, 0L, `hvm)
         , Error
             (Api_errors.Server_error
                ( Api_errors.invalid_value

ocaml/xapi-cli-server/cli_operations.ml

@@ -5794,6 +5794,13 @@ let export_common fd _printer rpc session_id params filename num ?task_uuid
   in
   let vm_metadata_only = get_bool_param params "metadata" in
   let vm_record = vm.record () in
+  (* disallow exports and cross-pool migrations of VMs with VTPMs *)
+  ( if vm_record.API.vM_VTPMs <> [] then
+      let message = "Exporting VM metadata with VTPMs attached" in
+      (* Helpers.maybe_raise_vtpm_unimplemented cannot be used due to the
+         xapi_globs dependence *)
+      raise Api_errors.(Server_error (not_implemented, [message]))
+  ) ;
   let exporttask, task_destroy_fn =
     match task_uuid with
     | None ->

ocaml/xapi/export.ml

@@ -210,6 +210,12 @@ let make_host table __context self =
 let make_vm ?(with_snapshot_metadata = false) ~preserve_power_state table
     __context self =
   let vm = Db.VM.get_record ~__context ~self in
+  let vM_VTPMs = filter table (List.map Ref.string_of vm.API.vM_VTPMs) in
+  (* disallow exports and cross-pool migrations of VMs with VTPMs *)
+  ( if vM_VTPMs <> [] then
+      let message = "Exporting VM metadata with VTPMs attached" in
+      Helpers.maybe_raise_vtpm_unimplemented __FUNCTION__ message
+  ) ;
   let vm =
     {
       vm with
@@ -251,7 +257,7 @@ let make_vm ?(with_snapshot_metadata = false) ~preserve_power_state table
     ; API.vM_VBDs= filter table (List.map Ref.string_of vm.API.vM_VBDs)
     ; API.vM_VGPUs= filter table (List.map Ref.string_of vm.API.vM_VGPUs)
     ; API.vM_crash_dumps= []
-    ; API.vM_VTPMs= []
+    ; API.vM_VTPMs
     ; API.vM_resident_on= lookup table (Ref.string_of vm.API.vM_resident_on)
     ; API.vM_affinity= lookup table (Ref.string_of vm.API.vM_affinity)
     ; API.vM_consoles= []

ocaml/xapi/helpers.ml

@@ -891,12 +891,18 @@ let is_platform_version_same_on_master ~__context ~host =
       (LocalObject host)
     = 0
 
+let maybe_raise_vtpm_unimplemented func message =
+  if not !ignore_vtpm_unimplemented then (
+    error {|%s: Functionality not implemented yet. "%s"|} func message ;
+    raise Api_errors.(Server_error (not_implemented, [message]))
+  )
+
 let assert_ha_vtpms_compatible ~__context =
   let on_db = {|field "persistence_backend"="xapi"|} in
   let vtpms_on_db = Db.VTPM.get_all_records_where ~__context ~expr:on_db in
   if vtpms_on_db <> [] then
     let message = "VTPM persistence when HA or clustering is enabled" in
-    raise Api_errors.(Server_error (not_implemented, [message]))
+    maybe_raise_vtpm_unimplemented __FUNCTION__ message
 
 let assert_platform_version_is_same_on_master ~__context ~host ~self =
   if not (is_platform_version_same_on_master ~__context ~host) then

ocaml/xapi/vm_platform.ml

@@ -145,8 +145,8 @@ let is_valid_device_model ~key ~platformdata =
         false
   with Not_found -> false
 
-let sanity_check ~platformdata ?firmware ~vcpu_max ~vcpu_at_startup:_
-    ~domain_type ~filter_out_unknowns () =
+let sanity_check ~platformdata ~firmware ~vcpu_max ~vcpu_at_startup:_
+    ~domain_type ~filter_out_unknowns =
   (* Filter out unknown flags, if applicable *)
   let platformdata =
     if filter_out_unknowns then
@@ -165,7 +165,7 @@ let sanity_check ~platformdata ?firmware ~vcpu_max ~vcpu_at_startup:_
     match domain_type with `hvm | `pv_in_pvh -> true | `pv -> false
   in
   ( match (List.assoc device_model platformdata, firmware) with
-  | "qemu-trad", Some (Xenops_types.Vm.Uefi _) ->
+  | "qemu-trad", Xenops_types.Vm.Uefi _ ->
       raise
         (Api_errors.Server_error
            ( Api_errors.invalid_value
@@ -175,7 +175,7 @@ let sanity_check ~platformdata ?firmware ~vcpu_max ~vcpu_at_startup:_
              ]
            )
         )
-  | "qemu-upstream-uefi", Some Xenops_types.Vm.Bios ->
+  | "qemu-upstream-uefi", Xenops_types.Vm.Bios ->
       raise
         (Api_errors.Server_error
            ( Api_errors.invalid_value

ocaml/xapi/xapi_globs.ml

@@ -926,6 +926,8 @@ let repository_gpgcheck = ref true
 
 let migration_compression = ref false
 
+let ignore_vtpm_unimplemented = ref false
+
 let evacuation_batch_size = ref 10
 
 type xapi_globs_spec_ty = Float of float ref | Int of int ref
@@ -1362,8 +1364,16 @@ let other_options =
     , (fun () -> string_of_int !evacuation_batch_size)
     , "The number of VMs evacauted from a host in parallel."
     )
+  ; ( "ignore-vtpm-unimplemented"
+    , Arg.Set ignore_vtpm_unimplemented
+    , (fun () -> string_of_bool !ignore_vtpm_unimplemented)
+    , "Do not raise errors on use-cases where VTPM codepaths are not finished."
+    )
   ]
 
+(* The options can be set with the variable xapiflags in /etc/sysconfig/xapi.
+   e.g. xapiflags=-nowatchdog *)
+
 let all_options = options_of_xapi_globs_spec @ other_options
 
 (* VIRTUAL HARDWARE PLATFORM VERSIONS *)

ocaml/xapi/xapi_vm_clone.ml

@@ -423,13 +423,8 @@ let clone ?snapshot_info_record ?(ignore_vdis = []) disk_op ~__context ~vm
       let power_state = Db.VM.get_power_state ~__context ~self:vm in
       ( match (power_state, vtpms) with
       | `Running, _ :: _ ->
-          error "%s: Running VMs with VTPMs cannot be snapshotted yet"
-            __FUNCTION__ ;
-          raise
-            Api_errors.(
-              Server_error
-                (not_implemented, ["VM.clone of running VM with VTPM"])
-            )
+          let message = "VM.clone of running VM with VTPM" in
+          Helpers.maybe_raise_vtpm_unimplemented __FUNCTION__ message
       | _ ->
           ()
       ) ;

ocaml/xapi/xapi_vm_migrate.ml

@@ -1719,6 +1719,11 @@ let assert_can_migrate ~__context ~vm ~dest ~live:_ ~vdi_map ~vif_map ~options
              , [Ref.string_of vm; Ref.string_of remote.dest_host]
              )
           ) ;
+      (* VTPMs can't be exported currently, which will make the migration fail *)
+      ( if Db.VM.get_VTPMs ~__context ~self:vm <> [] then
+          let message = "Cross-pool VM migration with VTPMs attached" in
+          Helpers.maybe_raise_vtpm_unimplemented __FUNCTION__ message
+      ) ;
       (* Check VDIs are not migrating to or from an SR which doesn't have required_sr_operations *)
       assert_sr_support_operations ~__context ~vdi_map ~remote
         ~ops:required_sr_operations ;

ocaml/xapi/xapi_vtpm.ml

@@ -32,7 +32,7 @@ let assert_no_fencing ~__context ~persistence_backend =
   match (persistence_backend, may_fence) with
   | `xapi, true ->
       let message = "VTPM.create with HA or clustering enabled" in
-      raise Api_errors.(Server_error (not_implemented, [message]))
+      Helpers.maybe_raise_vtpm_unimplemented __FUNCTION__ message
   | _ ->
       ()
 

ocaml/xapi/xapi_xenops.ml

@@ -1211,14 +1211,14 @@ module MD = struct
       in
       {priority; affinity}
     in
+    let firmware = firmware_of_vm vm in
     let platformdata =
-      Vm_platform.sanity_check ~platformdata:vm.API.vM_platform
-        ~firmware:(firmware_of_vm vm) ~vcpu_max:vm.API.vM_VCPUs_max
+      Vm_platform.sanity_check ~platformdata:vm.API.vM_platform ~firmware
+        ~vcpu_max:vm.API.vM_VCPUs_max
         ~vcpu_at_startup:vm.API.vM_VCPUs_at_startup
         ~domain_type:(Helpers.check_domain_type vm.API.vM_domain_type)
         ~filter_out_unknowns:
           (not (Pool_features.is_enabled ~__context Features.No_platform_filter))
-        ()
     in
     (* Replace the timeoffset in the platform data too, to avoid confusion *)
     let timeoffset = rtc_timeoffset_of_vm ~__context (vmref, vm) vbds in
@@ -1261,6 +1261,14 @@ module MD = struct
       else
         platformdata
     in
+    (* BIOS guests don't seem to detect the attached VTPM, block them *)
+    ( match (firmware, vm.API.vM_VTPMs) with
+    | Xenops_types.Vm.Bios, _ :: _ ->
+        let message = "Booting BIOS VM with VTPMs attached" in
+        Helpers.maybe_raise_vtpm_unimplemented __FUNCTION__ message
+    | _ ->
+        ()
+    ) ;
     (* Add TPM version 2 iff there's a tpm attached to the VM, this allows
        hvmloader to load the TPM 2.0 ACPI table while maintaing the current
        ACPI table for other guests *)

quality-gate.sh

@@ -57,7 +57,19 @@ structural-equality () {
   fi
 }
 
+vtpm-unimplemented () {
+  N=8
+  VTPM=$(git grep -r --count 'maybe_raise_vtpm_unimplemented' -- **/*.ml | cut -d ':' -f 2 | paste -sd+ - | bc)
+  if [ "$VTPM" -eq "$N" ]; then
+    echo "OK found $VTPM usages of vtpm unimplemented errors"
+  else
+    echo "ERROR expected $N usages of unimplemented vtpm functionality, got $VTPM." 1>&2
+    exit 1
+  fi
+}
+
 list-hd
 verify-cert
 mli-files
 structural-equality
+vtpm-unimplemented