Integrate QCOW2 import-export

dune-project

@@ -402,6 +402,7 @@
     (= :version))) ; the public library is only used for testing
   integers
   ipaddr
+  qcow-stream
   logs
   magic-mime
   mirage-crypto

ocaml/tests/unix_select.gawk

@@ -35,7 +35,7 @@ END {
     for (idx in CALLS[SYM]) {
       caller = CALLS[SYM][idx];
       print "--"
-      if (caller ~ /caml(Thread|Unix__fun_).*/) {
+      if (caller ~ /caml(Thread|Unix__fun_|Lwt_engine__fun_).*/) {
         # direct calls from these functions to unix_select are expected
         print caller "[expected]"
       } else {

ocaml/xapi/dune

@@ -164,6 +164,7 @@
   psq
   ptime
   ptime.clock.os
+  qcow-stream
   rpclib.core
   rpclib.json
   rpclib.xml

ocaml/xapi/export_raw_vdi.ml

@@ -47,12 +47,18 @@ let localhost_handler rpc session_id vdi (req : Http.Request.t)
           let copy base_path path size =
             try
               debug "Copying VDI contents..." ;
-              Vhd_tool_wrapper.send ?relative_to:base_path
-                (Vhd_tool_wrapper.update_task_progress __context)
-                "none"
-                (Importexport.Format.to_string format)
-                s path size "" ;
-              debug "Copying VDI complete."
+              match format with
+              | Qcow ->
+                  Qcow_tool_wrapper.send
+                    (Qcow_tool_wrapper.update_task_progress __context)
+                    s path size
+              | Vhd | Tar | Raw ->
+                  Vhd_tool_wrapper.send ?relative_to:base_path
+                    (Vhd_tool_wrapper.update_task_progress __context)
+                    "none"
+                    (Importexport.Format.to_string format)
+                    s path size "" ;
+                  debug "Copying VDI complete."
             with Unix.Unix_error (Unix.EIO, _, _) ->
               raise
                 (Api_errors.Server_error
@@ -73,7 +79,7 @@ let localhost_handler rpc session_id vdi (req : Http.Request.t)
             in
             Http_svr.headers s headers ;
             match format with
-            | Raw | Vhd ->
+            | Raw | Vhd | Qcow ->
                 let size = Db.VDI.get_virtual_size ~__context ~self:vdi in
                 if format = Vhd && size > Constants.max_vhd_size then
                   raise

ocaml/xapi/import_raw_vdi.ml

@@ -106,6 +106,10 @@ let localhost_handler rpc session_id vdi_opt (req : Request.t)
                      )
                   )
             | None ->
+                (* FIXME: Currently, when importing an image with a virtual
+                   size that's bigger than the VDI's virtual size, we fail in
+                   an unhelpful manner on some write.
+                   We could instead parse the header first and fail early. *)
                 let vdi =
                   match
                     ( vdi_opt
@@ -122,6 +126,22 @@ let localhost_handler rpc session_id vdi_opt (req : Request.t)
                         ~virtual_size:length ~_type:`user ~sharable:false
                         ~read_only:false ~other_config:[] ~xenstore_data:[]
                         ~sm_config:[] ~tags:[]
+                  | None, Importexport.Format.Qcow, _, _ ->
+                      error
+                        "Importing a QCOW2 directly into an SR not yet \
+                         supported" ;
+                      raise
+                        (HandleError
+                           ( Api_errors.Server_error
+                               ( Api_errors.internal_error
+                               , [
+                                   "Importing a QCOW2 directly into an SR not \
+                                    yet supported"
+                                 ]
+                               )
+                           , Http.http_400_badrequest ~version:"1.0" ()
+                           )
+                        )
                   | None, Importexport.Format.Vhd, _, _ ->
                       error
                         "Importing a VHD directly into an SR not yet supported" ;
@@ -158,6 +178,13 @@ let localhost_handler rpc session_id vdi_opt (req : Request.t)
                 in
                 Http_svr.headers s headers ;
                 ( match format with
+                | Qcow ->
+                    Sm_fs_ops.with_block_attached_device __context rpc
+                      session_id vdi `RW (fun path ->
+                        Qcow_tool_wrapper.receive
+                          (Qcow_tool_wrapper.update_task_progress __context)
+                          s path
+                    )
                 | Raw | Vhd ->
                     let prezeroed =
                       not

ocaml/xapi/importexport.ml

@@ -430,9 +430,17 @@ let sr_of_req ~__context (req : Http.Request.t) =
     None
 
 module Format = struct
-  type t = Raw | Vhd | Tar
+  type t = Raw | Vhd | Tar | Qcow
 
-  let to_string = function Raw -> "raw" | Vhd -> "vhd" | Tar -> "tar"
+  let to_string = function
+    | Raw ->
+        "raw"
+    | Vhd ->
+        "vhd"
+    | Tar ->
+        "tar"
+    | Qcow ->
+        "qcow2"
 
   let of_string x =
     match String.lowercase_ascii x with
@@ -442,6 +450,8 @@ module Format = struct
         Some Vhd
     | "tar" ->
         Some Tar
+    | "qcow2" ->
+        Some Qcow
     | _ ->
         None
 
@@ -457,6 +467,8 @@ module Format = struct
         "application/vhd"
     | Tar ->
         "application/x-tar"
+    | Qcow ->
+        "application/x-qemu-disk"
 
   let _key = "format"
 

ocaml/xapi/qcow_tool_wrapper.ml

@@ -0,0 +1,56 @@
+(*
+ * Copyright (C) 2025 Vates.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as published
+ * by the Free Software Foundation; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU Lesser General Public License for more details.
+ *)
+
+module D = Debug.Make (struct let name = "qcow_tool_wrapper" end)
+
+open D
+
+let run_qcow_tool (_progress_cb : int -> unit) (args : string list)
+    (ufd : Unix.file_descr) =
+  let qcow_tool = !Xapi_globs.qcow_to_stdout in
+  info "Executing %s %s" qcow_tool (String.concat " " args) ;
+  let open Forkhelpers in
+  match
+    with_logfile_fd "qcow-tool" (fun log_fd ->
+        let pid =
+          safe_close_and_exec None (Some ufd) (Some log_fd) [] qcow_tool args
+        in
+        let _, status = waitpid pid in
+        if status <> Unix.WEXITED 0 then (
+          error "qcow-tool failed, returning VDI_IO_ERROR" ;
+          raise
+            (Api_errors.Server_error
+               (Api_errors.vdi_io_error, ["Device I/O errors"])
+            )
+        )
+    )
+  with
+  | Success (out, _) ->
+      debug "qcow-tool successful export (%s)" out
+  | Failure (out, _e) ->
+      error "qcow-tool output: %s" out ;
+      raise (Api_errors.Server_error (Api_errors.vdi_io_error, [out]))
+
+let update_task_progress (__context : Context.t) (x : int) =
+  TaskHelper.set_progress ~__context (float_of_int x /. 100.)
+
+let receive (progress_cb : int -> unit) (unix_fd : Unix.file_descr)
+    (path : string) =
+  debug "Calling Qcow_stream.stream_decode (output_path = '%s')" path ;
+  Qcow_stream.stream_decode ~progress_cb unix_fd path
+
+let send (progress_cb : int -> unit) (unix_fd : Unix.file_descr) (path : string)
+    (_size : Int64.t) =
+  let args = [path] in
+  run_qcow_tool progress_cb args unix_fd

opam/xapi.opam

@@ -34,6 +34,7 @@ depends: [
   "http-lib" {with-test & = version}
   "integers"
   "ipaddr"
+  "qcow-stream"
   "logs"
   "magic-mime"
   "mirage-crypto"