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_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/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 ;

quality-gate.sh

@@ -58,7 +58,7 @@ structural-equality () {
 }
 
 vtpm-unimplemented () {
-  N=5
+  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"