Implement Better VM revert using VDI revert

ocaml/idl/datamodel.ml

@@ -4275,6 +4275,7 @@ module SR = struct
         ; ("vdi_generate_config", "Generating the configuration of the VDI")
         ; ("vdi_resize_online", "Resizing the VDI online")
         ; ("vdi_update", "Refreshing the fields on the VDI")
+        ; ("vdi_revert", "Reverting a VDI to the snapshot")
         ; ("pbd_create", "Creating a PBD for this SR")
         ; ("pbd_destroy", "Destroying one of this SR's PBDs")
         ]
@@ -5476,6 +5477,16 @@ module VDI = struct
          different SR. The destination SR must be visible to the guest."
       ~allowed_roles:_R_VM_POWER_ADMIN ()
 
+  let revert =
+    call ~name:"revert" ~in_oss_since:None ~lifecycle:[]
+      ~params:
+        [(Ref _vdi, "snapshot", "The snapshot to which we want to revert")]
+      ~doc:
+        "Copy the contents of a snapshot to the VDI it's related to. The \
+         original contents of the VDI are lost."
+      ~errs:[Api_errors.unimplemented_in_sm_backend]
+      ~allowed_roles:_R_VM_POWER_ADMIN ~doc_tags:[Snapshots] ()
+
   let introduce_params first_rel =
     [
       {
@@ -5718,6 +5729,8 @@ module VDI = struct
           )
         ; ("set_on_boot", "Setting the on_boot field of the VDI")
         ; ("blocked", "Operations on this VDI are temporarily blocked")
+        ; ("revert_to", "Reverting a VDI to a clone of this snapshot")
+        ; ("revert_from", "Reverting this VDI to a clone of a snapshot")
         ]
       )
 
@@ -6256,6 +6269,7 @@ module VDI = struct
         ; data_destroy
         ; list_changed_blocks
         ; get_nbd_info
