Allow selection of image format during VM migration

This patch allows specifying the destination format for individual VDIs
mapped to a destination SR. It adds a new parameter to `VM.migrate_send`
and `VM.assert_can_migrate` API. It also adds a new parameter to XE CLI.
The format to specify the image format is `image-format:<source VDI
UUID>=<destination image format>`. If the given image format cannot be
validated, an error is returned.

Signed-off-by: Guillaume <[email protected]>

Author: gthvn1

ocaml/idl/datamodel_vm.ml

@@ -1714,6 +1714,13 @@ let migrate_send =
         ; param_release= inverness_release
         ; param_default= Some (VMap [])
         }
+      ; {
+          param_type= Map (Ref _vdi, String)
+        ; param_name= "vdi_format_map"
+        ; param_doc= "Map of source VDI to an image format"
+        ; param_release= numbered_release "25.6.0-next"
+        ; param_default= Some (VMap [])
+        }
       ]
     ~result:
       (Ref _vm, "The reference of the newly created VM in the destination pool")
@@ -1781,6 +1788,13 @@ let assert_can_migrate =
         ; param_release= inverness_release
         ; param_default= Some (VMap [])
         }
+      ; {
+          param_type= Map (Ref _vdi, String)
+        ; param_name= "vdi_format_map"
+        ; param_doc= "Map of source VDI to its expected type on destination"
+        ; param_release= numbered_release "25.6.0-next"
+        ; param_default= Some (VMap [])
+        }
       ]
     ~allowed_roles:_R_VM_POWER_ADMIN
     ~errs:[Api_errors.license_restriction]

ocaml/xapi-cli-server/cli_frontend.ml

@@ -1574,6 +1574,7 @@ let rec cmdtable_data : (string * cmd_spec) list =
           ; "compress"
           ; "vif:"
           ; "vdi:"
+          ; "image-format:"
           ]
       ; help=
           "Migrate the selected VM(s). The parameter '--live' will migrate the \
@@ -1587,7 +1588,9 @@ let rec cmdtable_data : (string * cmd_spec) list =
            'copy=true' will enable the copy mode so that a stopped vm can be \
            copied, instead of migrating, to the destination pool. The vif and \
            vdi mapping parameters take the form 'vif:<source vif uuid>=<dest \
-           network uuid>' and 'vdi:<source vdi uuid>=<dest sr uuid>'. \
+           network uuid>' and 'vdi:<source vdi uuid>=<dest sr uuid>'. You can \
+           also specify the destination image format of the VDI using \
+           image-format:<source vdi uuid>=<destination image format>. \
            Unfortunately, destination uuids cannot be tab-completed."
       ; implementation= No_fd Cli_operations.vm_migrate
       ; flags= [Standard; Vm_selectors]

ocaml/xapi-cli-server/cli_operations.ml

@@ -4544,6 +4544,7 @@ let vm_migrate_sxm_params =
   ; "remote-network"
   ; "vdi"
   ; "vgpu"
+  ; "image-format"
   ]
 
 let vm_migrate printer rpc session_id params =
@@ -4691,6 +4692,17 @@ let vm_migrate printer rpc session_id params =
             )
             (read_map_params "vdi" params)
         in
