Allow selection of image format during 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.

It also adds a new parameter to `VDI.pool-migrate`. This new parameter
allows to provide a string that is the destination format. This string is
used to check whether the destination SR supports the expected format. If
the check fails or cannot be performed due to missing information on the
destination SR, an error is returned.

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

Author: gthvn1

ocaml/idl/datamodel.ml

@@ -5443,6 +5443,10 @@ module VDI = struct
         [
           (Ref _vdi, "vdi", "The VDI to migrate")
         ; (Ref _sr, "sr", "The destination SR")
+        ; ( String
+          , "dest_img_format"
+          , "The image format to use on destination SR"
+          )
         ; (Map (String, String), "options", "Other parameters")
         ]
       ~result:(Ref _vdi, "The new reference of the migrated VDI.")

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 it's expected type on destination"
+        ; param_release= numbered_release "25.24.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 it's expected type on destination"
+        ; param_release= numbered_release "25.24.0-next"
+        ; param_default= Some (VMap [])
+        }
       ]
     ~allowed_roles:_R_VM_POWER_ADMIN
     ~errs:[Api_errors.license_restriction]

ocaml/xapi-cli-server/cli_frontend.ml

@@ -2468,10 +2468,10 @@ let rec cmdtable_data : (string * cmd_spec) list =
   ; ( "vdi-pool-migrate"
     , {
         reqd= ["uuid"; "sr-uuid"]
-      ; optn= []
+      ; optn= ["dest-img-format"]
       ; help=
-          "Migrate a VDI to a specified SR, while the VDI is attached to a \
-           running guest."
+          "Migrate a VDI to a specified SR, while it is attached to a running \
+           guest. You can specify the image format for the destination."
       ; implementation= No_fd Cli_operations.vdi_pool_migrate
       ; flags= []
       }

ocaml/xapi-cli-server/cli_operations.ml

@@ -2064,8 +2064,12 @@ let vdi_pool_migrate printer rpc session_id params =
     Client.VDI.get_by_uuid ~rpc ~session_id ~uuid:(List.assoc "uuid" params)
   and sr =
     Client.SR.get_by_uuid ~rpc ~session_id ~uuid:(List.assoc "sr-uuid" params)
+  and dest_img_format =
+    List.assoc_opt "dest-img-format" params |> Option.value ~default:""
   and options = [] (* no options implemented yet *) in
-  let newvdi = Client.VDI.pool_migrate ~rpc ~session_id ~vdi ~sr ~options in
+  let newvdi =
+    Client.VDI.pool_migrate ~rpc ~session_id ~vdi ~sr ~dest_img_format ~options
+  in
   let newuuid = Client.VDI.get_uuid ~rpc ~session_id ~self:newvdi in
   printer (Cli_printer.PList [newuuid])
 
@@ -4592,6 +4596,7 @@ let vm_migrate_sxm_params =
   ; "remote-network"
   ; "vdi"
   ; "vgpu"
+  ; "image-format"
   ]
 
 let vm_migrate printer rpc session_id params =
@@ -4896,12 +4901,24 @@ let vm_migrate printer rpc session_id params =
         let token =
           remote Client.Host.migrate_receive ~host ~network ~options
         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 new_vm =
           do_vm_op ~include_control_vms:false ~include_template_vms:true printer
             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