+        ; revert
         ]
       ~contents:
         ([

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/datamodel_lifecycle.ml

@@ -251,6 +251,8 @@ let prototyped_of_message = function
       Some "22.26.0"
   | "VTPM", "create" ->
       Some "22.26.0"
+  | "VDI", "revert" ->
+      Some "26.15.0-next"
   | "host", "set_servertime" ->
       Some "26.0.0"
   | "host", "get_ntp_synchronized" ->

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 = "62c803c7341a736eef8293337105206f"
+let last_known_schema_hash = "6147ef4f0f9c3bbbf0c2061e0a0d0010"
 
 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,26 +143,36 @@ 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
+
+  let snap_vbds = Client.Client.VM.get_VBDs ~rpc ~session_id ~self:snapshot in
+  Alcotest.(check int) "Snapshot must only have 2 VBDs" 2 (List.length snap_vbds) ;
+
   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
 
+  Alcotest.(check int) "VM must only have 2 VBDs" 2 (List.length vbds) ;
   (* CD VDIs are considered immutable and the clone code ignores them *)
   check_vdis_same vdi vdi_after ;
   check_vdis_same vdi2 vdi_after2
@@ -178,13 +188,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/tests/record_util/old_record_util.ml

@@ -299,6 +299,10 @@ let vdi_operation_to_string : API.vdi_operations -> string = function
       "set_on_boot"
   | `blocked ->
       "blocked"
+  | `revert_to ->
+      "revert_to"
+  | `revert_from ->
+      "revert_from"
 
 let sr_operation_to_string : API.storage_operations -> string = function
   | `scan ->
@@ -356,6 +360,8 @@ let sr_operation_to_string : API.storage_operations -> string = function
       "VDI.resize_online"
   | `vdi_update ->
       "VDI.update"
+  | `vdi_revert ->
+      "VDI.revert"
 
 let vbd_operation_to_string = function
   | `attach ->

ocaml/tests/test_vdi_allowed_operations.ml

@@ -573,6 +573,54 @@ let test_update_allowed_operations () =
   Alcotest.(check Alcotest_comparators.vdi_operations_set)
     "update_allowed_operations should be correct" ok_ops allowed_operations
 
+(* Tests for revert operation *)
+let test_revert =
+  let test_can_revert_to_snapshot () =
+    let __context = Mock.make_context_with_new_db "Mock context" in
+
+    run_assert_equal_with_vdi ~__context
+      ~vdi_fun:(fun vdi_ref ->
+        Db.VDI.set_is_a_snapshot ~__context ~self:vdi_ref ~value:true
+      )
+      `revert_to (Ok ())
+  in
+  (* VBDs of checkpoints are marked with currently_attached = true, but we still
+     need to be able to revert to them. *)
+  let test_can_revert_to_checkpoint () =
+    let __context = Mock.make_context_with_new_db "Mock context" in
+
+    run_assert_equal_with_vdi ~__context
+      ~vdi_fun:(fun vdi_ref ->
+        Db.VDI.set_is_a_snapshot ~__context ~self:vdi_ref ~value:true ;
+        make_vbd ~__context ~vDI:vdi_ref ~currently_attached:true ~mode:`RW ()
+      )
+      `revert_to (Ok ())
+  in
+  let test_cannot_revert_to_leaf () =
+    let __context = Mock.make_context_with_new_db "Mock context" in
+
+    run_assert_equal_with_vdi ~__context
+      ~vdi_fun:(fun _ -> ())
+      `revert_to
+      (Error (Api_errors.only_revert_snapshot, []))
+  in
+  let test_cannot_revert_live () =
+    let __context = Mock.make_context_with_new_db "Mock context" in
+
+    run_assert_equal_with_vdi ~__context
+      ~vdi_fun:(fun vdi_ref ->
+        make_vbd ~__context ~vDI:vdi_ref ~currently_attached:true ~mode:`RW ()
+      )
+      `revert_from
+      (Error (Api_errors.vdi_in_use, []))
+  in
+  [
+    ("Revert: Can revert to snapshot", `Quick, test_can_revert_to_snapshot)
+  ; ("Revert: Can revert to checkpoint", `Quick, test_can_revert_to_checkpoint)
+  ; ("Revert: Cannot revert to leaf", `Quick, test_cannot_revert_to_leaf)
+  ; ("Revert: Cannot revert live", `Quick, test_cannot_revert_live)
+  ]
+
 let test =
   [
     ("test_ca98944", `Quick, test_ca98944)
@@ -586,3 +634,4 @@ let test =
       ("test_null_vm", `Quick, test_null_vm)
     ; ("test_update_allowed_operations", `Quick, test_update_allowed_operations)
     ]
+  @ test_revert

ocaml/tests/test_vdi_allowed_operations.mli

