Skip to content

Support qcow2 format in VDI export/import #6396

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Closed
wants to merge 10 commits into from
Closed

Support qcow2 format in VDI export/import #6396

Show file tree
Hide file tree
Changes from 1 commit
Commits
Show all changes
10 commits
Select commit Hold shift + click to select a range
0647d38
[qcow-tool packaging] import qcow-tool from ocaml-qcow
gthvn1 Mar 17, 2025
c2621a6
[qcow-tool packaging] build fix: use io-page instead of io-page-unix
gthvn1 Mar 18, 2025
9bd40d4
[qcow-tool packaging] build fix: cstruct
gthvn1 Mar 18, 2025
def1cf6
[qcow-tool packaging] build fix: remove Unimplemented variant
gthvn1 Mar 18, 2025
81232c5
[qcow-tool packaging] build fix: update cmdliner
gthvn1 Mar 18, 2025
05b56c4
[qcow-tool packaging] package it in xapi
gthvn1 Mar 18, 2025
2f6c847
[qcow-tool packaging] remove lib-test
gthvn1 Mar 21, 2025
ecc0ee1
[qcow-tool] run make format
gthvn1 Mar 26, 2025
15f0f6e
[qcow-tool] add qcow as supported format
gthvn1 Dec 16, 2024
d77adf5
[qcow-tool] [WIP] implement streaming
gthvn1 Mar 28, 2025
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
5 changes: 1 addition & 4 deletions ocaml/qcow-tool/lib/qcow.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -324,7 +324,6 @@ module Make(Base: Qcow_s.RESIZABLE_BLOCK)(Time: Mirage_time.S) = struct
let open Lwt.Infix in
loop 0
>>= function
| Error `Unimplemented -> Lwt.return (Error `Unimplemented)
| Error `Disconnected -> Lwt.return (Error `Disconnected)
| Error `Is_read_only -> Lwt.return (Error (`Msg "Device is read only"))
| Error (`Msg m) -> Lwt.return (Error (`Msg m))
Expand Down Expand Up @@ -1432,7 +1431,6 @@ module Make(Base: Qcow_s.RESIZABLE_BLOCK)(Time: Mirage_time.S) = struct
(fun () ->
B.read base sector [ buf ]
>>= function
| Error (#Mirage_device.error as e) -> Lwt.return_error e
| Error _ -> Lwt.fail_with "unknown error"
| Ok () -> Lwt.return (Ok buf)
) (fun e ->
Expand All @@ -1451,7 +1449,6 @@ module Make(Base: Qcow_s.RESIZABLE_BLOCK)(Time: Mirage_time.S) = struct
(fun () ->
B.write base sector [ buf ]
>>= function
| Error `Unimplemented -> Lwt.return (Error `Unimplemented)
| Error `Disconnected -> Lwt.return (Error `Disconnected)
| Error `Is_read_only -> Lwt.return (Error `Is_read_only)
| Error _ -> Lwt.fail_with "unknown error"
Expand Down Expand Up @@ -1645,7 +1642,7 @@ module Make(Base: Qcow_s.RESIZABLE_BLOCK)(Time: Mirage_time.S) = struct
let open Lwt_write_error.Infix in
( if not(t.config.Config.discard) then begin
Log.err (fun f -> f "discard called but feature not implemented in configuration");
Lwt.return (Error `Unimplemented)
Lwt.fail (Failure "Unimplemented")
end else Lwt.return (Ok ()) )
>>= fun () ->
Counter.inc (Metrics.discards t.config.Config.id) Int64.(to_float @@ mul n @@ of_int t.sector_size);
Expand Down
4 changes: 2 additions & 2 deletions ocaml/qcow-tool/lib/qcow_cluster_map.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -342,8 +342,8 @@ let zero =
let free = Qcow_bitmap.make_empty ~initial_size:0 ~maximum_size:0 in
let refs = Cluster.Map.empty in
let cache = Cache.create
~read_cluster:(fun _ -> Lwt.return (Error `Unimplemented))
~write_cluster:(fun _ _ -> Lwt.return (Error `Unimplemented))
~read_cluster:(fun _ -> Lwt.fail (Failure "Unimplemented"))
~write_cluster:(fun _ _ -> Lwt.fail (Failure "Unimplemented"))
() in
make ~free ~refs ~first_movable_cluster:Cluster.zero ~cache ~runtime_asserts:false ~id:None ~cluster_size:0

Expand Down
4 changes: 2 additions & 2 deletions ocaml/qcow-tool/lib/qcow_debug.mli
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -18,9 +18,9 @@ open Qcow_types

val on_duplicate_reference: Qcow_metadata.t -> Qcow_cluster_map.t -> cluster_bits:int ->
(int64 * int) -> (int64 * int) -> int64 ->
(unit, [> `Disconnected | `Is_read_only | `Msg of string | `Unimplemented ]) result Lwt.t
(unit, [> `Disconnected | `Is_read_only | `Msg of string ]) result Lwt.t