+        let vdi_format_map =
+          List.map
+            (fun (vdi_uuid, vdi_fmt) ->
+              let vdi =
+                Client.VDI.get_by_uuid ~rpc ~session_id ~uuid:vdi_uuid
+              in
+              debug "GTNDEBUG: add image format %s,%s" vdi_uuid vdi_fmt ;
+              (vdi, vdi_fmt)
+            )
+            (read_map_params "image-format" params)
+        in
         let vgpu_map =
           List.map
             (fun (vgpu_uuid, gpu_group_uuid) ->
@@ -4853,7 +4865,8 @@ let vm_migrate printer rpc session_id params =
             rpc session_id
             (fun vm ->
               Client.VM.migrate_send ~rpc ~session_id ~vm:(vm.getref ())
-                ~dest:token ~live:true ~vdi_map ~vif_map ~options ~vgpu_map
+                ~dest:token ~live:true ~vdi_map ~vdi_format_map ~vif_map
+                ~options ~vgpu_map
             )
             params
             (["host"; "host-uuid"; "host-name"; "live"; "force"; "copy"]

ocaml/xapi-idl/storage/storage_interface.ml

@@ -251,6 +251,8 @@ let string_of_vdi_info (x : vdi_info) = Jsonrpc.to_string (rpc_of vdi_info x)
     "datapaths". *)
 type dp = string [@@deriving rpcty]
 
+type image_format = string [@@deriving rpcty]
+
 type sock_path = string [@@deriving rpcty]
 
 type dp_stat_t = {
@@ -277,6 +279,8 @@ type probe_result =
 module Mirror = struct
   type id = string [@@deriving rpcty]
 
+  type image_format = string [@@deriving rpcty]
+
   type state = Receiving | Sending | Copying [@@deriving rpcty]
 
   type t = {source_vdi: Vdi.t; dest_vdi: Vdi.t; state: state list; failed: bool}
@@ -998,6 +1002,8 @@ module StorageAPI (R : RPC) = struct
         )
 
     module MIRROR = struct
+      let image_format_p = Param.mk ~name:"image_format" image_format
+
       let mirror_vm_p = Param.mk ~name:"mirror_vm" Vm.t
 
       let copy_vm_p = Param.mk ~name:"copy_vm" Vm.t
@@ -1009,6 +1015,7 @@ module StorageAPI (R : RPC) = struct
           (dbg_p
           @-> sr_p
           @-> vdi_p
+          @-> image_format_p
           @-> dp_p
           @-> mirror_vm_p
           @-> copy_vm_p
@@ -1034,27 +1041,35 @@ module StorageAPI (R : RPC) = struct
         Use the receive_start2 function instead. 
       *)
       let receive_start =
+        let image_format_p =
+          Param.mk ~name:"image_format" Mirror.image_format
+        in
         let similar_p = Param.mk ~name:"similar" Mirror.similars in
         let result = Param.mk ~name:"result" Mirror.mirror_receive_result in
         declare "DATA.MIRROR.receive_start" []
           (dbg_p
           @-> sr_p
           @-> VDI.vdi_info_p
           @-> id_p
+          @-> image_format_p
           @-> similar_p
           @-> returning result err
           )
 
       (** Called on the receiving end to prepare for receipt of the storage. This
       function should be used in conjunction with [receive_finalize2]*)
       let receive_start2 =
+        let image_format_p =
+          Param.mk ~name:"image_format" Mirror.image_format
+        in
         let similar_p = Param.mk ~name:"similar" Mirror.similars in
         let result = Param.mk ~name:"result" Mirror.mirror_receive_result in
         declare "DATA.MIRROR.receive_start2" []
           (dbg_p
           @-> sr_p
           @-> VDI.vdi_info_p
           @-> id_p
+          @-> image_format_p
           @-> similar_p
           @-> vm_p
           @-> returning result err
@@ -1420,6 +1435,7 @@ module type Server_impl = sig
         -> dbg:debug_info
         -> sr:sr
         -> vdi:vdi
+        -> image_format:string
         -> dp:dp
         -> mirror_vm:vm
         -> copy_vm:vm
@@ -1438,6 +1454,7 @@ module type Server_impl = sig
         -> sr:sr
         -> vdi_info:vdi_info
         -> id:Mirror.id
+        -> image_format:Mirror.image_format
         -> similar:Mirror.similars
         -> Mirror.mirror_receive_result
 
@@ -1447,6 +1464,7 @@ module type Server_impl = sig
         -> sr:sr
         -> vdi_info:vdi_info
         -> id:Mirror.id
+        -> image_format:Mirror.image_format
         -> similar:Mirror.similars
         -> vm:vm
         -> Mirror.mirror_receive_result
@@ -1633,17 +1651,20 @@ module Server (Impl : Server_impl) () = struct
         Impl.DATA.copy () ~dbg ~sr ~vdi ~vm ~url ~dest ~verify_dest
     ) ;
     S.DATA.MIRROR.start
-      (fun dbg sr vdi dp mirror_vm copy_vm url dest verify_dest ->
-        Impl.DATA.MIRROR.start () ~dbg ~sr ~vdi ~dp ~mirror_vm ~copy_vm ~url
-          ~dest ~verify_dest
+      (fun dbg sr vdi image_format dp mirror_vm copy_vm url dest verify_dest ->
+        Impl.DATA.MIRROR.start () ~dbg ~sr ~vdi ~image_format ~dp ~mirror_vm
+          ~copy_vm ~url ~dest ~verify_dest
     ) ;
     S.DATA.MIRROR.stop (fun dbg id -> Impl.DATA.MIRROR.stop () ~dbg ~id) ;
     S.DATA.MIRROR.stat (fun dbg id -> Impl.DATA.MIRROR.stat () ~dbg ~id) ;
-    S.DATA.MIRROR.receive_start (fun dbg sr vdi_info id similar ->
-        Impl.DATA.MIRROR.receive_start () ~dbg ~sr ~vdi_info ~id ~similar
+    S.DATA.MIRROR.receive_start (fun dbg sr vdi_info id image_format similar ->
+        Impl.DATA.MIRROR.receive_start () ~dbg ~sr ~vdi_info ~id ~image_format
+          ~similar
     ) ;
-    S.DATA.MIRROR.receive_start2 (fun dbg sr vdi_info id similar vm ->
-        Impl.DATA.MIRROR.receive_start2 () ~dbg ~sr ~vdi_info ~id ~similar ~vm
+    S.DATA.MIRROR.receive_start2
+      (fun dbg sr vdi_info id image_format similar vm ->
+        Impl.DATA.MIRROR.receive_start2 () ~dbg ~sr ~vdi_info ~id ~image_format
+          ~similar ~vm
     ) ;
     S.DATA.MIRROR.receive_cancel (fun dbg id ->
         Impl.DATA.MIRROR.receive_cancel () ~dbg ~id

ocaml/xapi-idl/storage/storage_skeleton.ml

@@ -157,17 +157,18 @@ module DATA = struct
   module MIRROR = struct
     (** [start task sr vdi url sr2] creates a VDI in remote [url]'s [sr2] and
         writes data synchronously. It returns the id of the VDI.*)
-    let start ctx ~dbg ~sr ~vdi ~dp ~mirror_vm ~copy_vm ~url ~dest =
+    let start ctx ~dbg ~sr ~vdi ~image_format ~dp ~mirror_vm ~copy_vm ~url ~dest
+        =
       u "DATA.MIRROR.start"
 
     let stop ctx ~dbg ~id = u "DATA.MIRROR.stop"
 
     let stat ctx ~dbg ~id = u "DATA.MIRROR.stat"
 
-    let receive_start ctx ~dbg ~sr ~vdi_info ~id ~similar =
+    let receive_start ctx ~dbg ~sr ~vdi_info ~id ~image_format ~similar =
       u "DATA.MIRROR.receive_start"
 
-    let receive_start2 ctx ~dbg ~sr ~vdi_info ~id ~similar ~vm =
+    let receive_start2 ctx ~dbg ~sr ~vdi_info ~id ~image_format ~similar ~vm =
       u "DATA.MIRROR.receive_start2"
 
     let receive_finalize ctx ~dbg ~id = u "DATA.MIRROR.receive_finalize"

ocaml/xapi-storage-cli/main.ml

@@ -322,8 +322,11 @@ let mirror_start common_opts sr vdi dp url dest verify_dest =
       let dp = get_opt dp "Need a local data path" in
       let url = get_opt url "Need a URL" in
       let dest = get_opt dest "Need a destination SR" in
+      (* TODO: add image_format as a parameter of the CLI *)
+      let image_format = "" in
       let task =
-        Client.DATA.MIRROR.start dbg sr vdi dp mirror_vm copy_vm url
+        Client.DATA.MIRROR.start dbg sr vdi image_format dp mirror_vm copy_vm
+          url
           (Storage_interface.Sr.of_string dest)
           verify_dest
       in

ocaml/xapi/message_forwarding.ml

@@ -2536,26 +2536,26 @@ functor
              assuming it can ignore this check."
 
       let assert_can_migrate ~__context ~vm ~dest ~live ~vdi_map ~vif_map
-          ~options ~vgpu_map =
+          ~options ~vgpu_map ~vdi_format_map =
         info "VM.assert_can_migrate: VM = '%s'" (vm_uuid ~__context vm) ;
         (* Run the checks that can be done using just the DB directly on the master *)
-        Local.VM.assert_can_migrate ~__context ~vm ~dest ~live ~vdi_map ~vif_map
-          ~vgpu_map ~options ;
+        Local.VM.assert_can_migrate ~__context ~vm ~dest ~live ~vdi_map
+          ~vdi_format_map ~vif_map ~vgpu_map ~options ;
         (* Run further checks on the sending host *)
         assert_can_migrate_sender ~__context ~vm ~dest ~live ~vdi_map ~vif_map
           ~vgpu_map ~options
 
       let migrate_send ~__context ~vm ~dest ~live ~vdi_map ~vif_map ~options
-          ~vgpu_map =
+          ~vgpu_map ~vdi_format_map =
         info "VM.migrate_send: VM = '%s'" (vm_uuid ~__context vm) ;
         let source_host = Db.VM.get_resident_on ~__context ~self:vm in
         let local_fn =
-          Local.VM.migrate_send ~vm ~dest ~live ~vdi_map ~vif_map ~vgpu_map
-            ~options
+          Local.VM.migrate_send ~vm ~dest ~live ~vdi_map ~vdi_format_map
+            ~vif_map ~vgpu_map ~options
         in
         let op session_id rpc =
           Client.VM.migrate_send ~rpc ~session_id ~vm ~dest ~live ~vdi_map
-            ~vif_map ~options ~vgpu_map
+            ~vdi_format_map ~vif_map ~options ~vgpu_map
         in
         let migration_type =
           if Xapi_vm_lifecycle_helpers.is_live ~__context ~self:vm then
@@ -2575,7 +2575,8 @@ functor
                 Helpers.try_internal_async ~__context API.ref_VM_of_rpc
                   (fun () ->
                     Client.InternalAsync.VM.migrate_send ~rpc ~session_id ~vm
-                      ~dest ~live ~vdi_map ~vif_map ~options ~vgpu_map
+                      ~dest ~live ~vdi_map ~vdi_format_map ~vif_map ~options
+                      ~vgpu_map
                   )
                   (fun () -> op session_id rpc)
             )
@@ -2614,7 +2615,7 @@ functor
               Server_helpers.exec_with_subtask ~__context
                 "VM.assert_can_migrate" (fun ~__context ->
                   assert_can_migrate ~__context ~vm ~dest ~live ~vdi_map
-                    ~vif_map ~vgpu_map ~options
+                    ~vdi_format_map ~vif_map ~vgpu_map ~options
               ) ;
               forward_migrate_send ()
           )

ocaml/xapi/storage_migrate.ml

@@ -700,7 +700,7 @@ module MigrateLocal = struct
               ) ;
               vdi_clone
           | None ->
-              debug "Creating a blank remote VDI" ;
+              debug "Creating a blank remote VDI <1>" ;
               Remote.VDI.create dbg dest {local_vdi with sm_config= []}
         in
         let remote_copy =
@@ -721,8 +721,8 @@ module MigrateLocal = struct
     | e ->
         raise (Storage_error (Internal_error (Printexc.to_string e)))
 
-  let start ~task ~dbg ~sr ~vdi ~dp ~mirror_vm ~copy_vm ~url ~dest ~verify_dest
-      =
+  let start ~task ~dbg ~sr ~vdi ~image_format ~dp ~mirror_vm ~copy_vm ~url ~dest
+      ~verify_dest =
     SXM.info
       "%s sr:%s vdi:%s dp: %s mirror_vm: %s copy_vm: %s url:%s dest:%s \
        verify_dest:%B"
@@ -786,8 +786,8 @@ module MigrateLocal = struct
            )
         ) ;
       let (Mirror.Vhd_mirror result) =
