Add an option to specify destination format

This patch introduces two options for specifying a destination image
format during migration.

The first option, `dest-img-format`, is used by `vdi-pool-migrate`. The
provided 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.

The second option is used by `vm-migrate`, and allows specifying the
destination format for individual VDIs mapped to a destination SR. The
format is `image-format:<source VDI UUID>=<destination image format>`.
As with VDI pool migration, if the destination 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]
@@ -2409,7 +2412,7 @@ 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."

ocaml/xapi-cli-server/cli_operations.ml

@@ -2060,7 +2060,13 @@ 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 options = [] (* no options implemented yet *) in
+  and options =
+    [
+      List.assoc_opt "dest-img-format" params
+      |> Option.map (fun fmt -> ("dest_img_format", "&dest-img-format=" ^ fmt))
+    ]
+    |> List.filter_map (fun x -> x)
+  in
   let newvdi = Client.VDI.pool_migrate ~rpc ~session_id ~vdi ~sr ~options in
   let newuuid = Client.VDI.get_uuid ~rpc ~session_id ~self:newvdi in
   printer (Cli_printer.PList [newuuid])
@@ -4544,6 +4550,7 @@ let vm_migrate_sxm_params =
   ; "remote-network"
   ; "vdi"
   ; "vgpu"
+  ; "image-format"
   ]
 
 let vm_migrate printer rpc session_id params =
@@ -4691,6 +4698,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 +4871,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,28 @@ 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
+          debug "GTNDEBUG: Local.VM.migrate_send" ;
+          Local.VM.migrate_send ~vm ~dest ~live ~vdi_map ~vdi_format_map
+            ~vif_map ~vgpu_map ~options
         in
         let op session_id rpc =
+          debug "GTNDEBUG: Client.VM.migrate_send" ;
           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
@@ -2568,14 +2570,16 @@ functor
             `Non_live
         in
         let forward_migrate_send () =
+          debug "GTNDEBUG: forward_migrate_send" ;
           let forward_internal_async () =
             forward_vm_op ~local_fn ~__context ~vm (fun session_id rpc ->
                 (* try InternalAsync.VM.migrate_send first to avoid long running idle stunnel connection
                    * fall back on Async.VM.migrate_send if slave doesn't support InternalAsync *)
                 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 +2618,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 ()
           )
@@ -5455,6 +5459,10 @@ functor
         )
 
       let pool_migrate ~__context ~vdi ~sr ~options =
+        debug "GTNDEBUG: pool_migrate from message forwarder...." ;
+        List.iter
+          (fun (s1, s2) -> debug "GTNDEBUG: options (%s, %s)" s1 s2)
+          options ;
         let vbds =
           let expr =
             Xapi_database.Db_filter_types.(