val check_references: Qcow_metadata.t -> Qcow_cluster_map.t -> cluster_bits:int -> Cluster.t ->
(unit, [> `Disconnected | `Is_read_only | `Msg of string | `Unimplemented ]) result Lwt.t
(unit, [> `Disconnected | `Is_read_only | `Msg of string ]) result Lwt.t
(** [check_references metadata map cluster_bits target] follows the back references
from physical offset [target], verifying the references on disk as it goes *)
4 changes: 0 additions & 4 deletions ocaml/qcow-tool/lib/qcow_error.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -41,15 +41,13 @@ module Lwt_error = struct
let ( >>= ) m f = m >>= function
| Ok x -> f x
| Error (`Msg s) -> Lwt.return (Error (`Msg s))
| Error `Unimplemented -> Lwt.return (Error `Unimplemented)
| Error `Disconnected -> Lwt.return (Error `Disconnected)
end

let or_fail_with m =
let open Lwt in
m >>= function
| Error (`Msg s) -> Lwt.fail_with s
| Error `Unimplemented -> Lwt.fail_with "unimplemented"
| Error `Disconnected -> Lwt.fail_with "disconnected"
| Ok x -> Lwt.return x

Expand All @@ -76,14 +74,12 @@ module Lwt_write_error = struct
| Ok x -> f x
| Error (`Msg s) -> Lwt.return (Error (`Msg s))
| Error `Is_read_only -> Lwt.return (Error `Is_read_only)
| Error `Unimplemented -> Lwt.return (Error `Unimplemented)
| Error `Disconnected -> Lwt.return (Error `Disconnected)
end
let or_fail_with m =
let open Lwt in
m >>= function
| Error (`Msg s) -> Lwt.fail_with s
| Error `Unimplemented -> Lwt.fail_with "unimplemented"
| Error `Is_read_only -> Lwt.fail_with "is read only"
| Error `Disconnected -> Lwt.fail_with "disconnected"
| Ok x -> Lwt.return x
Expand Down
12 changes: 6 additions & 6 deletions ocaml/qcow-tool/lib/qcow_error.mli
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -36,15 +36,15 @@ val any: (unit, 'b) result list -> (unit, 'b) result
module Lwt_error: sig
module Infix: sig
val ( >>= ) :
('a, [< `Disconnected | `Msg of 'b | `Unimplemented ]) result Lwt.t ->
('a, [< `Disconnected | `Msg of 'b ]) result Lwt.t ->
('a ->
('c, [> `Disconnected | `Msg of 'b | `Unimplemented ] as 'd) result
('c, [> `Disconnected | `Msg of 'b ] as 'd) result
Lwt.t) ->
('c, 'd) result Lwt.t
end

val or_fail_with :
('a, [< `Disconnected | `Msg of string | `Unimplemented ]) result Lwt.t ->
('a, [< `Disconnected | `Msg of string ]) result Lwt.t ->
'a Lwt.t

module List: sig
Expand All @@ -60,18 +60,18 @@ module Lwt_write_error : sig
module Infix: sig
val ( >>= ) :
('a,
[< `Disconnected | `Is_read_only | `Msg of 'b | `Unimplemented ])
[< `Disconnected | `Is_read_only | `Msg of 'b ])
result Lwt.t ->
('a ->
('c,
[> `Disconnected | `Is_read_only | `Msg of 'b | `Unimplemented ]
[> `Disconnected | `Is_read_only | `Msg of 'b ]
as 'd)
result Lwt.t) ->
('c, 'd) result Lwt.t
end
val or_fail_with :
('a,
[< `Disconnected | `Is_read_only | `Msg of string | `Unimplemented ])
[< `Disconnected | `Is_read_only | `Msg of string ])
result Lwt.t -> 'a Lwt.t
end

Expand Down
1 change: 0 additions & 1 deletion ocaml/qcow-tool/lib/qcow_metadata.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -137,6 +137,5 @@ let update ?client t cluster f =
>>= function
| Error `Is_read_only -> Lwt.return (Error `Is_read_only)
| Error `Disconnected -> Lwt.return (Error `Disconnected)
| Error `Unimplemented -> Lwt.return (Error `Unimplemented)
| Ok () -> Lwt.return (Ok result)
)
3 changes: 1 addition & 2 deletions ocaml/qcow-tool/lib/qcow_padded.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -21,9 +21,8 @@ module Make(B: Qcow_s.RESIZABLE_BLOCK) = struct
include B