-        Remote.DATA.MIRROR.receive_start2 dbg dest local_vdi mirror_id similars
-          mirror_vm
+        Remote.DATA.MIRROR.receive_start2 dbg dest local_vdi mirror_id
+          image_format similars mirror_vm
       in
       (* Enable mirroring on the local machine *)
       let mirror_dp = result.Mirror.mirror_datapath in
@@ -1122,7 +1122,7 @@ end
 (** module [MigrateRemote] is similar to [MigrateLocal], but most of these functions
 tend to be executed on the receiver side. *)
 module MigrateRemote = struct
-  let receive_start_common ~dbg ~sr ~vdi_info ~id ~similar ~vm =
+  let receive_start_common ~dbg ~sr ~vdi_info ~id ~image_format ~similar ~vm =
     let on_fail : (unit -> unit) list ref = ref [] in
     let vdis = Local.SR.scan dbg sr in
     (* We drop cbt_metadata VDIs that do not have any actual data *)
@@ -1183,9 +1183,19 @@ module MigrateRemote = struct
                   vdi_info.virtual_size new_size
             ) ;
             vdi_clone
-        | None ->
-            debug "Creating a blank remote VDI" ;
-            Local.VDI.create dbg sr vdi_info
+        | None -> (
+            debug "Creating a blank remote VDI <2>" ;
+            debug "image_format is set to <%s>" image_format ;
+            match image_format with
+            | "" ->
+                Local.VDI.create dbg sr vdi_info
+            | _ ->
+                Local.VDI.create dbg sr
+                  {
+                    vdi_info with
+                    sm_config= ("type", image_format) :: vdi_info.sm_config
+                  }
+          )
       in
       debug "Parent disk content_id=%s" parent.content_id ;
       State.add id