@@ -0,0 +1 @@
+val test : (string * [> `Quick] * (unit -> unit)) list

ocaml/xapi-cli-server/record_util.ml

@@ -175,6 +175,8 @@ let sr_operation_to_string : API.storage_operations -> string = function
       "VDI.resize_online"
   | `vdi_update ->
       "VDI.update"
+  | `vdi_revert ->
+      "VDI.revert"
   | `pbd_create ->
       "PBD.create"
   | `pbd_destroy ->

ocaml/xapi-idl/storage/storage_interface.ml

@@ -1026,6 +1026,15 @@ module StorageAPI (R : RPC) = struct
       let result_p = Param.mk ~name:"changed_blocks" Types.string in
       declare "VDI.list_changed_blocks" []
         (dbg_p @-> sr_p @-> vdi_from_p @-> vdi_to_p @-> returning result_p err)
+
+    (** [revert dbg sr snapshot_info] creates a new VDI which is a clone of
+        [snapshot_info] in [sr]. The contents of the VDI in
+        [snapshot_info.snapshot_of] will be destroyed and replaced with the
+        contents of [snapshot] *)
+    let revert =
+      let snapshot_info_p = Param.mk ~name:"snapshot_info" vdi_info in
+      declare "VDI.revert" []
+        (dbg_p @-> sr_p @-> snapshot_info_p @-> returning unit_p err)
   end
 
   (** [get_by_name task name] returns a vdi with [name] (which may be in any SR) *)
@@ -1651,6 +1660,9 @@ module type Server_impl = sig
 
     val list_changed_blocks :
       context -> dbg:debug_info -> sr:sr -> vdi_from:vdi -> vdi_to:vdi -> string
+
+    val revert :
+      context -> dbg:debug_info -> sr:sr -> snapshot_info:vdi_info -> unit
   end
 
   val get_by_name : context -> dbg:debug_info -> name:string -> sr * vdi_info
@@ -1854,6 +1866,9 @@ module Server (Impl : Server_impl) () = struct
     S.VDI.list_changed_blocks (fun dbg sr vdi_from vdi_to ->
         Impl.VDI.list_changed_blocks () ~dbg ~sr ~vdi_from ~vdi_to
     ) ;
+    S.VDI.revert (fun dbg sr snapshot_info ->
+        Impl.VDI.revert () ~dbg ~sr ~snapshot_info
+    ) ;
     S.get_by_name (fun dbg name -> Impl.get_by_name () ~dbg ~name) ;
     S.DATA.copy (fun dbg sr vdi vm url dest verify_dest ->
         Impl.DATA.copy () ~dbg ~sr ~vdi ~vm ~url ~dest ~verify_dest

ocaml/xapi-idl/storage/storage_skeleton.ml

@@ -175,6 +175,9 @@ module VDI = struct
 
   let list_changed_blocks ctx ~dbg ~sr ~vdi_from ~vdi_to =
     Storage_interface.unimplemented __FUNCTION__
+
+  let revert ctx ~dbg ~sr ~snapshot_info =
+    Storage_interface.unimplemented __FUNCTION__
 end
 
 let get_by_name ctx ~dbg ~name = Storage_interface.unimplemented __FUNCTION__

ocaml/xapi-storage-script/main.ml

@@ -1355,6 +1355,8 @@ module VDIImpl (M : META) = struct
           dbg sr vdi
     )
 
+  let ( let* ) = Lwt_result.bind
+
   let update_keys ~dbg ~sr ~key ~value response =
     match value with
     | None ->
@@ -1374,6 +1376,11 @@ module VDIImpl (M : META) = struct
         Volume_client.destroy (volume_rpc ~dbg) dbg sr vdi
     )
 
+  let revert ~dbg ~sr ~snapshot ~vdi =
+    return_volume_rpc (fun () ->
+        Volume_client.revert (volume_rpc ~dbg) dbg sr snapshot vdi
+    )
+
   let vdi_attach_common dbg sr vdi domain =
     Attached_SRs.find sr >>>= fun sr ->
     (* Discover the URIs using Volume.stat *)
@@ -1424,6 +1431,14 @@ module VDIImpl (M : META) = struct
     )
     |> wrap
 
+  let revert_impl dbg sr snapshot_info =
+    wrap
+    @@
+    let snapshot = Storage_interface.(Vdi.string_of snapshot_info.vdi) in
+    let vdi = Storage_interface.(Vdi.string_of snapshot_info.snapshot_of) in
+    let* sr = Attached_SRs.find sr in
+    revert ~dbg ~sr ~snapshot ~vdi
+
   let vdi_snapshot_impl dbg sr vdi_info =
     Attached_SRs.find sr
     >>>= (fun sr ->
@@ -1662,8 +1677,6 @@ module VDIImpl (M : META) = struct
 
   let vdi_set_persistent_impl _dbg _sr _vdi _persistent = return () |> wrap
 
-  let ( let* ) = Lwt_result.bind
-
   let vdi_enable_cbt_impl dbg sr vdi =
     wrap
     @@
@@ -1953,6 +1966,7 @@ let bind ~volume_script_dir =
   S.VDI.add_to_sm_config VDI.vdi_add_to_sm_config_impl ;
   S.VDI.remove_from_sm_config VDI.vdi_remove_from_sm_config_impl ;
   S.VDI.similar_content VDI.similar_content_impl ;
+  S.VDI.revert VDI.revert_impl ;
 
   let module DP = DPImpl (RuntimeMeta) in
   S.DP.destroy2 DP.dp_destroy2 ;