xapi_vm_snapshot: change VM.revert to use VDI.revert

The code now tries to call VDI.revert on all the disk VDIs, and if that
fails, it falls back to the original revert method that destroys VM
disks, clones snapshot disks and then fixes up metadata.

This means that the successfully reverted disks must be excluded from
the original method. This is done by introducing sets of VDIs and VBDs
and using set logic on them.

The CD disks and the suspend VDI are treated like before: destroy +
clone.

The code is more convoluted that I would have liked because of existing
clone infrastructure mixes VBDs with VDIs, so they need to be converted
back and forth to be able to run the previous method correctly,
especially for updating the snapshot_of field of the cloned snapshot
disks.

Quicktests encodes the difference in behaviour from the original method
to the native one: now VDI UUIDs are not changed when reverting.

Signed-off-by: Pau Ruiz Safont <pau.safont@vates.tech>
(cherry picked from commit d1ae2a7)

Author: psafont

ocaml/idl/datamodel_common.ml

@@ -10,7 +10,7 @@ open Datamodel_roles
               to leave a gap for potential hotfixes needing to increment the schema version.*)
 let schema_major_vsn = 5
 
-let schema_minor_vsn = 905
+let schema_minor_vsn = 906
 
 (* Historical schema versions just in case this is useful later *)
 let rio_schema_major_vsn = 5

ocaml/idl/schematest.ml

@@ -3,7 +3,7 @@ let hash x = Digest.string x |> Digest.to_hex
 (* BEWARE: if this changes, check that schema has been bumped accordingly in
    ocaml/idl/datamodel_common.ml, usually schema_minor_vsn *)
 
-let last_known_schema_hash = "f45d29452df691507ce8fc9f539649f1"
+let last_known_schema_hash = "247a7b080219583e50e3e1a3c3c85b08"
 
 let current_schema_hash : string =
   let open Datamodel_types in

ocaml/quicktest/qt_filter.ml

@@ -1,3 +1,4 @@
+module Listext = Xapi_stdext_std.Listext.List
 module A = Quicktest_args
 
 type 'a test_case = string * Alcotest.speed_level * 'a
@@ -312,14 +313,13 @@ module SR = struct
     )
 
   let allowed_operations ops =
-    sr_filter (fun i ->
-        Xapi_stdext_std.Listext.List.subset ops i.Qt.allowed_operations
-    )
+    sr_filter (fun i -> Listext.subset ops i.Qt.allowed_operations)
 
   let has_capabilities caps =
-    sr_filter (fun i ->
-        Xapi_stdext_std.Listext.List.subset caps i.Qt.capabilities
-    )
+    sr_filter (fun i -> Listext.subset caps i.Qt.capabilities)
+
+  let unavailable_operations ops =
+    sr_filter (fun i -> not (Listext.subset ops i.Qt.allowed_operations))
 
   (* Helper to filter SRs of specific types *)
   let has_one_of_types types sr_info =

ocaml/quicktest/qt_filter.mli

@@ -64,6 +64,8 @@ module SR : sig
 
   val allowed_operations : API.storage_operations_set -> srs -> srs
 
+  val unavailable_operations : API.storage_operations_set -> srs -> srs
+
   val has_capabilities : string list -> srs -> srs
 
   val has_type : string -> srs -> srs

ocaml/quicktest/quicktest_vm_snapshot.ml

@@ -143,17 +143,22 @@ let test_snapshot_ignore_vdi rpc session_id vm vdi vdi2 =
     (has_been_snapshot "1") ;
   check_vdi_snapshot_of rpc session_id vbds ~vdi "0"
 
-let test_revert rpc session_id vm vdi vdi2 =
+let test_revert rpc session_id vm vdi vdi2 ~change =
   let snapshot = take_snapshot rpc session_id vm ~origin:__FUNCTION__ in
   Client.Client.VM.revert ~rpc ~session_id ~snapshot ;
 
   let vbds = Client.Client.VM.get_VBDs ~rpc ~session_id ~self:vm in
   let vdi_after = get_vdi_with_user_device rpc session_id vbds "0" in
   let vdi_after2 = get_vdi_with_user_device rpc session_id vbds "1" in
 