@@ -1221,11 +1231,12 @@ module MigrateRemote = struct
         !on_fail ;
       raise e
 
-  let receive_start ~dbg ~sr ~vdi_info ~id ~similar =
-    receive_start_common ~dbg ~sr ~vdi_info ~id ~similar ~vm:(Vm.of_string "0")
+  let receive_start ~dbg ~sr ~vdi_info ~id ~image_format ~similar =
+    receive_start_common ~dbg ~sr ~vdi_info ~id ~image_format ~similar
+      ~vm:(Vm.of_string "0")
 
-  let receive_start2 ~dbg ~sr ~vdi_info ~id ~similar ~vm =
-    receive_start_common ~dbg ~sr ~vdi_info ~id ~similar ~vm
+  let receive_start2 ~dbg ~sr ~vdi_info ~id ~image_format ~similar ~vm =
+    receive_start_common ~dbg ~sr ~vdi_info ~image_format ~id ~similar ~vm
 
   let receive_finalize ~dbg ~id =
     let recv_state = State.find_active_receive_mirror id in
@@ -1446,10 +1457,11 @@ let copy ~dbg ~sr ~vdi ~vm ~url ~dest ~verify_dest =
         ~dest ~verify_dest
   )
 
-let start ~dbg ~sr ~vdi ~dp ~mirror_vm ~copy_vm ~url ~dest ~verify_dest =
+let start ~dbg ~sr ~vdi ~image_format ~dp ~mirror_vm ~copy_vm ~url ~dest
+    ~verify_dest =
   with_task_and_thread ~dbg (fun task ->
-      MigrateLocal.start ~task ~dbg:dbg.Debug_info.log ~sr ~vdi ~dp ~mirror_vm
-        ~copy_vm ~url ~dest ~verify_dest
+      MigrateLocal.start ~task ~dbg:dbg.Debug_info.log ~sr ~vdi ~image_format
+        ~dp ~mirror_vm ~copy_vm ~url ~dest ~verify_dest
   )
 
 (* XXX: PR-1255: copy the xenopsd 'raise Exception' pattern *)