CA-370858: disallow VM exports with VTPMs attached

We're unable to serialize the data because the field for the contents is
not exposed in the API and it's based on a secret, which can be
dangerous once it's been implemented.

Exports are exposed using an HTTP endpoint, this means it's an indirect
operation and that other operations that use the  feature will fail in
extraneous ways in a non-instantaneous way.

To avoid this the two methods that use it in xapi are changed as well
(vm-export and VM cross-pool migrations). This makes the failure
immediate and clear.

Signed-off-by: Pau Ruiz Safont <pau.safont@citrix.com>

Author: psafont

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_uninmplemented 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_uninmplemented __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/xapi_vm_migrate.ml

@@ -1167,6 +1167,10 @@ let migrate_send' ~__context ~vm ~dest ~live:_ ~vdi_map ~vif_map ~vgpu_map
       true
     with _ -> false
   in
+  ( if (not is_intra_pool) && Db.VM.get_VTPMs ~__context ~self:vm <> [] then
+      let message = "Cross-pool VM migration with VTPMs attached" in
+      Helpers.maybe_raise_vtpm_uninmplemented __FUNCTION__ message
+  ) ;
   let is_same_host = is_intra_pool && remote.dest_host = localhost in
   if copy && is_intra_pool then
     raise

quality-gate.sh

@@ -58,7 +58,7 @@ structural-equality () {
 }
 
 vtpm-unimplemented () {
-  N=5
+  N=8
   VTPM=$(git grep -r --count 'maybe_raise_vtpm_uninmplemented' -- **/*.ml | cut -d ':' -f 2 | paste -sd+ - | bc)
   if [ "$VTPM" -eq "$N" ]; then
     echo "OK found $VTPM usages of vtpm unimplemented errors"