-  (* Xapi forces VDI clones, the VDIs' IDs will always change *)
-  check_vdis_different vdi vdi_after ;
-  check_vdis_different vdi2 vdi_after2
+  let check =
+    if change then
+      (* Xapi forces VDI clones, the VDIs' IDs will always change *)
+      check_vdis_different
+    else
+      check_vdis_same
+  in
+  check vdi vdi_after ; check vdi2 vdi_after2
 
 let test_revert_cds rpc session_id vm vdi vdi2 =
   let snapshot = take_snapshot rpc session_id vm ~origin:__FUNCTION__ in
@@ -178,13 +183,35 @@ let suite name with_setup tests sr_ops =
   |> sr SR.(all |> allowed_operations sr_ops)
   |> vm_template Qt.VM.Template.other
 
+let suite_split_revert name with_setup =
+  let open Qt_filter in
+  let needed_ops = [`vdi_create] in
+  let old_ops = [`vdi_clone] in
+  let new_ops = [`vdi_revert] in
+  let sr_candidates = SR.(all |> allowed_operations needed_ops) in
+  let sr_native = sr_candidates |> SR.allowed_operations new_ops in
+  let sr_clonables =
+    sr_candidates
+    |> SR.unavailable_operations new_ops
+    |> SR.allowed_operations old_ops
+  in
+  let tests (filter_name, sr_filter) tests_f =
+    let name = Printf.sprintf "%s (%s)" name filter_name in
+    [(name, `Slow, a_test with_setup tests_f)]
+    |> conn
+    |> sr sr_filter
+    |> vm_template Qt.VM.Template.other
+  in
+  tests ("with VDI.revert", sr_native) [test_revert ~change:false]
+  @ tests ("with cloning method", sr_clonables) [test_revert ~change:true]
+
 let tests () =
   List.concat
     [
-      suite "VM snapshot tests" with_setup
+      suite "VM snapshot" with_setup
         [test_snapshot; test_snapshot_ignore_vdi]
         [`vdi_create]
-    ; suite "VM revert tests" with_setup [test_revert] [`vdi_create; `vdi_clone]
-    ; suite "VM revert with CD tests" with_cd_setup [test_revert_cds]
+    ; suite_split_revert "VM revert" with_setup
+    ; suite "VM revert with CD" with_cd_setup [test_revert_cds]
         [`vdi_create; `vdi_clone]
     ]

ocaml/xapi/xapi_vm_snapshot.ml

@@ -211,61 +211,155 @@ let with_vdis_on_error ~vdis f = try f () with e -> Error (e, vdis)
 
 let ( let@ ) f x = f x
 
-(* Copy the VBDs and VIFs from a source VM to a dest VM and then delete the old
-   disks. This operation destroys the data of the dest VM. *)
+(* Revert the VBDs of a VM to have the contents of the snapshot and copy the
+   VIFs from a snapshot VM to the VM. This operation destroys the data of the
+   dest VM. *)
+
 type cloned = {
     disks: ([`VBD] Ref.t * API.ref_VDI * bool) list
   ; cds: ([`VBD] Ref.t * API.ref_VDI * bool) list
   ; suspend_VDI: [`VDI] Ref.t
 }
 
+module VDISet = Set.Make (struct
+  type t = [`VDI] Ref.t
+
+  let compare = Ref.compare
+end)
+
+module VBDSet = Set.Make (struct
+  type t = [`VBD] Ref.t
+
+  let compare = Ref.compare
+end)
+
 let revert_vbds ~__context ~rpc ~session_id ~snapshot ~vm =
-  let snap_VBDs = Db.VM.get_VBDs ~__context ~self:snapshot in
-  let snap_VBDs_disk, snap_VBDs_CD =
-    List.partition
-      (fun vbd -> Db.VBD.get_type ~__context ~self:vbd = `Disk)
-      snap_VBDs
-  in
-  let snap_disks =
-    List.map (fun vbd -> Db.VBD.get_VDI ~__context ~self:vbd) snap_VBDs_disk
+  let get_snapshot_of vdi = Db.VDI.get_snapshot_of ~__context ~self:vdi in
+
+  let disks_of_vbds vbds =
+    vbds
+    |> VBDSet.to_seq
+    |> Seq.map (fun vbd -> Db.VBD.get_VDI ~__context ~self:vbd)
+    |> VDISet.of_seq
   in
-  let snap_disks_snapshot_of =
-    List.map (fun vdi -> Db.VDI.get_snapshot_of ~__context ~self:vdi) snap_disks
+
+  let snap_VBDs_disk, snap_VBDs_CD =
+    Db.VM.get_VBDs ~__context ~self:snapshot
+    |> VBDSet.of_list
+    |> VBDSet.partition (fun vbd -> Db.VBD.get_type ~__context ~self:vbd = `Disk)
   in
   let snap_suspend_VDI = Db.VM.get_suspend_VDI ~__context ~self:snapshot in
+  let snap_disks_all = disks_of_vbds snap_VBDs_disk in
+  let snap_disks_snapshot_of = VDISet.map get_snapshot_of snap_disks_all in
 
-  let vm_VBDs = Db.VM.get_VBDs ~__context ~self:vm in
-  (* Filter VBDs to ensure that we don't read empty CDROMs *)
+  let vm_VBDs_all = Db.VM.get_VBDs ~__context ~self:vm |> VBDSet.of_list in
   let vm_VBDs_disk =
-    List.filter
+    (* Filter VBDs to ensure that we don't read empty CDROMs *)
+    VBDSet.filter
       (fun vbd -> Db.VBD.get_type ~__context ~self:vbd = `Disk)
-      vm_VBDs
+      vm_VBDs_all
+  in
+  let vm_disks_all = disks_of_vbds vm_VBDs_disk in
+
+  let vm_suspend_VDI =
+    Db.VM.get_suspend_VDI ~__context ~self:vm |> VDISet.singleton
   in
-  (* Filter out VM disks for which the snapshot does not have a corresponding
-     disk - these disks will be left unattached after the revert is complete. *)
-  let vm_disks =
-    List.map (fun vbd -> Db.VBD.get_VDI ~__context ~self:vbd) vm_VBDs_disk
+
+  if VDISet.cardinal snap_disks_all <> 0 then
+    debug "%s: trying to revert VDIs using VDI.revert" __FUNCTION__ ;
+
+  let snap_disks_reverted =
+    VDISet.filter
+      (fun snapshot ->
+        try
+          Client.VDI.revert ~rpc ~session_id ~snapshot ;
+          true
+        with _ -> false
+      )
+      snap_disks_all
   in
-  let vm_disks_with_snapshot =
-    List.filter (fun vdi -> List.mem vdi snap_disks_snapshot_of) vm_disks
+
+  let vm_disks_already_reverted =
+    VDISet.map get_snapshot_of snap_disks_reverted
   in
-  let vm_suspend_VDI = Db.VM.get_suspend_VDI ~__context ~self:vm in
 
-  debug "Cleaning up the old VBDs and VDIs to have more free space" ;
-  List.iter (safe_destroy_vbd ~__context ~rpc ~session_id) vm_VBDs ;
-  List.iter
+  let vm_disks_to_be_destroyed =
+    let ( --- ) = VDISet.diff in
+    let ( +++ ) = VDISet.union in
+
+    (* Disks without snapshot are left unattached after the revert is complete. *)
+    let vm_disks_without_snapshot = vm_disks_all --- snap_disks_snapshot_of in
+
+    vm_disks_all
+    --- vm_disks_without_snapshot
+    --- vm_disks_already_reverted
+    +++ vm_suspend_VDI
+  in
+
+  let filter_vbds_from_vdis vbds vdis =
+    vbds
+    |> VBDSet.filter (fun vbd ->
+        VDISet.mem (Db.VBD.get_VDI ~__context ~self:vbd) vdis
+    )
+  in
+
+  let vm_vbds_to_be_destroyed =
+    filter_vbds_from_vdis vm_VBDs_all vm_disks_to_be_destroyed
+  in
+
+  let snap_VBDs_reverted =
+    filter_vbds_from_vdis snap_VBDs_disk snap_disks_reverted
+  in
+
+  (*
+     snap VBDs (disk)
+   - snap VBDs from reverted disks
+   = snap VBDs to be cloned
+   *)
+  let snap_VBDs_to_be_cloned =
+    let ( --- ) = VBDSet.diff in
+    snap_VBDs_disk --- snap_VBDs_reverted
+  in
+  if
+    VBDSet.cardinal vm_vbds_to_be_destroyed <> 0
+    || VDISet.cardinal vm_disks_to_be_destroyed <> 0
+  then
+    debug "%s: Cleaning up the old VBDs and VDIs to have more free space"
+      __FUNCTION__ ;
+  VBDSet.iter
+    (safe_destroy_vbd ~__context ~rpc ~session_id)
+    vm_vbds_to_be_destroyed ;
+  VDISet.iter
     (safe_destroy_vdi ~__context ~rpc ~session_id)
-    (vm_suspend_VDI :: vm_disks_with_snapshot) ;
+    vm_disks_to_be_destroyed ;
   TaskHelper.set_progress ~__context 0.2 ;
-  debug "Cloning the snapshotted disks" ;
+  if VBDSet.cardinal snap_VBDs_to_be_cloned <> 0 then
+    debug "%s: Cloning the snapshotted disks" __FUNCTION__ ;
+
   let driver_params = Xapi_vm_clone.make_driver_params () in
   let cloned_disks =
-    Xapi_vm_clone.safe_clone_disks rpc session_id Xapi_vm_clone.Disk_op_clone
-      ~__context snap_VBDs_disk driver_params
+    (* the list of cloned VDIs maintains the order of the VBDs given, use this
+       to correlate the VDI with the original VDI before the clone *)
+    let snap_VBDs_to_be_cloned =
+      snap_VBDs_to_be_cloned |> VBDSet.to_seq |> List.of_seq
+    in
+    let snap_disks_previous_snapshot_of =
+      snap_VBDs_to_be_cloned
+      |> List.map (fun vbd ->
+          let vdi = Db.VBD.get_VDI ~__context ~self:vbd in
+          Db.VDI.get_snapshot_of ~__context ~self:vdi
+      )
+    in
+
+    let cloned =
+      Xapi_vm_clone.safe_clone_disks rpc session_id Xapi_vm_clone.Disk_op_clone
+        ~__context snap_VBDs_to_be_cloned driver_params
+    in
+    List.combine cloned snap_disks_previous_snapshot_of
   in
   let destroy_vdis_on_error =
     List.filter_map
-      (fun (_, vdi, on_error_delete) ->
+      (fun ((_, vdi, on_error_delete), _) ->
         if on_error_delete then
           Some vdi
         else
@@ -275,20 +369,22 @@ let revert_vbds ~__context ~rpc ~session_id ~snapshot ~vm =
   in
   let@ () = with_vdis_on_error ~vdis:destroy_vdis_on_error in
   let cloned_CDs =
+    let snap_VBDs_CD = snap_VBDs_CD |> VBDSet.to_seq |> List.of_seq in
     Xapi_vm_clone.safe_clone_disks rpc session_id Xapi_vm_clone.Disk_op_clone
       ~__context snap_VBDs_CD driver_params
   in
   TaskHelper.set_progress ~__context 0.5 ;
-  debug "Updating the snapshot_of fields for relevant VDIs" ;
-  List.iter2
-    (fun snap_disk (_, cloned_disk, _) ->
+  if cloned_disks <> [] then
+    debug "%s: Updating the snapshot_of fields for relevant VDIs" __FUNCTION__ ;
+
+  List.iter
+    (fun ((_, cloned_disk, _), snapshot_of) ->
       (* For each snapshot disk which was just cloned:
          1) Find the value of snapshot_of
          2) Find all snapshots with the same snapshot_of
          3) Update each of these snapshots so that their snapshot_of points
             to the new cloned disk. *)
       let open Xapi_database.Db_filter_types in
-      let snapshot_of = Db.VDI.get_snapshot_of ~__context ~self:snap_disk in
       let all_snaps_in_tree =
         Db.VDI.get_refs_where ~__context
           ~expr:(Eq (Field "snapshot_of", Literal (Ref.string_of snapshot_of)))
@@ -299,7 +395,7 @@ let revert_vbds ~__context ~rpc ~session_id ~snapshot ~vm =
         )
         all_snaps_in_tree
     )
-    snap_disks cloned_disks ;
+    cloned_disks ;
   debug "Cloning the suspend VDI if needed" ;
   let cloned_suspend_VDI =
     if snap_suspend_VDI = Ref.null then
@@ -310,12 +406,13 @@ let revert_vbds ~__context ~rpc ~session_id ~snapshot ~vm =
   in
   let destroy_vdis_on_error = cloned_suspend_VDI :: destroy_vdis_on_error in
   let@ () = with_vdis_on_error ~vdis:destroy_vdis_on_error in
+  let vbds_to_copy = List.map fst cloned_disks @ cloned_CDs in
   TaskHelper.set_progress ~__context 0.6 ;
-  debug "Copying the VBDs" ;
+  if vbds_to_copy <> [] then debug "%s: Copying the VBDs" __FUNCTION__ ;
   let (_ : [`VBD] Ref.t list) =
     List.map
       (fun (vbd, vdi, _) -> Xapi_vbd_helpers.copy ~__context ~vm ~vdi vbd)
-      (cloned_disks @ cloned_CDs)
+      vbds_to_copy
   in
   debug "Update the suspend_VDI" ;
   Db.VM.set_suspend_VDI ~__context ~self:vm ~value:cloned_suspend_VDI ;