Add ignore_vdis to VM.snapshot method

ocaml/idl/datamodel_vm.ml

@@ -247,9 +247,10 @@ let power_behaviour =
       ~in_product_since: rel_orlando
       ~doc:"Snapshots the specified VM, making a new VM. Snapshot automatically exploits the capabilities of the underlying storage repository in which the VM's disk images are stored (e.g. Copy on Write)."
       ~result: (Ref _vm, "The reference of the newly created VM.")
-      ~params:[
-        Ref _vm, "vm", "The VM to be snapshotted";
-        String, "new_name", "The name of the snapshotted VM"
+      ~versioned_params:
+      [{param_type=Ref _vm; param_name="vm"; param_doc="The VM to be snapshotted"; param_release=orlando_release; param_default=None};
+       {param_type=String; param_name="new_name"; param_doc="The name of the snapshotted VM"; param_release=orlando_release; param_default=None};
+       {param_type=Set(Ref _vdi); param_name="ignore_vdis"; param_doc="A list of VDIs to ignore for the snapshot"; param_release=next_release; param_default=Some (VSet [])};
       ]
       ~errs:[Api_errors.vm_bad_power_state; Api_errors.sr_full; Api_errors.operation_not_allowed]
       ~allowed_roles:_R_VM_POWER_ADMIN

ocaml/quicktest/quicktest.ml

@@ -29,6 +29,7 @@ let () =
         ; ("Quicktest_async_calls", Quicktest_async_calls.tests ())
         ; ("Quicktest_vm_import_export", Quicktest_vm_import_export.tests ())
         ; ("Quicktest_vm_lifecycle", Quicktest_vm_lifecycle.tests ())
+        ; ("Quicktest_vm_snapshot", Quicktest_vm_snapshot.tests ())
         ; ( "Quicktest_vdi_ops_data_integrity"
           , Quicktest_vdi_ops_data_integrity.tests ()
           )

ocaml/quicktest/quicktest_vm_snapshot.ml

@@ -0,0 +1,112 @@
+(** Set up snapshot test: create a small VM with a selection of VBDs *)
+let with_setup rpc session_id sr vm_template f =
+  print_endline "Setting up test VM" ;
+  let uuid = Client.Client.VM.get_uuid rpc session_id vm_template in
+  print_endline (Printf.sprintf "Template has uuid: %s%!" uuid) ;
+  let vdi =
+    Client.Client.VDI.create rpc session_id "small" __LOC__ sr 4194304L `user
+      false false [] [] [] []
+  in
+  let vdi2 =
+    Client.Client.VDI.create rpc session_id "small2" __LOC__ sr 4194304L `user
+      false false [] [] [] []
+  in
+  Qt.VM.with_new rpc session_id ~template:vm_template (fun vm ->
+      print_endline (Printf.sprintf "Installed new VM") ;
+      print_endline
+        (Printf.sprintf "Using SR: %s"
+           (Client.Client.SR.get_name_label ~rpc ~session_id ~self:sr)
+        ) ;
+      ignore
+        (Client.Client.VBD.create ~rpc ~session_id ~vM:vm ~vDI:vdi
+           ~userdevice:"0" ~bootable:false ~mode:`RW ~_type:`Disk
+           ~unpluggable:true ~empty:false ~other_config:[]
+           ~qos_algorithm_type:"" ~qos_algorithm_params:[] ~device:""
+           ~currently_attached:true
+        ) ;
+      ignore
+        (Client.Client.VBD.create ~rpc ~session_id ~vM:vm ~vDI:vdi2
+           ~userdevice:"1" ~bootable:false ~mode:`RW ~_type:`Disk
+           ~unpluggable:true ~empty:false ~other_config:[]
+           ~qos_algorithm_type:"" ~qos_algorithm_params:[] ~device:""
+           ~currently_attached:true
+        ) ;
+      f rpc session_id vm vdi vdi2 ;
+      Client.Client.VDI.destroy rpc session_id vdi ;
+      Client.Client.VDI.destroy rpc session_id vdi2
+  )
+
+let test_snapshot rpc session_id vm vdi vdi2 =
+  let snapshot = Client.Client.VM.snapshot rpc session_id vm "Snapshot" [] in
+  let vbds = Client.Client.VM.get_VBDs rpc session_id snapshot in
+  let snap_vbd =
+    match
+      List.find_opt
+        (fun vbd -> Client.Client.VBD.get_userdevice rpc session_id vbd = "0")
+        vbds
+    with
+    | None ->
+        Alcotest.fail "Couldn't find VBD on snapshot"
+    | Some vbd ->
+        vbd
+  in
+  let snap_vbd2 =
+    match
+      List.find_opt
+        (fun vbd -> Client.Client.VBD.get_userdevice rpc session_id vbd = "1")
+        vbds
+    with
+    | None ->
+        Alcotest.fail "Couldn't find VBD on snapshot"
+    | Some vbd ->
+        vbd
+  in
+  let snap_vdi = Client.Client.VBD.get_VDI rpc session_id snap_vbd in
+  let snap_vdi2 = Client.Client.VBD.get_VDI rpc session_id snap_vbd2 in
+  let orig_vdi = Client.Client.VDI.get_snapshot_of rpc session_id snap_vdi in
+  let orig_vdi2 = Client.Client.VDI.get_snapshot_of rpc session_id snap_vdi2 in
+  assert (orig_vdi = vdi) ;
+  assert (orig_vdi2 = vdi2)
+
+let test_snapshot_ignore_vdi rpc session_id vm vdi vdi2 =
+  let snapshot =
+    Client.Client.VM.snapshot rpc session_id vm "Snapshot" [vdi2]
+  in
+  let vbds = Client.Client.VM.get_VBDs rpc session_id snapshot in
+  let snap_vbd =
+    match
+      List.find_opt
+        (fun vbd -> Client.Client.VBD.get_userdevice rpc session_id vbd = "0")
+        vbds
+    with
+    | None ->
+        Alcotest.fail "Couldn't find VBD on snapshot"
+    | Some vbd ->
+        vbd
+  in
+  assert (
+    not
+      (List.exists
+         (fun vbd -> Client.Client.VBD.get_userdevice rpc session_id vbd = "1")
+         vbds
+      )
+  ) ;
+  let snap_vdi = Client.Client.VBD.get_VDI rpc session_id snap_vbd in
+  let orig_vdi = Client.Client.VDI.get_snapshot_of rpc session_id snap_vdi in
+  assert (orig_vdi = vdi)
+
+let test rpc session_id sr_info vm_template () =
+  let sr = sr_info.Qt.sr in
+  List.iter
+    (with_setup rpc session_id sr vm_template)
+    [test_snapshot; test_snapshot_ignore_vdi]
+
+let tests () =
+  let open Qt_filter in
+  [
+    [("VM snapshot tests", `Slow, test)]
+    |> conn
+    |> sr SR.(all |> allowed_operations [`vdi_create])
+    |> vm_template Qt.VM.Template.other
+  ]
+  |> List.concat

ocaml/xapi-cli-server/cli_frontend.ml

@@ -1310,7 +1310,7 @@ let rec cmdtable_data : (string * cmd_spec) list =
   ; ( "vm-snapshot"
     , {
         reqd= ["new-name-label"]
-      ; optn= ["new-name-description"]
+      ; optn= ["new-name-description"; "ignore-vdi-uuids"]
       ; help=
           "Snapshot an existing VM, using storage-level fast disk snapshot \
            operation where available."

ocaml/xapi-cli-server/cli_operations.ml

@@ -4079,7 +4079,7 @@ let vm_clone_aux clone_op cloned_string printer include_template_vms rpc
     do_vm_op printer ~include_template_vms rpc session_id
       (fun vm -> clone_op ~rpc ~session_id ~vm:(vm.getref ()) ~new_name)
       params
-      ["new-name-label"; "new-name-description"]
+      ["new-name-label"; "new-name-description"; "ignore-vdi-uuids"]
   in
   Option.iter
     (fun desc ->
@@ -4093,8 +4093,22 @@ let vm_clone_aux clone_op cloned_string printer include_template_vms rpc
 
 let vm_clone printer = vm_clone_aux Client.VM.clone "Cloned " printer true
 
-let vm_snapshot printer =
-  vm_clone_aux Client.VM.snapshot "Snapshotted " printer false
+let vm_snapshot printer rpc session_id params =
+  let ignore_vdis_uuids =
+    match List.assoc_opt "ignore-vdi-uuids" params with
+    | None ->
+        []
+    | Some x ->
+        String.split_on_char ',' x
+  in
+  let ignore_vdis =
+    List.map
+      (fun vdi_uuid -> Client.VDI.get_by_uuid rpc session_id vdi_uuid)
+      ignore_vdis_uuids
+  in
+  vm_clone_aux
+    (Client.VM.snapshot ~ignore_vdis)
+    "Snapshotted " printer false rpc session_id params
 
 let vm_snapshot_with_quiesce printer =
   vm_clone_aux Client.VM.snapshot_with_quiesce "Snapshotted" printer false

ocaml/xapi/message_forwarding.ml

@@ -1577,10 +1577,10 @@ functor
           ~value:transportable_snapshot_id
 
       (* almost a copy of the clone function *)
-      let snapshot ~__context ~vm ~new_name =
+      let snapshot ~__context ~vm ~new_name ~ignore_vdis =
         info "VM.snapshot: VM = '%s'; new_name = '%s'" (vm_uuid ~__context vm)
           new_name ;
-        let local_fn = Local.VM.snapshot ~vm ~new_name in
+        let local_fn = Local.VM.snapshot ~vm ~new_name ~ignore_vdis in
         (* We mark the VM as snapshoting. We don't mark the disks; the implementation of the snapshot uses the API   *)
         (* to snapshot and lock the individual VDIs. We don't give any atomicity guarantees here but we do prevent   *)
         (* disk corruption.                                                                                          *)
@@ -1589,7 +1589,7 @@ functor
             (fun () ->
               forward_to_access_srs ~local_fn ~__context ~vm
                 (fun session_id rpc ->
-                  Client.VM.snapshot rpc session_id vm new_name
+                  Client.VM.snapshot rpc session_id vm new_name ignore_vdis
               )
           )
         in

ocaml/xapi/xapi_vm.ml

@@ -757,9 +757,9 @@ let clone ~__context ~vm ~new_name =
 
 (* We do call wait_in_line for snapshot and snapshot_with_quiesce because the locks are taken at *)
 (* the VBD level (with pause/unpause mechanism                                                   *)
-let snapshot ~__context ~vm ~new_name =
+let snapshot ~__context ~vm ~new_name ~ignore_vdis =
   TaskHelper.set_cancellable ~__context ;
-  Xapi_vm_snapshot.snapshot ~__context ~vm ~new_name
+  Xapi_vm_snapshot.snapshot ~__context ~vm ~new_name ~ignore_vdis
 
 (* As we will destroy the domain ourself, we grab the vm_lock here in order to tell the event thread to *)
 (* do not look at this domain. The message forwarding layer already checked that the VM reference we    *)

ocaml/xapi/xapi_vm.mli

@@ -211,7 +211,11 @@ val clone :
   __context:Context.t -> vm:API.ref_VM -> new_name:string -> [`VM] Ref.t
 
 val snapshot :
-  __context:Context.t -> vm:API.ref_VM -> new_name:string -> [`VM] Ref.t
+     __context:Context.t
+  -> vm:API.ref_VM
+  -> new_name:string
+  -> ignore_vdis:[`VDI] API.Ref.t list
+  -> [`VM] Ref.t
 
 val revert : __context:Context.t -> snapshot:[`VM] Ref.t -> unit
 

ocaml/xapi/xapi_vm_clone.ml

@@ -408,7 +408,8 @@ let make_driver_params () =
   [(Constants._sm_epoch_hint, Uuid.to_string (Uuid.make_uuid ()))]
 
 (* NB this function may be called when the VM is suspended for copy/clone operations. Snapshot can be done in live.*)
-let clone ?snapshot_info_record disk_op ~__context ~vm ~new_name =
+let clone ?snapshot_info_record ?(ignore_vdis = []) disk_op ~__context ~vm
+    ~new_name =
   Helpers.call_api_functions ~__context (fun rpc session_id ->
       let task_id = Ref.string_of (Context.get_task_id __context) in
       let vbds = Db.VM.get_VBDs ~__context ~self:vm in
@@ -429,6 +430,18 @@ let clone ?snapshot_info_record disk_op ~__context ~vm ~new_name =
       let is_a_snapshot =
         disk_op = Disk_op_snapshot || disk_op = Disk_op_checkpoint
       in
+
+      let vbds =
+        if is_a_snapshot then
+          List.filter
+            (fun x ->
+              not (List.mem (Db.VBD.get_VDI ~__context ~self:x) ignore_vdis)
+              )
+            vbds
+        else
+          vbds
+      in
+
       (* Check licence permission before copying disks, since the copy can take a long time.
          		 * We always allow snapshotting a VM, but check before clone/copy of an existing snapshot or template. *)
       if Db.VM.get_has_vendor_device ~__context ~self:vm && not is_a_snapshot

ocaml/xapi/xapi_vm_clone.mli

@@ -57,6 +57,7 @@ val clone_single_vdi :
 (* NB this function may be called when the VM is suspended for copy/clone operations. Snapshot can be done in live.*)
 val clone :
      ?snapshot_info_record:(string * string) list
+  -> ?ignore_vdis:[`VDI] API.Ref.t list
   -> disk_op_t
   -> __context:Context.t
   -> vm:[`VM] API.Ref.t

ocaml/xapi/xapi_vm_snapshot.ml

@@ -25,12 +25,13 @@ open D
 (*************************************************************************************************)
 (* Crash-consistant snapshot                                                                     *)
 (*************************************************************************************************)
-let snapshot ~__context ~vm ~new_name =
+let snapshot ~__context ~vm ~new_name ~ignore_vdis =
   debug "Snapshot: begin" ;
   TaskHelper.set_cancellable ~__context ;
   Xapi_vmss.show_task_in_xencenter ~__context ~vm ;
   let res =
     Xapi_vm_clone.clone Xapi_vm_clone.Disk_op_snapshot ~__context ~vm ~new_name
+      ~ignore_vdis
   in
   debug "Snapshot: end" ; res
 

ocaml/xe-cli/bash-completion

@@ -373,6 +373,13 @@ _xe()
                 return 0
                 ;;
 
+            ignore-vdi-uuids) # for vm-snapshot
+                val=$(final_comma_separated_param "$value")
+                vdis=$(${xe} vdi-list --minimal 2>/dev/null)
+                IFS=$'\n'
+                set_completions "$vdis" "$val"
+                return 0
+                ;;
             *)
                 snd=`echo ${param} | gawk -F- '{print $NF}'`
                 fst=`echo ${param} | gawk -F- '{printf "%s", $1; for (i=2; i<NF; i++) printf "-%s", $i}'`