Support qcow2 format in VDI export/import

Makefile

@@ -173,7 +173,7 @@ DUNE_IU_PACKAGES3=-j $(JOBS) --destdir=$(DESTDIR) --prefix=$(OPTDIR) --libdir=$(
 install-dune3:
 	dune install $(DUNE_IU_PACKAGES3)
 
-DUNE_IU_PACKAGES4=-j $(JOBS) --destdir=$(DESTDIR) --prefix=$(PREFIX) --libdir=$(LIBDIR) --libexecdir=/usr/libexec --mandir=$(MANDIR) vhd-tool forkexec
+DUNE_IU_PACKAGES4=-j $(JOBS) --destdir=$(DESTDIR) --prefix=$(PREFIX) --libdir=$(LIBDIR) --libexecdir=/usr/libexec --mandir=$(MANDIR) vhd-tool qcow-tool forkexec
 
 install-dune4:
 	dune install $(DUNE_IU_PACKAGES4)

dune-project

@@ -420,6 +420,34 @@
   )
 )
 
+(package
+  (name qcow-tool)
+  (synopsis "Manipulate .qcow files")
+  (tags ("org.mirage" "org:xapi-project"))
+  (depends
+    asetmap
+    astring
+    cmdliner
+    cstruct
+    ezjsonm
+    fmt
+    io-page
+    logs
+    lwt
+    mirage-block
+    mirage-block-combinators
+    mirage-block-unix
+    mirage-time
+    mirage-types-lwt
+    ounit
+    prometheus
+    result
+    sexplib
+    sha
+    unix-type-representations
+  )
+)
+
 (package
   (name vhd-tool)
   (synopsis "Manipulate .vhd files")

ocaml/qcow-tool/.circleci/config.yml

@@ -0,0 +1,9 @@
+version: 2
+jobs:
+  build:
+    docker:
+      - image: docker:19.03.11
+    steps:
+      - checkout
+      - setup_remote_docker
+      - run: docker build .

ocaml/qcow-tool/.dockerignore

@@ -0,0 +1,3 @@
+.git
+_build
+Dockerfile

ocaml/qcow-tool/.gitignore

@@ -0,0 +1,16 @@
+*.annot
+*.cmo
+*.cma
+*.cmi
+*.a
+*.o
+*.cmx
+*.cmxs
+*.cmxa
+_build
+*.native
+.coverage/
+*.install
+lib/qcow_word_size.ml
+*.exe
+*.merlin

ocaml/qcow-tool/.travis.yml

@@ -0,0 +1,12 @@
+language: c
+sudo: false
+services:
+  - docker
+install: wget https://raw.githubusercontent.com/ocaml/ocaml-travisci-skeleton/master/.travis-docker.sh
+script: bash ./.travis-docker.sh
+env:
+  global:
+    - PACKAGE="qcow-tool"
+    - PINS="qcow:. mirage-block-ramdisk:https://github.com/mirage/mirage-block-ramdisk.git"
+ matrix:
+   - DISTRO=alpine OCAML_VERSION=4.09

ocaml/qcow-tool/CHANGES.md

@@ -0,0 +1,158 @@
+## 0.11.0 (2020-06-05)
+- Update the build to use `dune` (@emillon, #112)
+- Update to Mirage 4.0 interfaces (@djs55, #112)
+- LICENSE.md: add title and copyright year range (@waldyrious, #109)
+
+## 0.10.5 (2017-12-14):
+- CLI: use the disk locking feature in mirage-block-unix >= 0.9.0
+
+## 0.10.4 (2017-12-07):
+- fix build on OCaml 4.06 (and -safe-string)
+- update to new sha.1.10 signature
+- document the prometheus support
+
+## 0.10.3 (2017-08-02):
+- avoid linking ppx tools into the library
+
+## 0.10.2 (2017-06-18):
+- remove false dependency on cmdliner
+
+## 0.10.1 (2017-06-17):
+- update to new io-page/ io-page-unix
+- fix prometheus accounting error
+
+## 0.10.0 (2017-05-13)
+- fix a major performance problem with `compact`
+- split into 2 packages: qcow and qcow-tool
+- add `qcow-tool dehydrate` and `qcow-tool rehydrate` for extracting
+  metadata for debug/support
+- add prometheus metrics for I/O and GC operations
+- restore the `qcow-tool compact --progress` progress bar
+- add `qcow-tool compact --progress-fd` for json-formatted progress
+- build via jbuilder
+
+## 0.9.5 (2017-03-12)
+- CLI: `check` and `sha` will nolonger resize the file as a side-effect
+  (#84)
+- Allow the number of `cluster_bits` to be set in `create`
+
+## 0.9.4 (2017-03-07)
+- Strictly enforce the cluster move state machine
+- Don't start moving new blocks while existing moves are in progress
+  (fix bug where the same destination block could be reused)
+- Hold a lock to exclude `flush` while updating references to ensure
+  reference updates hit the disk before the move is considered complete
+- Simplify allocator by always adding blocks to the Roots set before
+  returning. The caller must transfer them somewhere else.
+- Simplify the cluster moving API by combining `get_moves` with
+  `start_moves`, so it's not possible to block and affect the moves
+  which can legally be started
+- When detecting a duplicate reference or hitting an I/O error, log
+  analysis of the internal state
+- Check for move cancellation before copying a block to avoid accidentally
+  copying a block which is now outside the file
+- Avoid adding a cluster to the Junk set twice during a reference update
+- Add lots of assertions
+
+## 0.9.3 (2017-03-02)
+- Hold a read lock on the L1 during read/write
+- Minimise locking while updating references
+- When moving an L2 cluster, update the cluster map
+
+## 0.9.2 (2017-02-26)
+- Don't hold the global lock while updating references
+- Log an error if a client I/O takes more than 30s
+- Improve the performance of discard by writing each L2 cluster to disk
+  only once
+- Track clusters which are being erased and copied into, to prevent the
+  file being shrunk, orphaning them (which typically manifests as a later
+  double-allocation)
+
+## 0.9.1 (2017-02-25)
+- Add configuration `runtime_assert` to check GC invariants at runtime
+- Use tail-recursive calls in the block recycler (which deals with large
+  block lists)
+- Wait for the compaction work list to stabilise before processing it
+  (otherwise we move blocks which are then immediately discarded)
+- Track the difference between blocks on the end of the file being full
+  of zeroes due to ftruncate versus being full of junk due to discard
+- On open, truncate the file to erase trailing junk
+- Don't try to use free space between header structures for user data
+  since we assume all blocks after the start of free space are movable
+  and header blocks aren't (in this implementation)
+- Make cluster locks recursive, hold relevant metadata read locks while
+  reading or writing data clusters to ensure they aren't moved while
+  we're using them.
+- Add a debug testing mode and use it in a test case to verify that
+  compact mid-write works as expected.
+
+## 0.9.0 (2017-02-21)
+- Add online coalescing mode and background cluster recycling thread
+- Rename internal modules and types
+- Ensure the interval tree remains balanced to improve performance
+
+## 0.8.1 (2017-02-13)
+- fix error in META file
+
+## 0.8.0 (2017-02-13)
+- update to Mirage 3 APIs
+- now requires OCaml 4.03+
+- ensure the interval tree is kept balanced
+
+## 0.7.2 (2016-12-21)
+- if `discard` is not enabled, fail `discard` calls
+- if `discard` is enabled, enable lazy-refcounts and zero refcount clusters
+  to avoid breaking refcounts over `discard`, `compact`
+
+## 0.7.1 (2016-12-15)
+- speed up `check` and `compact` up to 50x
+- `qcow-tool compact` work around files which aren't a whole number of
+  sectors
+
+## 0.7.0 (2016-12-10)
+- now functorised over `TIME`
+- allow background compact to be cancelled
+- cancel background compact to allow regular I/O to go through
+- don't trigger the background compact until 1s after the last
+  `discard`
+- on `connect`, sanity-check the image
+
+## 0.6.0 (2016-12-04)
+- rename ocamlfind package from `qcow-format` to `qcow` for uniformity
+- add support for runtime configuration arguments to `connect` and `create`
+- add support for `discard` (aka TRIM or UNMAP) and online compaction
+  (through a stop-the-world GC)
+- switch the build from `oasis` to `topkg` (thanks to @jgimenez)
+
+## 0.5.0 (2016-11-26)
+- `resize` now takes a new size in bytes (rather than sectors) and uses a
+  labelled argument
+- `qcow-tool info` now takes a `--filter <expression>` for example
+  `qcow-tool info ... --filter .size` to view the virtual size
+
+## 0.4.2 (2016-09-21)
+- Don't break the build if `Block.connect` has optional arguments
+
+## 0.4.1 (2016-08-17)
+- Remove one necessary source of `flush` calls
+- CLI: add `mapped` command to list the mapped regions of a file
+
+## 0.4 (2016-08-03)
+- For buffered block devices, call `flush` to guarantee metadata correctness
+- In lazy_refcounts mode (the default), do not compute any refcounts
+- CLI: the `repair` command should recompute refcounts
+
+## 0.3 (2016-05-12)
+- Depend on ppx, require OCaml 4.02+
+
+## 0.2 (2016-01-15)
+- Use qcow version 3 by default, setting `lazy_refcount=on`
+- Unit tests now verify that `qemu-img check` is happy and that `qemu-nbd`
+  sees the same data we wrote
+
+## 0.1 (2015-11-09)
+- initial `V1_LWT.BLOCK` support
+- caches metadata for performance
+- CLI tool for manipulating images
+- supports the `seek_mapped` `seek_unmapped` interface for iterating over
+  sparse regions

ocaml/qcow-tool/Dockerfile

@@ -0,0 +1,16 @@
+FROM alpine:latest AS build
+
+RUN apk add opam alpine-sdk
+
+RUN opam init -y --disable-sandboxing --comp=4.10.0
+RUN opam install depext -y
+COPY . /src
+RUN opam pin add qcow.dev /src -n
+RUN opam depext -i qcow -y
+RUN opam pin add qcow-tool.dev /src -n
+RUN opam depext -i qcow-tool -y
+
+FROM alpine:latest
+COPY --from=build /root/.opam/4.10.0/bin/qcow-tool /qcow-tool
+ENTRYPOINT ["/qcow-tool"]
+

ocaml/qcow-tool/LICENSE.md

@@ -0,0 +1,18 @@
+(*
+ * ISC License
+ *
+ * Copyright (c) 2015-2018 <the authors, see individual headers on files>
+ *
+ * Permission to use, copy, modify, and distribute this software for any
+ * purpose with or without fee is hereby granted, provided that the above
+ * copyright notice and this permission notice appear in all copies.
+ *
+ * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ *
+ *)

ocaml/qcow-tool/Makefile

@@ -0,0 +1,14 @@
+
+.PHONY: build clean
+
+build:
+	dune build @install
+
+install:
+	dune install
+
+uninstall:
+	dune uninstall
+
+clean:
+	dune clean

ocaml/qcow-tool/README.md

@@ -0,0 +1,94 @@
+Ocaml support for Qcow2 images
+==============================
+
+[![Build Status](https://travis-ci.org/mirage/ocaml-qcow.png?branch=master)](https://travis-ci.org/mirage/ocaml-qcow) [![Coverage Status](https://coveralls.io/repos/mirage/ocaml-qcow/badge.png?branch=master)](https://coveralls.io/r/mirage/ocaml-qcow?branch=master)
+
+Please read [the API documentation](https://mirage.github.io/ocaml-qcow/).
+
+Features
+--------
+
+- supports `resize`
+- exposes sparseness information
+- produces files which can be understood by qemu (although not in
+  reverse since we don't support many features)
+
+Example
+-------
+
+In a top-level like utop:
+```ocaml
+# #require "io-page.unix";;
+# #require "mirage-block";;
+# #require "mirage-block-ramdisk";;
+# #require "qcow";;
+# #require "lwt.syntax";;
+
+# lwt t_or_error = Ramdisk.create ~name:"hello" ~size_sectors:1024L ~sector_size:512;;
+val t_or_error : [ `Error of Ramdisk.error | `Ok of Ramdisk.t ] = `Ok <abstr>
+
+# let t = Mirage_block.Error.ok_exn t_or_error;;
+val t : Ramdisk.t = <abstr>
+
+# module Qcow_on_ramdisk = Qcow.Make(Ramdisk);;
+module Qcow_on_ramdisk :                                                          sig                                                                               type page_aligned_buffer = Ramdisk.page_aligned_buffer
+    type error =
+        [ `Disconnected | `Is_read_only | `Unimplemented | `Unknown of bytes ]
+    type 'a io = 'a Ramdisk.io
+    type t = Qcow.Make(Ramdisk).t
+    type id = Qcow.Make(Ramdisk).id
+    val disconnect : t -> unit io
+    type info =
+      Qcow.Make(Ramdisk).info = {
+      read_write : bool;
+      sector_size : int;
+      size_sectors : int64;
+    }
+    val get_info : t -> info io
+    val read :
+      t ->
+      int64 -> page_aligned_buffer list -> [ `Error of error | `Ok of unit ] io
+    val write :
+      t ->
+      int64 -> page_aligned_buffer list -> [ `Error of error | `Ok of unit ] io
+    val create : Ramdisk.t -> int64 -> [ `Error of error | `Ok of t ] io
+    val connect : Ramdisk.t -> t io
+    val resize : t -> int64 -> [ `Error of error | `Ok of unit ] io
+    val seek_unmapped : t -> int64 -> [ `Error of error | `Ok of int64 ] io
+    val seek_mapped : t -> int64 -> [ `Error of error | `Ok of int64 ] io
+    val rebuild_refcount_table : t -> [ `Error of error | `Ok of unit ] io
+    val header : t -> Qcow.Header.t
+    module Debug :
+      sig
+        type t = Qcow.Make(Ramdisk).t
+        type error = error
+        val check_no_overlaps : t -> [ `Error of error | `Ok of unit ] io
+        val set_next_cluster : t -> int64 -> unit
+      end
+  end
+
+# lwt t_or_error = Qcow_on_ramdisk.create t 1048576L;;
+val t_or_error : [ `Error of Qcow_on_ramdisk.error | `Ok of Qcow_on_ramdisk.t ]
+  = `Ok <abstr>
+
+# let t = Mirage_block.Error.ok_exn t_or_error;;
+val t : Qcow_on_ramdisk.t = <abstr>
+
+# let page = Io_page.(to_cstruct (get 1));;
+val page : Ramdisk.page_aligned_buffer =
+  {Cstruct.buffer = <abstr>; off = 0; len = 4096}
+
+# lwt result_or_error = Qcow_on_ramdisk.read t 0L [ page ];;
+val result_or_error : [ `Error of Ramdisk.error | `Ok of unit ] = `Ok ()
+
+# lwt ok_or_error = Mirage_block.sparse_copy (module Ramdisk) t (module Ramdisk) t;;
+val ok_or_error :
+  [ `Error of [> `Different_sizes | `Is_read_only | `Msg of bytes ]
+  | `Ok of unit ] = `Ok ()
+```
+
+Limitations
+-----------
+
+- cluster size is fixed at 64-bits
+- no support for snapshots