@@ -264,6 +264,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_t = string [@@deriving rpcty]
+
 type sock_path = string [@@deriving rpcty]
 
 type dp_stat_t = {
@@ -1035,6 +1037,8 @@ module StorageAPI (R : RPC) = struct
     declare "get_by_name" [] (dbg_p @-> name_p @-> returning result_p err)
 
   module DATA = struct
+    let image_format_p = Param.mk ~name:"image_format" image_format_t
+
     let url_p = Param.mk ~name:"url" Types.string
 
     let dest_p = Param.mk ~name:"dest" Sr.t
@@ -1066,6 +1070,7 @@ module StorageAPI (R : RPC) = struct
         (dbg_p
         @-> sr_p
         @-> vdi_p
+        @-> image_format_p
         @-> vm_p
         @-> url_p
         @-> returning operation_p err
@@ -1109,6 +1114,8 @@ module StorageAPI (R : RPC) = struct
         )
 
     module MIRROR = struct
+      let image_format_p = Param.mk ~name:"image_format" image_format_t
+
       let mirror_vm_p = Param.mk ~name:"mirror_vm" Vm.t
 
       let copy_vm_p = Param.mk ~name:"copy_vm" Vm.t
@@ -1117,7 +1124,7 @@ module StorageAPI (R : RPC) = struct
 
       let id_p = Param.mk ~name:"id" Mirror.id
 
-      (** [send_start dbg dp task src_sr vdi mirror_vm mirror_id local_vdi copy_vm 
+      (** [send_start dbg dp task src_sr vdi image_format mirror_vm mirror_id local_vdi copy_vm
       live_vm url remote_mirror dest_sr verify_dest]
       takes the remote mirror [remote_mirror] prepared by the destination host 
       and initiates the mirroring of [vdi] from the source *)
@@ -1134,6 +1141,7 @@ module StorageAPI (R : RPC) = struct
           @-> task_id_p
           @-> src_sr_p
           @-> vdi_p
+          @-> image_format_p
           @-> mirror_vm_p
           @-> id_p
           @-> local_vdi_p
@@ -1159,6 +1167,7 @@ module StorageAPI (R : RPC) = struct
           @-> sr_p
           @-> VDI.vdi_info_p
           @-> id_p
+          @-> image_format_p
           @-> similar_p
           @-> returning result err
           )
@@ -1176,6 +1185,7 @@ module StorageAPI (R : RPC) = struct
           @-> sr_p
           @-> VDI.vdi_info_p
           @-> id_p
+          @-> image_format_p
           @-> similar_p
           @-> vm_p
           @-> returning result err
@@ -1191,6 +1201,7 @@ module StorageAPI (R : RPC) = struct
           @-> sr_p
           @-> VDI.vdi_info_p
           @-> id_p
+          @-> image_format_p
           @-> similar_p
           @-> vm_p
           @-> url_p
@@ -1320,6 +1331,7 @@ module type MIRROR = sig
     -> dp:dp
     -> sr:sr
     -> vdi:vdi
+    -> image_format:string
     -> mirror_vm:vm
     -> mirror_id:Mirror.id
     -> local_vdi:vdi_info
@@ -1337,6 +1349,7 @@ module type MIRROR = sig
     -> sr:sr
     -> vdi_info:vdi_info
     -> id:Mirror.id
+    -> image_format:string
     -> similar:Mirror.similars
     -> Mirror.mirror_receive_result
 
@@ -1346,6 +1359,7 @@ module type MIRROR = sig
     -> sr:sr
     -> vdi_info:vdi_info
     -> id:Mirror.id
+    -> image_format:string
     -> similar:Mirror.similars
     -> vm:vm
     -> Mirror.mirror_receive_result
@@ -1356,6 +1370,7 @@ module type MIRROR = sig
     -> sr:sr
     -> vdi_info:vdi_info
     -> mirror_id:Mirror.id
+    -> image_format:string
     -> similar:Mirror.similars
     -> vm:vm
     -> url:string
@@ -1657,6 +1672,7 @@ module type Server_impl = sig
       -> dbg:debug_info
       -> sr:sr
       -> vdi:vdi
+      -> image_format:string
       -> vm:vm
       -> dest:string
       -> operation
@@ -1844,8 +1860,8 @@ module Server (Impl : Server_impl) () = struct
     S.DATA.copy (fun dbg sr vdi vm url dest verify_dest ->
         Impl.DATA.copy () ~dbg ~sr ~vdi ~vm ~url ~dest ~verify_dest
     ) ;
-    S.DATA.mirror (fun dbg sr vdi vm dest ->
-        Impl.DATA.mirror () ~dbg ~sr ~vdi ~vm ~dest
+    S.DATA.mirror (fun dbg sr vdi image_format vm dest ->
+        Impl.DATA.mirror () ~dbg ~sr ~vdi ~image_format ~vm ~dest
     ) ;
     S.DATA.stat (fun dbg sr vdi vm key ->
         Impl.DATA.stat () ~dbg ~sr ~vdi ~vm ~key
@@ -1857,6 +1873,7 @@ module Server (Impl : Server_impl) () = struct
         dp
         sr
         vdi
+        image_format
         mirror_vm
         mirror_id
         local_vdi
@@ -1867,20 +1884,23 @@ module Server (Impl : Server_impl) () = struct
         dest_sr
         verify_dest
       ->
-        Impl.DATA.MIRROR.send_start () ~dbg ~task_id ~dp ~sr ~vdi ~mirror_vm
-          ~mirror_id ~local_vdi ~copy_vm ~live_vm ~url ~remote_mirror ~dest_sr
-          ~verify_dest
+        Impl.DATA.MIRROR.send_start () ~dbg ~task_id ~dp ~sr ~vdi ~image_format
+          ~mirror_vm ~mirror_id ~local_vdi ~copy_vm ~live_vm ~url ~remote_mirror
+          ~dest_sr ~verify_dest
     ) ;
-    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_start3
-      (fun dbg sr vdi_info mirror_id similar vm url verify_dest ->
+      (fun dbg sr vdi_info mirror_id image_format similar vm url verify_dest ->
         Impl.DATA.MIRROR.receive_start3 () ~dbg ~sr ~vdi_info ~mirror_id
-          ~similar ~vm ~url ~verify_dest
+          ~image_format ~similar ~vm ~url ~verify_dest
     ) ;
     S.DATA.MIRROR.receive_cancel (fun dbg id ->
         Impl.DATA.MIRROR.receive_cancel () ~dbg ~id

ocaml/xapi-idl/storage/storage_skeleton.ml

@@ -183,7 +183,7 @@ module DATA = struct
   let copy ctx ~dbg ~sr ~vdi ~vm ~url ~dest =
     Storage_interface.unimplemented __FUNCTION__
 
-  let mirror ctx ~dbg ~sr ~vdi ~vm ~dest =
+  let mirror ctx ~dbg ~sr ~vdi ~image_format ~vm ~dest =
     Storage_interface.unimplemented __FUNCTION__
 
   let stat ctx ~dbg ~sr ~vdi ~vm ~key =
@@ -198,18 +198,19 @@ module DATA = struct
   module MIRROR = struct
     type context = unit
 
-    let send_start ctx ~dbg ~task_id ~dp ~sr ~vdi ~mirror_vm ~mirror_id
-        ~local_vdi ~copy_vm ~live_vm ~url ~remote_mirror ~dest_sr ~verify_dest =
+    let send_start ctx ~dbg ~task_id ~dp ~sr ~vdi ~image_format ~mirror_vm
+        ~mirror_id ~local_vdi ~copy_vm ~live_vm ~url ~remote_mirror ~dest_sr
+        ~verify_dest =
       Storage_interface.unimplemented __FUNCTION__
 
-    let receive_start ctx ~dbg ~sr ~vdi_info ~id ~similar =
+    let receive_start ctx ~dbg ~sr ~vdi_info ~id ~image_format ~similar =
       Storage_interface.unimplemented __FUNCTION__
 
-    let receive_start2 ctx ~dbg ~sr ~vdi_info ~id ~similar ~vm =
+    let receive_start2 ctx ~dbg ~sr ~vdi_info ~id ~image_format ~similar ~vm =
       Storage_interface.unimplemented __FUNCTION__
 
-    let receive_start3 ctx ~dbg ~sr ~vdi_info ~mirror_id ~similar ~vm ~url
-        ~verify_dest =
+    let receive_start3 ctx ~dbg ~sr ~vdi_info ~mirror_id ~image_format ~similar
+        ~vm ~url ~verify_dest =
       Storage_interface.unimplemented __FUNCTION__
 
     let receive_finalize ctx ~dbg ~id =

ocaml/xapi-storage-cli/main.ml

@@ -317,16 +317,19 @@ let copy_vm = Vm.of_string "SXM_copy"
 
 let live_vm = Vm.of_string "live_vm"
 
-let mirror_start common_opts sr vdi dp url dest verify_dest =
+let mirror_start common_opts sr vdi dp url dest verify_dest dest_img_format =
   on_vdi'
     (fun sr vdi ->
       let get_opt x err = match x with Some y -> y | None -> failwith err in
       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
+      let image_format =
+        match dest_img_format with Some s -> s | None -> ""
+      in
       let task =
-        Storage_migrate.start ~dbg ~sr ~vdi ~dp ~mirror_vm ~copy_vm ~live_vm
-          ~url
+        Storage_migrate.start ~dbg ~sr ~vdi ~image_format ~dp ~mirror_vm
+          ~copy_vm ~live_vm ~url
           ~dest:(Storage_interface.Sr.of_string dest)
           ~verify_dest
       in
@@ -531,6 +534,10 @@ let mirror_start_cmd =
     let doc = "Verify certicate of remote server" in
     Arg.(value & pos 5 bool false & info [] ~docv:"VERIFYDEST" ~doc)
   in
+  let dest_img_format =
+    let doc = "Specify the image format on the destination SR" in
+    Arg.(value & pos 6 (some string) None & info [] ~docv:"IMAGEFORMAT" ~doc)
+  in
   ( Term.(
       ret
         (const mirror_start
@@ -541,6 +548,7 @@ let mirror_start_cmd =
         $ url
         $ dest
         $ verify_dest
+        $ dest_img_format
         )
     )
   , Cmd.info "mirror-start" ~sdocs:_common_options ~doc ~man

ocaml/xapi-storage-script/main.ml

@@ -1817,7 +1817,7 @@ module DATAImpl (M : META) = struct
 
   let stat_impl dbg sr vdi vm key = wrap @@ stat dbg sr vdi vm key
 
-  let mirror dbg sr vdi' vm' remote =
+  let mirror dbg sr vdi' image_format vm' remote =
     let vdi = Storage_interface.Vdi.string_of vdi' in
     let domain = Storage_interface.Vm.string_of vm' in
     Attached_SRs.find sr >>>= fun sr ->
@@ -1841,7 +1841,8 @@ module DATAImpl (M : META) = struct
     | MirrorV1 v ->
         return (Storage_interface.Mirror.MirrorV1 v)
 
-  let mirror_impl dbg sr vdi vm remote = wrap @@ mirror dbg sr vdi vm remote
+  let mirror_impl dbg sr vdi image_format vm remote =
+    wrap @@ mirror dbg sr vdi image_format vm remote
 
   let data_import_activate_impl dbg _dp sr vdi' vm' =
     wrap