let handle_error = function
| `Unimplemented -> Lwt.return (Error `Unimplemented)
| `Disconnected -> Lwt.return (Error `Disconnected)
| e -> Format.kasprintf Lwt.fail_with "Unknown error: %a" B.pp_error e
| _ -> Format.kasprintf Lwt.fail_with "Unknown error in qcow_paddle.ml"

let read base base_sector buf =
let open Lwt in
Expand Down
6 changes: 1 addition & 5 deletions ocaml/qcow-tool/lib/qcow_recycler.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -81,13 +81,11 @@ module Make(B: Qcow_s.RESIZABLE_BLOCK)(Time: Mirage_time.S) = struct
let open Lwt.Infix in
B.read t.base src_sector [ cluster ]
>>= function
| Error `Unimplemented -> Lwt.return (Error `Unimplemented)
| Error `Disconnected -> Lwt.return (Error `Disconnected)
| Error e -> Format.kasprintf Lwt.fail_with "Unknown error: %a" B.pp_error e
| Ok () ->
B.write t.base dst_sector [ cluster ]
>>= function
| Error `Unimplemented -> Lwt.return (Error `Unimplemented)
| Error `Disconnected -> Lwt.return (Error `Disconnected)
| Error `Is_read_only -> Lwt.return (Error `Is_read_only)
| Error e -> Format.kasprintf Lwt.fail_with "Unknown error: %a" B.pp_write_error e
Expand Down Expand Up @@ -134,10 +132,9 @@ module Make(B: Qcow_s.RESIZABLE_BLOCK)(Time: Mirage_time.S) = struct
end else begin
copy_already_locked t src dst
>>= function
| Error `Unimplemented -> Lwt.return (Error `Unimplemented)
| Error `Disconnected -> Lwt.return (Error `Disconnected)
| Error `Is_read_only -> Lwt.return (Error `Is_read_only)
| Error e -> Format.kasprintf Lwt.fail_with "Unknown error: %a" B.pp_write_error e
| Error _ -> Format.kasprintf Lwt.fail_with "Unknown error in qcow_recylcer.ml"
Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I'd rather keep printing the error here, otherwise you might have a bad time debugging the cause

| Ok () ->
Qcow_cluster_map.(set_move_state cluster_map move Copied);
Lwt.return (Ok ())
Expand Down Expand Up @@ -549,7 +546,6 @@ module Make(B: Qcow_s.RESIZABLE_BLOCK)(Time: Mirage_time.S) = struct
begin update_references t
>>= function
| Error (`Msg x) -> Lwt.fail_with x
| Error `Unimplemented -> Lwt.fail_with "Unimplemented"
| Error `Disconnected -> Lwt.fail_with "Disconnected"
| Error `Is_read_only -> Lwt.fail_with "Is_read_only"
| Ok nr_updated ->
Expand Down
2 changes: 0 additions & 2 deletions ocaml/qcow-tool/lib_test/error.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -21,7 +21,6 @@ module Lwt_error = struct
module Infix = struct
let ( >>= ) m f = m >>= function
| Ok x -> f x
| Error `Unimplemented -> Lwt.fail_with "Unimplemented"
| Error `Disconnected -> Lwt.fail_with "Disconnected"
| Error _ -> Lwt.fail_with "Unknown error"
end
Expand All @@ -33,7 +32,6 @@ module Lwt_write_error = struct
let ( >>= ) m f = m >>= function
| Ok x -> f x
| Error `Is_read_only -> Lwt.fail_with "Is_read_only"
| Error `Unimplemented -> Lwt.fail_with "Unimplemented"
| Error `Disconnected -> Lwt.fail_with "Disconnected"
| Error _ -> Lwt.fail_with "Unknown error"
end
Expand Down
4 changes: 2 additions & 2 deletions ocaml/qcow-tool/lib_test/error.mli
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -19,15 +19,15 @@ open Result
module Lwt_error: sig
module Infix : sig
val ( >>= ) :
('a, [> `Disconnected | `Unimplemented ]) result Lwt.t ->
('a, [> `Disconnected ]) result Lwt.t ->
('a -> 'b Lwt.t) -> 'b Lwt.t
end
end

module Lwt_write_error: sig
module Infix : sig
val ( >>= ) :
('a, [> `Is_read_only | `Disconnected | `Unimplemented ]) result Lwt.t ->
('a, [> `Is_read_only | `Disconnected ]) result Lwt.t ->
('a -> 'b Lwt.t) -> 'b Lwt.t
end
end
Expand Down