├── .circleci └── config.yml ├── .dockerignore ├── .gitignore ├── .merlin ├── CHANGES.md ├── Dockerfile ├── LICENSE.md ├── Makefile ├── README.md ├── cli ├── common.ml ├── dune ├── encode_decode.t ├── impl.ml └── main.ml ├── doc ├── TRIM.md ├── dashboard.json ├── prometheus.md └── prometheus.yml ├── dune-project ├── generator ├── dune └── gen.ml ├── lib ├── dune ├── qcow.ml ├── qcow.mli ├── qcow.mllib ├── qcow_bitmap.ml ├── qcow_bitmap.mli ├── qcow_block_cache.ml ├── qcow_block_cache.mli ├── qcow_cache.ml ├── qcow_cache.mli ├── qcow_cluster_map.ml ├── qcow_cluster_map.mli ├── qcow_config.ml ├── qcow_config.mli ├── qcow_cstructs.ml ├── qcow_cstructs.mli ├── qcow_debug.ml ├── qcow_debug.mli ├── qcow_diet.ml ├── qcow_diet.mli ├── qcow_error.ml ├── qcow_error.mli ├── qcow_header.ml ├── qcow_header.mli ├── qcow_int.ml ├── qcow_int.mli ├── qcow_int64.ml ├── qcow_int64.mli ├── qcow_locks.ml ├── qcow_locks.mli ├── qcow_metadata.ml ├── qcow_metadata.mli ├── qcow_padded.ml ├── qcow_padded.mli ├── qcow_physical.ml ├── qcow_physical.mli ├── qcow_recycler.ml ├── qcow_recycler.mli ├── qcow_rwlock.ml ├── qcow_rwlock.mli ├── qcow_s.ml ├── qcow_s.mli ├── qcow_stream.ml ├── qcow_stream.mli ├── qcow_types.ml ├── qcow_types.mli ├── qcow_virtual.ml ├── qcow_virtual.mli └── qcow_word_size.mli ├── lib_test ├── compact_random.ml ├── dune ├── error.ml ├── error.mli ├── extent.ml ├── qemu.ml ├── qemu.mli ├── sizes.ml ├── test.ml └── utils.ml ├── pkg └── pkg.ml ├── qcow-stream.opam ├── qcow-tool.opam ├── qcow-types.opam └── qcow.opam /.circleci/config.yml: -------------------------------------------------------------------------------- 1 | version: 2 2 | jobs: 3 | build: 4 | docker: 5 | - image: docker:19.03.11 6 | steps: 7 | - checkout 8 | - setup_remote_docker 9 | - run: docker build . 10 | -------------------------------------------------------------------------------- /.dockerignore: -------------------------------------------------------------------------------- 1 | .git 2 | _build 3 | Dockerfile 4 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.annot 2 | *.cmo 3 | *.cma 4 | *.cmi 5 | *.a 6 | *.o 7 | *.cmx 8 | *.cmxs 9 | *.cmxa 10 | _build 11 | *.native 12 | .coverage/ 13 | *.install 14 | lib/qcow_word_size.ml 15 | *.exe 16 | *.merlin 17 | -------------------------------------------------------------------------------- /.merlin: -------------------------------------------------------------------------------- 1 | PKG astring cmdliner cstruct logs lwt mirage-block mirage-block-unix ppx_sexp_conv ppx_tools ppx_type_conv 2 | PKG io-page io-page.unix logs.fmt result sexplib 3 | PKG ezjsonm mirage-block-ramdisk nbd ounit 4 | S lib 5 | S lib_test 6 | B _build/** 7 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | ## 0.12.1 (2025-06-02) 2 | - Fix dune and opam metadata issues (@psafont #129) 3 | 4 | ## 0.12.0 (2025-05-29) 5 | 6 | - Build fixes (@last-genius, #123) 7 | - Further fixes: parsing, CLI, overallocation (@last-genius, #124) 8 | - remove mirage-types, add mirage-sleep dependency (@hannesm, #125) 9 | - Add x-maintenance-intent to opam files (@hannesm, #126) 10 | - Add a Qcow_stream module (@last-genius, #127) 11 | 12 | ## 0.11.0 (2020-06-05) 13 | - Update the build to use `dune` (@emillon, #112) 14 | - Update to Mirage 4.0 interfaces (@djs55, #112) 15 | - LICENSE.md: add title and copyright year range (@waldyrious, #109) 16 | 17 | ## 0.10.5 (2017-12-14): 18 | - CLI: use the disk locking feature in mirage-block-unix >= 0.9.0 19 | 20 | ## 0.10.4 (2017-12-07): 21 | - fix build on OCaml 4.06 (and -safe-string) 22 | - update to new sha.1.10 signature 23 | - document the prometheus support 24 | 25 | ## 0.10.3 (2017-08-02): 26 | - avoid linking ppx tools into the library 27 | 28 | ## 0.10.2 (2017-06-18): 29 | - remove false dependency on cmdliner 30 | 31 | ## 0.10.1 (2017-06-17): 32 | - update to new io-page/ io-page-unix 33 | - fix prometheus accounting error 34 | 35 | ## 0.10.0 (2017-05-13) 36 | - fix a major performance problem with `compact` 37 | - split into 2 packages: qcow and qcow-tool 38 | - add `qcow-tool dehydrate` and `qcow-tool rehydrate` for extracting 39 | metadata for debug/support 40 | - add prometheus metrics for I/O and GC operations 41 | - restore the `qcow-tool compact --progress` progress bar 42 | - add `qcow-tool compact --progress-fd` for json-formatted progress 43 | - build via jbuilder 44 | 45 | ## 0.9.5 (2017-03-12) 46 | - CLI: `check` and `sha` will nolonger resize the file as a side-effect 47 | (#84) 48 | - Allow the number of `cluster_bits` to be set in `create` 49 | 50 | ## 0.9.4 (2017-03-07) 51 | - Strictly enforce the cluster move state machine 52 | - Don't start moving new blocks while existing moves are in progress 53 | (fix bug where the same destination block could be reused) 54 | - Hold a lock to exclude `flush` while updating references to ensure 55 | reference updates hit the disk before the move is considered complete 56 | - Simplify allocator by always adding blocks to the Roots set before 57 | returning. The caller must transfer them somewhere else. 58 | - Simplify the cluster moving API by combining `get_moves` with 59 | `start_moves`, so it's not possible to block and affect the moves 60 | which can legally be started 61 | - When detecting a duplicate reference or hitting an I/O error, log 62 | analysis of the internal state 63 | - Check for move cancellation before copying a block to avoid accidentally 64 | copying a block which is now outside the file 65 | - Avoid adding a cluster to the Junk set twice during a reference update 66 | - Add lots of assertions 67 | 68 | ## 0.9.3 (2017-03-02) 69 | - Hold a read lock on the L1 during read/write 70 | - Minimise locking while updating references 71 | - When moving an L2 cluster, update the cluster map 72 | 73 | ## 0.9.2 (2017-02-26) 74 | - Don't hold the global lock while updating references 75 | - Log an error if a client I/O takes more than 30s 76 | - Improve the performance of discard by writing each L2 cluster to disk 77 | only once 78 | - Track clusters which are being erased and copied into, to prevent the 79 | file being shrunk, orphaning them (which typically manifests as a later 80 | double-allocation) 81 | 82 | ## 0.9.1 (2017-02-25) 83 | - Add configuration `runtime_assert` to check GC invariants at runtime 84 | - Use tail-recursive calls in the block recycler (which deals with large 85 | block lists) 86 | - Wait for the compaction work list to stabilise before processing it 87 | (otherwise we move blocks which are then immediately discarded) 88 | - Track the difference between blocks on the end of the file being full 89 | of zeroes due to ftruncate versus being full of junk due to discard 90 | - On open, truncate the file to erase trailing junk 91 | - Don't try to use free space between header structures for user data 92 | since we assume all blocks after the start of free space are movable 93 | and header blocks aren't (in this implementation) 94 | - Make cluster locks recursive, hold relevant metadata read locks while 95 | reading or writing data clusters to ensure they aren't moved while 96 | we're using them. 97 | - Add a debug testing mode and use it in a test case to verify that 98 | compact mid-write works as expected. 99 | 100 | ## 0.9.0 (2017-02-21) 101 | - Add online coalescing mode and background cluster recycling thread 102 | - Rename internal modules and types 103 | - Ensure the interval tree remains balanced to improve performance 104 | 105 | ## 0.8.1 (2017-02-13) 106 | - fix error in META file 107 | 108 | ## 0.8.0 (2017-02-13) 109 | - update to Mirage 3 APIs 110 | - now requires OCaml 4.03+ 111 | - ensure the interval tree is kept balanced 112 | 113 | ## 0.7.2 (2016-12-21) 114 | - if `discard` is not enabled, fail `discard` calls 115 | - if `discard` is enabled, enable lazy-refcounts and zero refcount clusters 116 | to avoid breaking refcounts over `discard`, `compact` 117 | 118 | ## 0.7.1 (2016-12-15) 119 | - speed up `check` and `compact` up to 50x 120 | - `qcow-tool compact` work around files which aren't a whole number of 121 | sectors 122 | 123 | ## 0.7.0 (2016-12-10) 124 | - now functorised over `TIME` 125 | - allow background compact to be cancelled 126 | - cancel background compact to allow regular I/O to go through 127 | - don't trigger the background compact until 1s after the last 128 | `discard` 129 | - on `connect`, sanity-check the image 130 | 131 | ## 0.6.0 (2016-12-04) 132 | - rename ocamlfind package from `qcow-format` to `qcow` for uniformity 133 | - add support for runtime configuration arguments to `connect` and `create` 134 | - add support for `discard` (aka TRIM or UNMAP) and online compaction 135 | (through a stop-the-world GC) 136 | - switch the build from `oasis` to `topkg` (thanks to @jgimenez) 137 | 138 | ## 0.5.0 (2016-11-26) 139 | - `resize` now takes a new size in bytes (rather than sectors) and uses a 140 | labelled argument 141 | - `qcow-tool info` now takes a `--filter ` for example 142 | `qcow-tool info ... --filter .size` to view the virtual size 143 | 144 | ## 0.4.2 (2016-09-21) 145 | - Don't break the build if `Block.connect` has optional arguments 146 | 147 | ## 0.4.1 (2016-08-17) 148 | - Remove one necessary source of `flush` calls 149 | - CLI: add `mapped` command to list the mapped regions of a file 150 | 151 | ## 0.4 (2016-08-03) 152 | - For buffered block devices, call `flush` to guarantee metadata correctness 153 | - In lazy_refcounts mode (the default), do not compute any refcounts 154 | - CLI: the `repair` command should recompute refcounts 155 | 156 | ## 0.3 (2016-05-12) 157 | - Depend on ppx, require OCaml 4.02+ 158 | 159 | ## 0.2 (2016-01-15) 160 | - Use qcow version 3 by default, setting `lazy_refcount=on` 161 | - Unit tests now verify that `qemu-img check` is happy and that `qemu-nbd` 162 | sees the same data we wrote 163 | 164 | ## 0.1 (2015-11-09) 165 | - initial `V1_LWT.BLOCK` support 166 | - caches metadata for performance 167 | - CLI tool for manipulating images 168 | - supports the `seek_mapped` `seek_unmapped` interface for iterating over 169 | sparse regions 170 | -------------------------------------------------------------------------------- /Dockerfile: -------------------------------------------------------------------------------- 1 | FROM ocaml/opam:alpine-ocaml-4.12 AS build 2 | # By default the container uses opam 2.0, change that 3 | RUN sudo ln -f /usr/bin/opam-2.3 /usr/bin/opam && opam init --reinit -ni 4 | WORKDIR /src 5 | COPY . . 6 | 7 | RUN opam pin add . -n --with-version=~dev 8 | RUN opam install . 9 | 10 | FROM alpine:latest 11 | COPY --from=build /root/.opam/4.12.0/bin/qcow-tool /qcow-tool 12 | ENTRYPOINT ["/qcow-tool"] 13 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | (* 2 | * ISC License 3 | * 4 | * Copyright (c) 2015-2018 5 | * 6 | * Permission to use, copy, modify, and distribute this software for any 7 | * purpose with or without fee is hereby granted, provided that the above 8 | * copyright notice and this permission notice appear in all copies. 9 | * 10 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | * 18 | *) 19 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | 2 | .PHONY: build clean test 3 | 4 | build: 5 | dune build @install 6 | 7 | test: 8 | dune build @runtest 9 | dune build lib_test/compact_random.exe lib_test/test.exe 10 | ./_build/default/lib_test/compact_random.exe -compact-mid-write -stop-after 16 11 | ./_build/default/lib_test/test.exe -runner sequential 12 | 13 | install: 14 | dune install 15 | 16 | uninstall: 17 | dune uninstall 18 | 19 | clean: 20 | dune clean 21 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Ocaml support for Qcow2 images 2 | ============================== 3 | 4 | [![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) 5 | 6 | Please read [the API documentation](https://mirage.github.io/ocaml-qcow/). 7 | 8 | Features 9 | -------- 10 | 11 | - supports `resize` 12 | - exposes sparseness information 13 | - produces files which can be understood by qemu (although not in 14 | reverse since we don't support many features) 15 | 16 | Example 17 | ------- 18 | 19 | In a top-level like utop: 20 | ```ocaml 21 | # #require "io-page.unix";; 22 | # #require "mirage-block";; 23 | # #require "mirage-block-ramdisk";; 24 | # #require "qcow";; 25 | # #require "lwt.syntax";; 26 | 27 | # lwt t_or_error = Ramdisk.create ~name:"hello" ~size_sectors:1024L ~sector_size:512;; 28 | val t_or_error : [ `Error of Ramdisk.error | `Ok of Ramdisk.t ] = `Ok 29 | 30 | # let t = Mirage_block.Error.ok_exn t_or_error;; 31 | val t : Ramdisk.t = 32 | 33 | # module Qcow_on_ramdisk = Qcow.Make(Ramdisk);; 34 | module Qcow_on_ramdisk : sig type page_aligned_buffer = Ramdisk.page_aligned_buffer 35 | type error = 36 | [ `Disconnected | `Is_read_only | `Unimplemented | `Unknown of bytes ] 37 | type 'a io = 'a Ramdisk.io 38 | type t = Qcow.Make(Ramdisk).t 39 | type id = Qcow.Make(Ramdisk).id 40 | val disconnect : t -> unit io 41 | type info = 42 | Qcow.Make(Ramdisk).info = { 43 | read_write : bool; 44 | sector_size : int; 45 | size_sectors : int64; 46 | } 47 | val get_info : t -> info io 48 | val read : 49 | t -> 50 | int64 -> page_aligned_buffer list -> [ `Error of error | `Ok of unit ] io 51 | val write : 52 | t -> 53 | int64 -> page_aligned_buffer list -> [ `Error of error | `Ok of unit ] io 54 | val create : Ramdisk.t -> int64 -> [ `Error of error | `Ok of t ] io 55 | val connect : Ramdisk.t -> t io 56 | val resize : t -> int64 -> [ `Error of error | `Ok of unit ] io 57 | val seek_unmapped : t -> int64 -> [ `Error of error | `Ok of int64 ] io 58 | val seek_mapped : t -> int64 -> [ `Error of error | `Ok of int64 ] io 59 | val rebuild_refcount_table : t -> [ `Error of error | `Ok of unit ] io 60 | val header : t -> Qcow.Header.t 61 | module Debug : 62 | sig 63 | type t = Qcow.Make(Ramdisk).t 64 | type error = error 65 | val check_no_overlaps : t -> [ `Error of error | `Ok of unit ] io 66 | val set_next_cluster : t -> int64 -> unit 67 | end 68 | end 69 | 70 | # lwt t_or_error = Qcow_on_ramdisk.create t 1048576L;; 71 | val t_or_error : [ `Error of Qcow_on_ramdisk.error | `Ok of Qcow_on_ramdisk.t ] 72 | = `Ok 73 | 74 | # let t = Mirage_block.Error.ok_exn t_or_error;; 75 | val t : Qcow_on_ramdisk.t = 76 | 77 | # let page = Io_page.(to_cstruct (get 1));; 78 | val page : Ramdisk.page_aligned_buffer = 79 | {Cstruct.buffer = ; off = 0; len = 4096} 80 | 81 | # lwt result_or_error = Qcow_on_ramdisk.read t 0L [ page ];; 82 | val result_or_error : [ `Error of Ramdisk.error | `Ok of unit ] = `Ok () 83 | 84 | # lwt ok_or_error = Mirage_block.sparse_copy (module Ramdisk) t (module Ramdisk) t;; 85 | val ok_or_error : 86 | [ `Error of [> `Different_sizes | `Is_read_only | `Msg of bytes ] 87 | | `Ok of unit ] = `Ok () 88 | ``` 89 | 90 | Limitations 91 | ----------- 92 | 93 | - cluster size is fixed at 64-bits 94 | - no support for snapshots 95 | -------------------------------------------------------------------------------- /cli/common.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) 2015 David Scott 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | *) 17 | 18 | type t = {debug: bool; progress: bool; progress_fd: int option} 19 | 20 | let make debug progress progress_fd = {debug; progress; progress_fd} 21 | -------------------------------------------------------------------------------- /cli/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name main) 3 | (public_name qcow-tool) 4 | (package qcow-tool) 5 | (libraries qcow qcow_stream io-page logs logs.fmt sha unix-type-representations 6 | cmdliner sexplib mirage-block-combinators mirage-block-unix) 7 | (preprocess 8 | (pps ppx_sexp_conv))) 9 | 10 | (cram 11 | (package qcow-tool) 12 | (deps main.exe)) 13 | -------------------------------------------------------------------------------- /cli/encode_decode.t: -------------------------------------------------------------------------------- 1 | Create a raw file with random contents 2 | $ dd if=/dev/random of=test.raw bs=65536 count=16 > /dev/null 2>&1 3 | 4 | Convert it to qcow file and back to raw 5 | $ ./main.exe encode test.raw test.qcow2 6 | $ ./main.exe decode test.qcow2 transform.raw 7 | 8 | Check that contents are the same 9 | $ diff test.raw transform.raw 10 | 11 | Check stream_decode works the same as seeking decode 12 | $ cat test.qcow2 | ./main.exe stream_decode stream_transform.raw 13 | $ diff test.raw stream_transform.raw 14 | 15 | Check we can decode files created by qemu-img 16 | $ qemu-img convert -f raw -O qcow2 test.raw qemu.qcow2 17 | $ ./main.exe decode qemu.qcow2 qemu_transform.raw 18 | $ diff test.raw qemu_transform.raw 19 | $ cat qemu.qcow2 | ./main.exe stream_decode stream_qemu_transform.raw 20 | $ diff test.raw stream_qemu_transform.raw 21 | -------------------------------------------------------------------------------- /doc/TRIM.md: -------------------------------------------------------------------------------- 1 | # Making the disk smaller 2 | 3 | A qcow-formatted disk allocates blocks on demand and the file grows as more 4 | blocks are allocated. A block may be marked as free by a "TRIM" or "discard" 5 | operation. To cause the file to shrink we use a concurrent GC, described in 6 | this document. 7 | 8 | ## Why is this so complicated? 9 | 10 | The simplest possible implementation of "TRIM" or "discard" is to call a 11 | filesystem API to "punch" holes out of the file. This is possible on BSDs and 12 | Linux but not on macOS. On macOS we must physically shuffle the blocks away 13 | from the end to make the file smaller. The implementation is further complicated 14 | by the need to avoid calling `fflush` too often as it's very slow and hurts 15 | performance. 16 | 17 | ## General approach 18 | 19 | We keep track of the set of unused ("discarded") "clusters" (clusters are blocks 20 | in a qcow2 file) and the references from one cluster to another. We have 2 21 | significant pieces of code: 22 | 23 | - the block allocator: previously this was a pointer to the next cluster and 24 | always extended the file. Now this allocates from a free list of blocks which 25 | have been erased and flushed. 26 | - the block GC: this is completely new and is responsible for maintaining a 27 | reasonably-sized free list of blocks and performing compaction of the disk 28 | by moving clusters from the end of the file to holes nearer the beginning. 29 | 30 | When there are new "discarded" clusters (called "junk" clusters in the code) 31 | we first top up the free list used by the block allocator, before using the 32 | rest to compact the file. This is because 33 | 34 | - if we're going to overwrite a block as part of a move, it's pointless to 35 | first erase and flush it 36 | - if we're compacting the file and the file is extended because the free list is 37 | empty then the allocation will be from the end and the new cluster will need to be 38 | moved before we can shrink the file -- better to get the cluster placement 39 | right first time than to have to move it immediately. 40 | 41 | Since `fflush` is very expensive we try to amortise the cost over many block 42 | copies/erases. If there is outstanding unflushed work we will call `fflush` 43 | after 5s, unless the user calls it themselves. 44 | 45 | At all times we try to avoid blocking I/O from the client as this can lead to 46 | timeouts (e.g. AHCI controller resets). 47 | 48 | ## States of clusters 49 | 50 | Clusters within a file can be in any one of the following states: 51 | 52 | - referenced and in-use 53 | - `junk`: these have been recently discarded 54 | - `erased`: these have been erased, but the zeroes have not been flushed which 55 | means it's unsafe to use them. If the computer crashes then the old data 56 | could re-appear. This is particularly bad for metadata blocks because we need 57 | them to contain zeroes (interpreted as NULL pointers i.e. unallocated clusters) 58 | - `available`: these have been erased and flushed and are safe to reallocate 59 | - `Copying`: these are being moved to another place on the disk 60 | - `Copied`: these have been duplicated but not flushed 61 | - `Flushed`: these have been duplicated and the duplicated data has been flushed. 62 | It is now safe to change the pointer to them. 63 | - `Referenced`: these have been duplicated, the duplicate has been flushed and 64 | the pointer has been changed but this has not been flushed. The old cluster 65 | still cannot be reused because the pointer update might be undone by a crash; 66 | but at least new writes go to the new location (and would obviously be lost if 67 | the pointer update was undone by a crash -- but this is ok, unflushed updates 68 | can be lost). After the next flush the original cluster becomes `junk` and the 69 | new cluster becomes referenced and in-use. 70 | 71 | ## Locking 72 | 73 | The principles are: 74 | 75 | - clusters are updated atomically 76 | - client I/O is not blocked on the output of the GC. The GC proceeds optimistically 77 | and can be rolled back 78 | 79 | We have the following locks 80 | 81 | - a per-cluster read/write lock: this guarantees clusters are updated atomically 82 | and protects access to the per-cluster move state. When a cluster is written 83 | to, any in-progress move can be marked as cancelled. 84 | - a global metadata mutex: this is held when following the (cached) metadata 85 | pointers and prevents following a pointer and it being immediately invalidated 86 | by the GC 87 | -------------------------------------------------------------------------------- /doc/prometheus.md: -------------------------------------------------------------------------------- 1 | # Prometheus stats 2 | 3 | This library supports exposing disk statistics in "prometheus" format. 4 | 5 | In a client application, stats can be exposed by instantiating the 6 | [Prometheus_app](https://github.com/mirage/prometheus/blob/master/app/prometheus_app.mli) 7 | functor, see 8 | [this example in the mirage/prometheus repo[(https://github.com/mirage/prometheus/blob/master/examples/example.ml) 9 | or 10 | [this example in the moby/hyperkit repo](https://github.com/moby/hyperkit/blob/70205a6d5143340299a679af259f70dfcd7cf8a4/src/lib/mirage_block_ocaml.ml#L188). 11 | 12 | Once exposed, stats can be gathered by an instance of [prometheus](https://prometheus.io) and 13 | then rendered into dashboards by tools like [grafana](https://grafana.com). 14 | 15 | ## Example 16 | 17 | Docker for Mac uses this qcow implementation and therefore has prometheus 18 | support. First install the latest experimental version from the 19 | [master branch](https://download-stage.docker.com/mac/master/Docker.dmg). 20 | 21 | Start the application once, and then shut it down again -- this will create 22 | the initial configuration. 23 | 24 | Expose metrics on `0.0.0.0:9090` by: 25 | ``` 26 | cd ~/Library/Containers/com.docker.docker/Data/database/ 27 | git reset --hard 28 | mkdir -p com.docker.driver.amd64-linux/disk 29 | echo -n "tcp:9090" > com.docker.driver.amd64-linux/disk/stats 30 | git add com.docker.driver.amd64-linux/disk/stats 31 | git commit -s -m 'Expose stats on port 9090 on all interfaces' 32 | ``` 33 | 34 | Test the metrics are working by: 35 | ``` 36 | curl http://localhost:9090/metrics 37 | ``` 38 | 39 | Download [prometheus.yml](https://raw.githubusercontent.com/mirage/ocaml-qcow/master/doc/prometheus.yml) 40 | 41 | Next run a prometheus server with: 42 | ``` 43 | docker run -d -p 9091:9090 -v $(pwd)/prometheus.yml:/etc/prometheus/prometheus.yml prom/prometheus 44 | ``` 45 | There should now be a prometheus server on port 9091. If you browse http://localhost:9091 and 46 | select the "Status" menu and then "Targets" you should see the target marked as "UP". 47 | 48 | Next run a grafana instance with: 49 | ``` 50 | docker run -d --name=grafana -p 3000:3000 grafana/grafana 51 | ``` 52 | Load http://localhost:3000/ in your browser, login with username "admin" and password "admin", 53 | click "Add data source", fill in a name (e.g. "qcow"), set the type to "Prometheus", 54 | change the URL to "http://localhost:9091", change the type to "direct" and click "Save & Test". 55 | It should say "Success: Data source is working" 56 | 57 | Click on the Main menu, hover over "Dashboards" and select "Import". Import the 58 | [dashboard.json](https://raw.githubusercontent.com/mirage/ocaml-qcow/master/doc/dashboard.json). 59 | 60 | Once sufficient data has been scraped, the dashboard should look like this: 61 | 62 | ![screenshot](https://cloud.githubusercontent.com/assets/198586/26151381/7e53db66-3afa-11e7-8608-7ba015c49910.png) 63 | -------------------------------------------------------------------------------- /doc/prometheus.yml: -------------------------------------------------------------------------------- 1 | global: 2 | scrape_interval: 5s # By default, scrape targets every 15 seconds. 3 | 4 | scrape_configs: 5 | - job_name: 'qcow' 6 | 7 | # Override the global default and scrape targets from this job every 5 seconds. 8 | scrape_interval: 5s 9 | 10 | static_configs: 11 | - targets: ['192.168.65.1:9090'] 12 | 13 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 3.18) 2 | 3 | (cram enable) 4 | 5 | (name qcow) 6 | (formatting (enabled_for ocaml)) 7 | (generate_opam_files true) 8 | 9 | (package 10 | (name qcow-types) 11 | (synopsis "Minimal set of dependencies for qcow-stream, shared with qcow") 12 | (maintainers "Dave Scott " "Pau Ruiz Safont" "Edwin Török ") 13 | (tags ("org:mirage")) 14 | (homepage "https://github.com/mirage/ocaml-qcow") 15 | (source (github mirage/ocaml-qcow)) 16 | (license "ISC") 17 | (authors "David Scott") 18 | (maintenance_intent "latest") 19 | (depends 20 | (ocaml (>= 4.12.0)) 21 | astring 22 | (cstruct (>= 6.1.0)) 23 | logs 24 | lwt 25 | mirage-block 26 | ppx_sexp_conv 27 | prometheus 28 | sexplib 29 | ) 30 | ) 31 | 32 | (package 33 | (name qcow-stream) 34 | (synopsis "Library offering QCOW streaming capabilities") 35 | (maintainers "Dave Scott " "Pau Ruiz Safont" "Edwin Török ") 36 | (tags ("org:mirage")) 37 | (homepage "https://github.com/mirage/ocaml-qcow") 38 | (source (github mirage/ocaml-qcow)) 39 | (license "ISC") 40 | (authors "David Scott") 41 | (maintenance_intent "latest") 42 | (depends 43 | (qcow-types (= :version)) 44 | cstruct-lwt 45 | io-page 46 | lwt 47 | ) 48 | ) 49 | 50 | (package 51 | (name qcow-tool) 52 | (synopsis "A command-line tool for manipulating qcow2-formatted data") 53 | (maintainers "Dave Scott " "Pau Ruiz Safont" "Edwin Török ") 54 | (tags ("org:mirage")) 55 | (homepage "https://github.com/mirage/ocaml-qcow") 56 | (source (github mirage/ocaml-qcow)) 57 | (license "ISC") 58 | (authors "David Scott") 59 | (maintenance_intent "latest") 60 | (depends 61 | (ocaml (>= 4.12.0)) 62 | (qcow (= :version)) 63 | (qcow-stream (= :version)) 64 | (conf-qemu-img :with-test) 65 | (cmdliner (>= 1.1.0)) 66 | cstruct 67 | result 68 | unix-type-representations 69 | lwt 70 | (mirage-block (>= 3.0.0)) 71 | (sha (>= 1.10)) 72 | sexplib 73 | logs 74 | (fmt (>= 0.8.2)) 75 | astring 76 | (io-page (>= 2.4.0)) 77 | (ounit :with-test) 78 | (mirage-block-ramdisk :with-test) 79 | (ezjsonm :with-test) 80 | ) 81 | ) 82 | 83 | (package 84 | (name qcow) 85 | (synopsis "Support for Qcow2 images") 86 | (maintainers "Dave Scott " "Pau Ruiz Safont" "Edwin Török ") 87 | (tags ("org:mirage")) 88 | (homepage "https://github.com/mirage/ocaml-qcow") 89 | (source (github mirage/ocaml-qcow)) 90 | (license "ISC") 91 | (authors "David Scott") 92 | (maintenance_intent "latest") 93 | (depends 94 | (ocaml (>= 4.12.0)) 95 | (qcow-types (= :version)) 96 | base-bytes 97 | (cstruct (>= 3.4.0)) 98 | result 99 | (io-page (>= 2.4.0)) 100 | (lwt (>= 5.5.0)) 101 | (mirage-block (>= 3.0.0)) 102 | (mirage-block-unix (>= 2.5.0)) 103 | mirage-block-combinators 104 | mirage-sleep 105 | sexplib 106 | logs 107 | (fmt (>= 0.8.2)) 108 | astring 109 | prometheus 110 | unix-type-representations 111 | stdlib-shims 112 | sha 113 | ppx_deriving 114 | ppx_sexp_conv 115 | (ounit :with-test) 116 | (mirage-block-ramdisk (and :with-test (>= 0.5))) 117 | (ezjsonm :with-test) 118 | ) 119 | ) 120 | -------------------------------------------------------------------------------- /generator/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name gen)) 3 | -------------------------------------------------------------------------------- /generator/gen.ml: -------------------------------------------------------------------------------- 1 | let output_file = ref "lib/qcow_word_size.ml" 2 | 3 | let _ = 4 | Arg.parse 5 | [("-o", Arg.Set_string output_file, "output filename")] 6 | (fun x -> 7 | Printf.fprintf stderr "Unexpected argument: %s\n%!" x ; 8 | exit 1 9 | ) 10 | "Auto-detect the host word size" ; 11 | 12 | let oc = open_out !output_file in 13 | ( match Sys.word_size with 14 | | 64 -> 15 | Printf.fprintf stderr "On a 64-bit machine so using 'int' for clusters\n" ; 16 | output_string oc "module Cluster = Qcow_int\n" 17 | | _ -> 18 | Printf.fprintf stderr 19 | "Not on a 64-bit machine to using 'int64' for clusters\n" ; 20 | output_string oc "module Cluster = Qcow_int64\n" 21 | ) ; 22 | close_out oc 23 | -------------------------------------------------------------------------------- /lib/dune: -------------------------------------------------------------------------------- 1 | (env 2 | (dev (flags (:standard -g -w -67-69))) 3 | (release (flags (:standard -w -67-69))) 4 | ) 5 | 6 | (library 7 | (name qcow_types) 8 | (public_name qcow-types) 9 | (modules (:standard \ qcow qcow_debug qcow_block_cache qcow_cstructs 10 | qcow_padded qcow_recycler qcow_stream)) 11 | (libraries 12 | astring 13 | (re_export cstruct) 14 | (re_export logs) 15 | (re_export lwt) 16 | (re_export mirage-block) 17 | (re_export prometheus) 18 | (re_export sexplib) 19 | ) 20 | (wrapped false) 21 | (preprocess 22 | (pps ppx_sexp_conv) 23 | ) 24 | ) 25 | 26 | (library 27 | (name qcow_stream) 28 | (public_name qcow-stream) 29 | (modules qcow_stream) 30 | (libraries 31 | cstruct-lwt 32 | io-page 33 | lwt.unix 34 | qcow_types 35 | ) 36 | (wrapped false) 37 | (preprocess 38 | (pps ppx_sexp_conv) 39 | ) 40 | ) 41 | 42 | (library 43 | (name qcow) 44 | (public_name qcow) 45 | (modules qcow qcow_debug qcow_block_cache qcow_cstructs 46 | qcow_padded qcow_recycler) 47 | (libraries 48 | fmt 49 | io-page 50 | mirage-sleep 51 | qcow_types 52 | ) 53 | (wrapped false) 54 | (preprocess 55 | (pps ppx_sexp_conv) 56 | ) 57 | ) 58 | 59 | (rule 60 | (targets qcow_word_size.ml) 61 | (action 62 | (run ../generator/gen.exe -o %{targets}))) 63 | -------------------------------------------------------------------------------- /lib/qcow.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) 2015 David Scott 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | *) 17 | module Error = Qcow_error 18 | module Header = Qcow_header 19 | module Physical = Qcow_physical 20 | module Int64 = Qcow_types.Int64 21 | 22 | module Make (B : Qcow_s.RESIZABLE_BLOCK) : sig 23 | include Mirage_block.S 24 | 25 | module Config : sig 26 | (** Runtime configuration of a device *) 27 | type t = { 28 | id: string (** unique name for prometheus metrics *) 29 | ; discard: bool (** true if `discard` will be enabled at runtime *) 30 | ; keep_erased: int64 option (** size of erased free pool in sectors *) 31 | ; compact_after_unmaps: int64 option 32 | (** automatically compact after n sectors are unmapped *) 33 | ; check_on_connect: bool (** perform an integrity check on connect *) 34 | ; runtime_asserts: bool (** check cluster invariants at runtime *) 35 | ; read_only: bool (** guarantee to not modify the file *) 36 | } 37 | 38 | val create : 39 | ?id:string 40 | -> ?discard:bool 41 | -> ?keep_erased:int64 42 | -> ?compact_after_unmaps:int64 43 | -> ?check_on_connect:bool 44 | -> ?runtime_asserts:bool 45 | -> ?read_only:bool 46 | -> unit 47 | -> t 48 | (** Customise the runtime behaviour, see [connect] or [create] *) 49 | 50 | val to_string : t -> string 51 | (** Marshal a config into a string suitable for a command-line argument *) 52 | 53 | val of_string : string -> (t, [`Msg of string]) result 54 | (** Parse the result of a previous [to_string] invocation *) 55 | end 56 | 57 | module Stats : sig 58 | (** Runtime statistics on a device *) 59 | type t = { 60 | mutable nr_erased: int64 (** number of sectors erased during discard *) 61 | ; mutable nr_unmapped: int64 62 | (** number of sectors unmapped during discard *) 63 | } 64 | end 65 | 66 | val create : 67 | B.t 68 | -> size:int64 69 | -> ?lazy_refcounts:bool 70 | -> ?cluster_bits:int 71 | -> ?config:Config.t 72 | -> unit 73 | -> (t, write_error) result Lwt.t 74 | (** [create block ~size ?lazy_refcounts ?cluster_bits ?config ()] initialises 75 | a qcow-formatted image on [block] with virtual size [size] in bytes. 76 | 77 | By default the file will use lazy refcounts, but this can be overriden by supplying 78 | [~lazy_refcounts:false]. By default the file will use 64KiB clusters (= 16 bits) 79 | but this can be overridden by supplying [?cluster_bits]. Note the cluster size 80 | must be greater than the sector size on the underlying block device. 81 | 82 | The [?config] argument does not affect the on-disk format but rather the 83 | behaviour as seen from this client. *) 84 | 85 | val connect : ?config:Config.t -> B.t -> t Lwt.t 86 | (** [connect ?config block] connects to an existing qcow-formatted image on 87 | [block]. *) 88 | 89 | val resize : 90 | t 91 | -> new_size:int64 92 | -> ?ignore_data_loss:bool 93 | -> unit 94 | -> (unit, write_error) result Lwt.t 95 | (** [resize block new_size_bytes ?ignore_data_loss] changes the size of the 96 | qcow-formatted image to [new_size_bytes], rounded up to the next allocation 97 | unit. This function will fail with an error if the new size would be 98 | smaller than the old size as this would cause data loss, unless the argument 99 | [?ignore_data_loss] is set to true. *) 100 | 101 | (** Summary of the compaction run *) 102 | type compact_result = { 103 | copied: int64 (** number of sectors copied *) 104 | ; refs_updated: int64 (** number of cluster references updated *) 105 | ; old_size: int64 (** previous size in sectors *) 106 | ; new_size: int64 (** new size in sectors *) 107 | } 108 | 109 | val compact : 110 | t 111 | -> ?progress_cb:(percent:int -> unit) 112 | -> unit 113 | -> (compact_result, write_error) result Lwt.t 114 | (** [compact t ()] scans the disk for unused space and attempts to fill it 115 | and shrink the file. This is useful if the underlying block device doesn't 116 | support discard and we must emulate it. *) 117 | 118 | val discard : 119 | t -> sector:int64 -> n:int64 -> unit -> (unit, write_error) result Lwt.t 120 | (** [discard sector n] signals that the [n] sectors starting at [sector] 121 | are no longer needed and the contents may be discarded. Note the contents 122 | may not actually be deleted: this is not a "secure erase". *) 123 | 124 | val seek_unmapped : t -> int64 -> (int64, error) result Lwt.t 125 | (** [seek_unmapped t start] returns the offset of the next "hole": a region 126 | of the device which is guaranteed to be full of zeroes (typically 127 | guaranteed because it is unmapped) *) 128 | 129 | val seek_mapped : t -> int64 -> (int64, error) result Lwt.t 130 | (** [seek_mapped t start] returns the offset of the next region of the 131 | device which may have data in it (typically this is the next mapped 132 | region) *) 133 | 134 | val rebuild_refcount_table : t -> (unit, write_error) result Lwt.t 135 | (** [rebuild_refcount_table t] rebuilds the refcount table from scratch. 136 | Normally we won't update the refcount table live, for performance. *) 137 | 138 | type check_result = { 139 | free: int64 (** unused sectors *) 140 | ; used: int64 (** used sectors *) 141 | } 142 | 143 | val check : 144 | B.t 145 | -> ( check_result 146 | , [ Mirage_block.error 147 | | `Reference_outside_file of int64 * int64 148 | | `Duplicate_reference of (int64 * int) * (int64 * int) * int64 149 | | `Msg of string ] 150 | ) 151 | result 152 | Lwt.t 153 | (** [check t] performs sanity checks of the file, looking for errors. 154 | The error [`Reference_outside_file (src, dst)] means that at offset [src] 155 | there is a reference to offset [dst] which is outside the file. 156 | The error [`Duplicate_reference (ref1, ref2, target) means that references 157 | at both [ref1] and [ref2] both point to the same [target] offset. *) 158 | 159 | val flush : t -> (unit, write_error) result Lwt.t 160 | (** [flush t] flushes any outstanding buffered writes *) 161 | 162 | val header : t -> Header.t 163 | (** Return a snapshot of the current header *) 164 | 165 | val to_config : t -> Config.t 166 | (** [to_config t] returns the configuration of a device *) 167 | 168 | val get_stats : t -> Stats.t 169 | (** [get_stats t] returns the runtime statistics of a device *) 170 | 171 | module Debug : sig 172 | val check_no_overlaps : t -> (unit, write_error) result Lwt.t 173 | 174 | val assert_no_leaked_blocks : t -> unit 175 | 176 | val assert_cluster_map_in_sync : t -> unit Lwt.t 177 | 178 | module Setting : sig 179 | val compact_mid_write : bool ref 180 | (** true means to trigger a compact part-way through a write to check that 181 | the write completes properly after the compact *) 182 | end 183 | 184 | val metadata_blocks : t -> Int64.IntervalSet.t 185 | (** Return the set of physical disk offsets containing metadata *) 186 | end 187 | end 188 | -------------------------------------------------------------------------------- /lib/qcow.mllib: -------------------------------------------------------------------------------- 1 | Qcow_config 2 | Qcow_header 3 | Qcow_error 4 | Qcow_types 5 | Qcow_int 6 | Qcow_int64 7 | Qcow_word_size 8 | Qcow_virtual 9 | Qcow_physical 10 | Qcow_s 11 | Qcow_diet 12 | Qcow_bitmap 13 | Qcow_rwlock 14 | Qcow_cache 15 | Qcow_locks 16 | Qcow_cluster_map 17 | Qcow_padded 18 | Qcow_cstructs 19 | Qcow_recycler 20 | Qcow_metadata 21 | Qcow_block_cache 22 | Qcow_debug 23 | Qcow 24 | -------------------------------------------------------------------------------- /lib/qcow_bitmap.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) 2016 David Scott 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | *) 17 | 18 | type t = {mutable buf: Cstruct.t; mutable len: int; max_len: int} 19 | 20 | type elt = int64 21 | 22 | type interval = elt * elt 23 | 24 | let make_empty ~initial_size:len ~maximum_size:max_len = 25 | let bytes_required = (len + 7) / 8 in 26 | let buf = Cstruct.create bytes_required in 27 | Cstruct.memset buf 0 ; {buf; len; max_len} 28 | 29 | let make_full ~initial_size:len ~maximum_size:max_len = 30 | let bytes_required = (len + 7) / 8 in 31 | let buf = Cstruct.create bytes_required in 32 | Cstruct.memset buf 0xff ; {buf; len; max_len} 33 | 34 | let copy t = 35 | let bytes_required = Cstruct.length t.buf in 36 | let buf = Cstruct.create bytes_required in 37 | Cstruct.blit t.buf 0 buf 0 bytes_required ; 38 | let len = t.len in 39 | let max_len = t.max_len in 40 | {buf; len; max_len} 41 | 42 | let increase t n = 43 | assert (n < t.max_len) ; 44 | let rec double len = 45 | if n >= len then double (min t.max_len (len * 2)) else len 46 | in 47 | let len = double t.len in 48 | assert (len <= t.max_len) ; 49 | assert (len > n) ; 50 | let bytes_required = (len + 7) / 8 in 51 | let buf = Cstruct.create bytes_required in 52 | Cstruct.memset buf 0 ; 53 | Cstruct.blit t.buf 0 buf 0 (Cstruct.length t.buf) ; 54 | t.buf <- buf ; 55 | t.len <- len 56 | 57 | let set' t n v = 58 | if n >= t.max_len then 59 | invalid_arg 60 | (Printf.sprintf "Qcow_bitmap.set %d >= maximum_size %d" n t.max_len) ; 61 | if n >= t.len then increase t n ; 62 | let i = n / 8 in 63 | let byte = Cstruct.get_uint8 t.buf i in 64 | let byte' = 65 | if v then 66 | byte lor (1 lsl (n mod 8)) 67 | else 68 | byte land lnot (1 lsl (n mod 8)) 69 | in 70 | Cstruct.set_uint8 t.buf i byte' 71 | 72 | let get' t n = 73 | if n >= t.len then 74 | invalid_arg (Printf.sprintf "Qcow_bitmap.get %d >= %d" n t.len) ; 75 | let i = n / 8 in 76 | let byte = Cstruct.get_uint8 t.buf i in 77 | byte land (1 lsl (n mod 8)) <> 0 78 | 79 | module Interval = struct 80 | let make x y = 81 | if x > y then invalid_arg "Interval.make" ; 82 | (x, y) 83 | 84 | let x = fst 85 | 86 | let y = snd 87 | end 88 | 89 | let add (a, b) t = 90 | for i = Int64.to_int a to Int64.to_int b do 91 | set' t i true 92 | done 93 | 94 | let remove (a, b) t = 95 | for i = Int64.to_int a to Int64.to_int b do 96 | set' t i false 97 | done 98 | 99 | let min_elt t = 100 | let rec loop from = if get' t from then from else loop (from + 1) in 101 | try Int64.of_int @@ loop 0 with _ -> raise Not_found 102 | 103 | (* fold over the maximal contiguous intervals *) 104 | let fold f t acc = 105 | let rec loop acc from = 106 | (* find a true element *) 107 | let rec find from v = if get' t from = v then from else find (from + 1) v in 108 | match find from true with 109 | | exception Invalid_argument _ -> 110 | (* there are no more *) 111 | acc 112 | | a -> 113 | (* find a false element, up to the end of the set *) 114 | let b = 115 | match find a false with 116 | | b -> 117 | b 118 | | exception Invalid_argument _ -> 119 | t.len 120 | in 121 | let acc = f (Int64.of_int a, Int64.of_int (b - 1)) acc in 122 | loop acc b 123 | in 124 | loop acc 0 125 | 126 | (* fold over the maximal contiguous intervals *) 127 | let fold_s f t acc = 128 | let open Lwt.Infix in 129 | let rec loop acc from = 130 | (* find a true element *) 131 | let rec find from v = if get' t from = v then from else find (from + 1) v in 132 | match find from true with 133 | | exception Invalid_argument _ -> 134 | (* there are no more *) 135 | Lwt.return acc 136 | | a -> 137 | (* find a false element, up to the end of the set *) 138 | let b = 139 | match find a false with 140 | | b -> 141 | b 142 | | exception Invalid_argument _ -> 143 | t.len 144 | in 145 | f (Int64.of_int a, Int64.of_int (b - 1)) acc >>= fun acc -> loop acc b 146 | in 147 | loop acc 0 148 | 149 | (* fold over individual elements *) 150 | let fold_individual f t acc = 151 | let range (from, upto) acc = 152 | let rec loop acc x = 153 | if x = Int64.succ upto then acc else loop (f x acc) (Int64.succ x) 154 | in 155 | loop acc from 156 | in 157 | fold range t acc 158 | 159 | let elements t = fold_individual (fun x acc -> x :: acc) t [] |> List.rev 160 | 161 | let to_string t = 162 | fold (fun (a, b) acc -> Printf.sprintf "%Ld - %Ld\n" a b :: acc) t [] 163 | |> String.concat ", " 164 | 165 | module Int = struct 166 | type t = int 167 | 168 | let compare (x : t) (y : t) = Stdlib.compare x y 169 | end 170 | 171 | module IntSet = Set.Make (Int) 172 | 173 | module Test = struct 174 | let make_random n m = 175 | let diet = make_empty ~initial_size:n ~maximum_size:n in 176 | let rec loop set = function 177 | | 0 -> 178 | (set, diet) 179 | | m -> 180 | let r = Random.int n in 181 | let i = Interval.make (Int64.of_int r) (Int64.of_int r) in 182 | let set, () = 183 | if Random.bool () then 184 | (IntSet.add r set, add i diet) 185 | else 186 | (IntSet.remove r set, remove i diet) 187 | in 188 | loop set (m - 1) 189 | in 190 | loop IntSet.empty m 191 | 192 | let check_equals set diet = 193 | let set' = IntSet.elements set |> List.map Int64.of_int in 194 | let diet' = elements diet in 195 | if set' <> diet' then 196 | (* 197 | Printf.fprintf stderr "Set contains: [ %s ]\n" @@ set_to_string set; 198 | Printf.fprintf stderr "Diet contains: [ %s ]\n" @@ diet_to_string diet; 199 | *) 200 | failwith "check_equals" 201 | 202 | let test_adds () = 203 | for _ = 1 to 1000 do 204 | let set, diet = make_random 1000 1000 in 205 | check_equals set diet 206 | done 207 | 208 | let test_add_1 () = 209 | let t = make_empty ~initial_size:10 ~maximum_size:10 in 210 | add (3L, 3L) t ; 211 | add (3L, 4L) t ; 212 | assert (elements t = [3L; 4L]) 213 | 214 | let test_remove_1 () = 215 | let t = make_empty ~initial_size:10 ~maximum_size:10 in 216 | add (7L, 8L) t ; 217 | remove (6L, 7L) t ; 218 | assert (elements t = [8L]) 219 | 220 | let all = 221 | [ 222 | ("adding an element to the right", test_add_1) 223 | ; ("removing an element on the left", test_remove_1) 224 | ; ("adding and removing elements acts like a Set", test_adds) 225 | ] 226 | end 227 | -------------------------------------------------------------------------------- /lib/qcow_bitmap.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) 2016 David Scott 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | *) 17 | 18 | (** The type of the set elements *) 19 | type elt = int64 20 | 21 | (** An interval: a range (x, y) of set values where all the elements from 22 | x to y inclusive are in the set *) 23 | type interval 24 | 25 | module Interval : sig 26 | val make : elt -> elt -> interval 27 | (** [make first last] construct an interval describing all the elements from 28 | [first] to [last] inclusive. *) 29 | 30 | val x : interval -> elt 31 | (** the starting element of the interval *) 32 | 33 | val y : interval -> elt 34 | (** the ending element of the interval *) 35 | end 36 | 37 | (** The type of sets *) 38 | type t 39 | 40 | val make_empty : initial_size:int -> maximum_size:int -> t 41 | (** [make_empty n] creates a set of [initial_size] which can be resized up to 42 | [maximum size], initially empty *) 43 | 44 | val make_full : initial_size:int -> maximum_size:int -> t 45 | (** [make_full n] creates a set of [initial_size] which can be resized up to 46 | [maximum size], initially full *) 47 | 48 | val copy : t -> t 49 | (** [copy t] returns a duplicate of [t] *) 50 | 51 | val fold : (interval -> 'a -> 'a) -> t -> 'a -> 'a 52 | (** [fold f t acc] folds [f] across all the intervals in [t] *) 53 | 54 | val fold_s : (interval -> 'a -> 'a Lwt.t) -> t -> 'a -> 'a Lwt.t 55 | (** [fold_s f t acc] folds [f] across all the intervals in [t] *) 56 | 57 | val add : interval -> t -> unit 58 | (** [add interval t] adds the [interval] to [t] in-place *) 59 | 60 | val remove : interval -> t -> unit 61 | (** [remove interval t] removes the [interval] from [t] in-place *) 62 | 63 | val min_elt : t -> elt 64 | (** [min_elt t] returns the smallest element, or raises [Not_found] if the set 65 | is empty. *) 66 | 67 | val to_string : t -> string 68 | 69 | module Test : sig 70 | val all : (string * (unit -> unit)) list 71 | end 72 | -------------------------------------------------------------------------------- /lib/qcow_block_cache.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) 2017 Docker Inc 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | *) 17 | 18 | let src = 19 | let src = Logs.Src.create "qcow" ~doc:"qcow2-formatted BLOCK device" in 20 | Logs.Src.set_level src (Some Logs.Info) ; 21 | src 22 | 23 | module Log = (val Logs.src_log src : Logs.LOG) 24 | 25 | let kib = 1024L 26 | 27 | let mib = Int64.mul kib 1024L 28 | 29 | open Qcow_types 30 | module Cstructs = Qcow_cstructs 31 | 32 | module RangeLocks = struct 33 | (** A set of exclusively locked intervals *) 34 | type t = {mutable locked: Int64.IntervalSet.t; c: unit Lwt_condition.t} 35 | 36 | let create () = 37 | let locked = Int64.IntervalSet.empty in 38 | let c = Lwt_condition.create () in 39 | {locked; c} 40 | 41 | let with_lock t i f = 42 | let open Lwt.Infix in 43 | let set = Int64.IntervalSet.(add i empty) in 44 | let rec get_lock () = 45 | if Int64.IntervalSet.(is_empty @@ inter t.locked set) then ( 46 | t.locked <- Int64.IntervalSet.(union t.locked set) ; 47 | Lwt.return_unit 48 | ) else 49 | Lwt_condition.wait t.c >>= fun () -> get_lock () 50 | in 51 | let put_lock () = 52 | t.locked <- Int64.IntervalSet.(diff t.locked set) ; 53 | Lwt.return_unit 54 | in 55 | get_lock () >>= fun () -> Lwt.finalize f put_lock 56 | end 57 | 58 | module Make (B : Qcow_s.RESIZABLE_BLOCK) = struct 59 | type error = B.error 60 | 61 | type write_error = B.write_error 62 | 63 | let pp_error = B.pp_error 64 | 65 | let pp_write_error = B.pp_write_error 66 | 67 | type t = { 68 | base: B.t 69 | ; mutable info: Mirage_block.info 70 | ; sector_size: int 71 | ; max_size_bytes: int64 72 | ; mutable in_cache: Int64.IntervalSet.t 73 | ; mutable zeros: Int64.IntervalSet.t 74 | ; mutable cache: Cstruct.t Int64.Map.t 75 | ; locks: RangeLocks.t 76 | ; mutable disconnect_request: bool 77 | ; disconnect_m: Lwt_mutex.t 78 | ; write_back_m: Lwt_mutex.t 79 | ; zero: Cstruct.t 80 | } 81 | 82 | let get_info t = Lwt.return t.info 83 | 84 | let lazy_write_back t = 85 | let open Lwt.Infix in 86 | Lwt_mutex.with_lock t.write_back_m (fun () -> 87 | Log.debug (fun f -> 88 | f "lazy_write_back cached sectors = %Ld zeros = %Ld" 89 | (Int64.IntervalSet.cardinal t.in_cache) 90 | (Int64.IntervalSet.cardinal t.zeros) 91 | ) ; 92 | assert (Int64.IntervalSet.(is_empty @@ inter t.in_cache t.zeros)) ; 93 | (* coalesce known-zeros together with data blocks *) 94 | let all = Int64.IntervalSet.union t.in_cache t.zeros in 95 | Int64.IntervalSet.fold_s 96 | (fun i err -> 97 | match err with 98 | | Error e -> 99 | Lwt.return (Error e) 100 | | Ok () -> 101 | RangeLocks.with_lock t.locks i (fun () -> 102 | let x, y = Int64.IntervalSet.Interval.(x i, y i) in 103 | let mib = Int64.(div 1048576L (of_int t.sector_size)) in 104 | (* split the interval into 1MiB chunks *) 105 | let rec loop x y = 106 | if x > y then 107 | Lwt.return (Ok ()) 108 | else 109 | let y' = min (Int64.add x mib) y in 110 | let rec bufs acc sector last = 111 | if sector > last then 112 | List.rev acc 113 | else 114 | let buf = 115 | if Int64.Map.mem sector t.cache then ( 116 | let buf = Int64.Map.find sector t.cache in 117 | t.in_cache <- 118 | Int64.IntervalSet.remove i t.in_cache ; 119 | t.zeros <- Int64.IntervalSet.remove i t.zeros ; 120 | t.cache <- Int64.Map.remove sector t.cache ; 121 | buf 122 | ) else 123 | t.zero 124 | in 125 | bufs (buf :: acc) (Int64.succ sector) last 126 | in 127 | let bufs = bufs [] x y' in 128 | B.write t.base x bufs >>= function 129 | | Error e -> 130 | Lwt.return (Error e) 131 | | Ok () -> 132 | loop (Int64.succ y') y 133 | in 134 | loop x y 135 | ) 136 | ) 137 | all (Ok ()) 138 | ) 139 | 140 | let flush t = 141 | let open Lwt.Infix in 142 | lazy_write_back t >>= function 143 | | Error e -> 144 | Lwt.return (Error e) 145 | | Ok () -> 146 | B.flush t.base 147 | 148 | let connect ?(max_size_bytes = Int64.mul 100L mib) base = 149 | let open Lwt.Infix in 150 | B.get_info base >>= fun info -> 151 | let sector_size = info.Mirage_block.sector_size in 152 | let in_cache = Int64.IntervalSet.empty in 153 | let zeros = Int64.IntervalSet.empty in 154 | let cache = Int64.Map.empty in 155 | let locks = RangeLocks.create () in 156 | let disconnect_request = false in 157 | let disconnect_m = Lwt_mutex.create () in 158 | let write_back_m = Lwt_mutex.create () in 159 | let zero = Cstruct.create sector_size in 160 | Cstruct.memset zero 0 ; 161 | let t = 162 | { 163 | base 164 | ; info 165 | ; sector_size 166 | ; max_size_bytes 167 | ; in_cache 168 | ; cache 169 | ; zeros 170 | ; locks 171 | ; disconnect_request 172 | ; disconnect_m 173 | ; write_back_m 174 | ; zero 175 | } 176 | in 177 | Lwt.return t 178 | 179 | let disconnect t = 180 | let open Lwt.Infix in 181 | Lwt_mutex.with_lock t.disconnect_m (fun () -> 182 | t.disconnect_request <- true ; 183 | Lwt.return_unit 184 | ) 185 | >>= fun () -> 186 | (* There can be no more in-progress writes *) 187 | flush t >>= fun _ -> B.disconnect t.base 188 | 189 | (* Call [f sector buf] for every sector from [start] up to the length of [bufs] *) 190 | let rec per_sector sector_size start bufs f = 191 | match bufs with 192 | | [] -> 193 | Lwt.return (Ok ()) 194 | | b :: bs -> ( 195 | let open Lwt.Infix in 196 | let rec loop sector remaining = 197 | if Cstruct.length remaining = 0 then 198 | Lwt.return (Ok sector) 199 | else ( 200 | assert (Cstruct.length remaining >= sector_size) ; 201 | let first = Cstruct.sub remaining 0 sector_size in 202 | f sector first >>= function 203 | | Error e -> 204 | Lwt.return (Error e) 205 | | Ok () -> 206 | loop (Int64.succ sector) (Cstruct.shift remaining sector_size) 207 | ) 208 | in 209 | loop start b >>= function 210 | | Error e -> 211 | Lwt.return (Error e) 212 | | Ok start' -> 213 | per_sector sector_size start' bs f 214 | ) 215 | 216 | let read t start bufs = 217 | let len = Int64.of_int @@ Cstructs.len bufs in 218 | let i = 219 | Int64.IntervalSet.Interval.make start 220 | Int64.(pred @@ add start (div len (of_int t.sector_size))) 221 | in 222 | let set = Int64.IntervalSet.(add i empty) in 223 | if t.disconnect_request then 224 | Lwt.return (Error `Disconnected) 225 | else 226 | RangeLocks.with_lock t.locks i (fun () -> 227 | if Int64.IntervalSet.(is_empty @@ inter t.in_cache set) then 228 | B.read t.base start bufs (* consider adding it to cache *) 229 | else 230 | per_sector t.sector_size start bufs (fun sector buf -> 231 | if Int64.Map.mem sector t.cache then ( 232 | let from_cache = Int64.Map.find sector t.cache in 233 | Cstruct.blit from_cache 0 buf 0 t.sector_size ; 234 | Lwt.return (Ok ()) 235 | ) else 236 | B.read t.base sector [buf] 237 | ) 238 | ) 239 | 240 | let write t start bufs = 241 | let open Lwt.Infix in 242 | let len = Int64.of_int @@ Cstructs.len bufs in 243 | let current_size_bytes = 244 | Int64.(mul (IntervalSet.cardinal t.in_cache) (of_int t.sector_size)) 245 | in 246 | ( if Int64.(add current_size_bytes len) > t.max_size_bytes then 247 | lazy_write_back t 248 | else 249 | Lwt.return (Ok ()) 250 | ) 251 | >>= function 252 | | Error e -> 253 | Lwt.return (Error e) 254 | | Ok () -> 255 | let i = 256 | Int64.IntervalSet.Interval.make start 257 | Int64.(pred @@ add start (div len (of_int t.sector_size))) 258 | in 259 | (* Prevent new writes entering the cache after the disconnect has started *) 260 | Lwt_mutex.with_lock t.disconnect_m (fun () -> 261 | if t.disconnect_request then 262 | Lwt.return (Error `Disconnected) 263 | else 264 | RangeLocks.with_lock t.locks i (fun () -> 265 | per_sector t.sector_size start bufs (fun sector buf -> 266 | assert (Cstruct.length buf = t.sector_size) ; 267 | if not (Int64.Map.mem sector t.cache) then ( 268 | t.in_cache <- Int64.IntervalSet.(add i t.in_cache) ; 269 | t.zeros <- Int64.IntervalSet.(remove i t.zeros) 270 | ) ; 271 | t.cache <- Int64.Map.add sector buf t.cache ; 272 | Lwt.return (Ok ()) 273 | ) 274 | ) 275 | ) 276 | 277 | let resize t new_size = 278 | let open Lwt.Infix in 279 | B.resize t.base new_size >>= function 280 | | Error e -> 281 | Lwt.return (Error e) 282 | | Ok () -> 283 | (* If the file has become smaller, drop cached blocks beyond the new file 284 | size *) 285 | if new_size < t.info.Mirage_block.size_sectors then ( 286 | let still_ok, to_drop = 287 | Int64.Map.partition (fun sector _ -> sector < new_size) t.cache 288 | in 289 | let to_drop' = 290 | Int64.Map.fold 291 | (fun sector _ set -> 292 | let i = Int64.IntervalSet.Interval.make sector sector in 293 | Int64.IntervalSet.(add i set) 294 | ) 295 | to_drop Int64.IntervalSet.empty 296 | in 297 | t.cache <- still_ok ; 298 | t.in_cache <- Int64.IntervalSet.diff t.in_cache to_drop' 299 | ) ; 300 | (* If the file has become bigger, we know the new blocks contain zeroes *) 301 | ( if new_size > t.info.Mirage_block.size_sectors then 302 | let i = 303 | Int64.IntervalSet.Interval.make t.info.Mirage_block.size_sectors 304 | (Int64.pred new_size) 305 | in 306 | t.zeros <- Int64.IntervalSet.add i t.zeros 307 | ) ; 308 | t.info <- {t.info with Mirage_block.size_sectors= new_size} ; 309 | Lwt.return (Ok ()) 310 | end 311 | -------------------------------------------------------------------------------- /lib/qcow_block_cache.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) 2017 Docker Inc 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | *) 17 | 18 | module Make (B : Qcow_s.RESIZABLE_BLOCK) : sig 19 | include Qcow_s.RESIZABLE_BLOCK 20 | 21 | val connect : ?max_size_bytes:int64 -> B.t -> t Lwt.t 22 | (** [connect ?max_size_bytes b] constructs a cache over [b] with a maximum 23 | memory footprint of [max_size_bytes]. Writes are heavily cached and only 24 | written to disk on a flush, disconnect or when out of space. *) 25 | end 26 | -------------------------------------------------------------------------------- /lib/qcow_cache.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) 2017 David Scott 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | *) 17 | open Qcow_types 18 | 19 | let src = 20 | let src = Logs.Src.create "qcow" ~doc:"qcow2-formatted BLOCK device" in 21 | Logs.Src.set_level src (Some Logs.Info) ; 22 | src 23 | 24 | module Log = (val Logs.src_log src : Logs.LOG) 25 | 26 | type t = { 27 | read_cluster: Cluster.t -> (Cstruct.t, Mirage_block.error) result Lwt.t 28 | ; write_cluster: 29 | Cluster.t -> Cstruct.t -> (unit, Mirage_block.write_error) result Lwt.t 30 | ; mutable clusters: Cstruct.t Cluster.Map.t 31 | ; seekable: bool 32 | ; last_read_cluster: Cluster.t ref 33 | } 34 | 35 | let create ~read_cluster ~write_cluster ?(seekable = true) () = 36 | let clusters = Cluster.Map.empty in 37 | { 38 | read_cluster 39 | ; write_cluster 40 | ; clusters 41 | ; seekable 42 | ; last_read_cluster= ref (Cluster.of_int 0) 43 | } 44 | 45 | let read t cluster = 46 | if Cluster.Map.mem cluster t.clusters then 47 | let data = Cluster.Map.find cluster t.clusters in 48 | Lwt.return (Ok data) 49 | else 50 | let open Lwt.Infix in 51 | let read_cluster cluster = 52 | t.read_cluster cluster >>= function 53 | | Error e -> 54 | Lwt.return (Error e) 55 | | Ok data -> 56 | t.clusters <- Cluster.Map.add cluster data t.clusters ; 57 | Lwt.return (Ok data) 58 | in 59 | let next_cluster = Cluster.succ !(t.last_read_cluster) in 60 | if t.seekable then 61 | read_cluster cluster 62 | else 63 | (* If we can't seek, we need to read sequential clusters until we reach 64 | the one we want. Previous clusters will still be stored in the cache 65 | for when we need them later (since we can't seek back) *) 66 | let rec read_clusters ~from ~until = 67 | let data = read_cluster from in 68 | t.last_read_cluster := from ; 69 | if from < until then 70 | read_clusters ~from:(Cluster.succ from) ~until 71 | else 72 | data 73 | in 74 | read_clusters ~from:next_cluster ~until:cluster 75 | 76 | let write t cluster data = 77 | if not (Cluster.Map.mem cluster t.clusters) then ( 78 | Log.err (fun f -> 79 | f 80 | "Cache.write %s: cluster is nolonger in cache, so update will be \ 81 | dropped" 82 | (Cluster.to_string cluster) 83 | ) ; 84 | assert false 85 | ) ; 86 | t.clusters <- Cluster.Map.add cluster data t.clusters ; 87 | t.write_cluster cluster data 88 | 89 | let remove t cluster = 90 | if Cluster.Map.mem cluster t.clusters then 91 | Printf.fprintf stderr "Dropping cache for cluster %s\n" 92 | (Cluster.to_string cluster) ; 93 | t.clusters <- Cluster.Map.remove cluster t.clusters 94 | 95 | let resize t new_size_clusters = 96 | let to_keep, to_drop = 97 | Cluster.Map.partition 98 | (fun cluster _ -> cluster < new_size_clusters) 99 | t.clusters 100 | in 101 | t.clusters <- to_keep ; 102 | if not (Cluster.Map.is_empty to_drop) then 103 | Log.info (fun f -> 104 | f "After file resize dropping cached clusters: %s" 105 | (String.concat ", " 106 | @@ List.map Cluster.to_string 107 | @@ List.map fst 108 | @@ Cluster.Map.bindings to_drop 109 | ) 110 | ) 111 | 112 | module Debug = struct 113 | let assert_not_cached t cluster = 114 | if Cluster.Map.mem cluster t.clusters then ( 115 | Printf.fprintf stderr "Cluster %s still in the metadata cache\n" 116 | (Cluster.to_string cluster) ; 117 | assert false 118 | ) 119 | 120 | let all_cached_clusters t = 121 | Cluster.Map.fold 122 | (fun cluster _ set -> 123 | Cluster.IntervalSet.(add (Interval.make cluster cluster) set) 124 | ) 125 | t.clusters Cluster.IntervalSet.empty 126 | 127 | let check_disk t = 128 | let open Lwt.Infix in 129 | let rec loop = function 130 | | [] -> 131 | Lwt.return (Ok ()) 132 | | (cluster, expected) :: rest -> ( 133 | (t.read_cluster cluster >>= function 134 | | Error e -> 135 | Lwt.return (Error e) 136 | | Ok data -> 137 | if not (Cstruct.equal expected data) then ( 138 | Log.err (fun f -> 139 | f "Cache for cluster %s disagrees with disk" 140 | (Cluster.to_string cluster) 141 | ) ; 142 | Log.err (fun f -> f "Cached:") ; 143 | let buffer = Buffer.create 65536 in 144 | Cstruct.hexdump_to_buffer buffer expected ; 145 | Log.err (fun f -> f "%s" (Buffer.contents buffer)) ; 146 | let buffer = Buffer.create 65536 in 147 | Cstruct.hexdump_to_buffer buffer data ; 148 | Log.err (fun f -> f "On disk:") ; 149 | Log.err (fun f -> f "%s" (Buffer.contents buffer)) ; 150 | Lwt.return (Ok ()) 151 | ) else 152 | Lwt.return (Ok ()) 153 | ) 154 | >>= function 155 | | Error e -> 156 | Lwt.return (Error e) 157 | | Ok () -> 158 | loop rest 159 | ) 160 | in 161 | loop (Cluster.Map.bindings t.clusters) 162 | end 163 | -------------------------------------------------------------------------------- /lib/qcow_cache.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) 2017 David Scott 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | *) 17 | open Qcow_types 18 | 19 | (** A cache of clusters *) 20 | type t 21 | 22 | val create : 23 | read_cluster:(Cluster.t -> (Cstruct.t, Mirage_block.error) result Lwt.t) 24 | -> write_cluster: 25 | (Cluster.t -> Cstruct.t -> (unit, Mirage_block.write_error) result Lwt.t) 26 | -> ?seekable:bool 27 | -> unit 28 | -> t 29 | (** Create a cache of clusters, given the read/write functions *) 30 | 31 | val read : t -> Cluster.t -> (Cstruct.t, Mirage_block.error) result Lwt.t 32 | (** [read t cluster] returns the data in [cluster] *) 33 | 34 | val write : 35 | t -> Cluster.t -> Cstruct.t -> (unit, Mirage_block.write_error) result Lwt.t 36 | (** [write t cluster data] writes [data] to [cluster] *) 37 | 38 | val remove : t -> Cluster.t -> unit 39 | (** [remove t cluster] drops any cache associated with [cluster] *) 40 | 41 | val resize : t -> Cluster.t -> unit 42 | (** [resize t new_size_clusters] drops any cache entries which are beyond the new 43 | file size. *) 44 | 45 | module Debug : sig 46 | val assert_not_cached : t -> Cluster.t -> unit 47 | 48 | val all_cached_clusters : t -> Cluster.IntervalSet.t 49 | 50 | val check_disk : t -> (unit, Mirage_block.error) result Lwt.t 51 | end 52 | -------------------------------------------------------------------------------- /lib/qcow_cluster_map.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) 2016 David Scott 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | *) 17 | open Qcow_types 18 | 19 | (** A cluster map which describes cluster usage in the file. The cluster map 20 | tracks which clusters are free, and which are used, and where the references 21 | are. *) 22 | type t 23 | 24 | (** Describes the state of a block move *) 25 | type move_state = 26 | | Copying 27 | (** a background copy is in progress. If this cluster is modified then 28 | the copy should be aborted. *) 29 | | Copied 30 | (** contents of this cluster have been copied once to another cluster. 31 | If this cluster is modified then the copy should be aborted. *) 32 | | Flushed 33 | (** contents of this cluster have been copied and flushed to disk: it 34 | is now safe to rewrite the pointer. If this cluster is modified then 35 | the copy should be aborted. *) 36 | | Referenced 37 | (** the reference has been rewritten; it is now safe to write to this 38 | cluster again. On the next flush, the copy is complete and the original 39 | block can be recycled. *) 40 | 41 | type reference = Cluster.t * int (* cluster * index within cluster *) 42 | 43 | module Move : sig 44 | (** An instruction to move the contents from cluster [src] to cluster [dst] *) 45 | type t = {src: Cluster.t; dst: Cluster.t} 46 | 47 | val to_string : t -> string 48 | end 49 | 50 | (** describes the state of an in-progress block move *) 51 | type move = {move: Move.t; state: move_state} 52 | 53 | val string_of_move : move -> string 54 | 55 | type cluster_state = 56 | | Junk 57 | | Erased 58 | | Available 59 | | Copies 60 | | Roots (** The state of a cluster *) 61 | 62 | val set_cluster_state : 63 | t -> Cluster.IntervalSet.t -> cluster_state -> cluster_state -> unit 64 | (** Update the state of a cluster *) 65 | 66 | module type MutableSet = sig 67 | val get : t -> Cluster.IntervalSet.t 68 | (** [get t] query the current contents of the set *) 69 | 70 | val remove : t -> Cluster.IntervalSet.t -> unit 71 | (** [remove t less] removes [less] from the set *) 72 | 73 | val mem : t -> Cluster.t -> bool 74 | (** [mem t cluster] is true if [cluster] is in [t] *) 75 | end 76 | 77 | val zero : t 78 | (** A cluster map for a zero-length disk *) 79 | 80 | val make : 81 | free:Qcow_bitmap.t 82 | -> refs:reference Cluster.Map.t 83 | -> cache:Qcow_cache.t 84 | -> first_movable_cluster:Cluster.t 85 | -> runtime_asserts:bool 86 | -> id:string option 87 | -> cluster_size:int 88 | -> t 89 | (** Given a set of free clusters, and the first cluster which can be moved 90 | (i.e. that isn't fixed header), construct an empty cluster map. *) 91 | 92 | val total_used : t -> int64 93 | (** Return the number of tracked used clusters *) 94 | 95 | val total_free : t -> int64 96 | (** Return the number of tracked free clusters *) 97 | 98 | val resize : t -> Cluster.t -> unit 99 | (** [resize t new_size_clusters] is called when the file is to be resized. *) 100 | 101 | val add : t -> reference -> Cluster.t -> unit 102 | (** [add t ref cluster] marks [cluster] as in-use and notes the reference from 103 | [reference]. *) 104 | 105 | val remove : t -> Cluster.t -> unit 106 | (** [remove t cluster] marks [cluster] as free and invalidates any reference 107 | to it (e.g. in response to a discard) *) 108 | 109 | (** Clusters which contain arbitrary data *) 110 | module Junk : MutableSet 111 | 112 | (** Clusters which have been erased but haven't been flushed yet so can't be 113 | safely reallocated. *) 114 | module Erased : MutableSet 115 | 116 | (** Clusters which are available for reallocation *) 117 | module Available : MutableSet 118 | 119 | (** Clusters which contain copies, as part of a compact *) 120 | module Copies : MutableSet 121 | 122 | (** Clusters which have been allocated but not yet placed somewhere reachable 123 | from the GC *) 124 | module Roots : MutableSet 125 | 126 | val wait : t -> unit Lwt.t 127 | (** [wait t] wait for some amount of recycling work to become available, e.g. 128 | - junk could be created 129 | - available could be used 130 | - a move might require a reference update *) 131 | 132 | val start_moves : t -> Move.t list 133 | (** [start_moves t] calculates the block moves required to compact [t] and 134 | marks the clusters as moving *) 135 | 136 | val moves : t -> move Cluster.Map.t 137 | (** [moves t] returns the state of the current active moves *) 138 | 139 | val set_move_state : t -> Move.t -> move_state -> unit 140 | (** Update the state of the given move operation *) 141 | 142 | val is_moving : t -> Cluster.t -> bool 143 | (** [is_moving t cluster] returns true if [cluster] is still moving *) 144 | 145 | val cancel_move : t -> Cluster.t -> unit 146 | (** [cancel_move cluster] cancels any in-progress move of cluster [cluster]. 147 | This should be called with the cluster write lock held whenever there has 148 | been a change in the contents of [cluster] *) 149 | 150 | val complete_move : t -> Move.t -> unit 151 | (** [complete_move t move] marks the move as complete. *) 152 | 153 | val find : t -> Cluster.t -> reference 154 | (** [find t cluster] returns the reference to [cluster], or raises [Not_found] *) 155 | 156 | val get_last_block : t -> Cluster.t 157 | (** [get_last_block t] is the last allocated block in [t]. Note if there are no 158 | data blocks this will point to the last header block even though it is 159 | immovable. *) 160 | 161 | val is_immovable : t -> Cluster.t -> bool 162 | (** [is_immovable t cluster] is true if [cluster] is fixed and cannot be moved 163 | i.e. it is before the first_movable_cluster i.e. it is part of the fixed 164 | (L1) header structure. *) 165 | 166 | val update_references : t -> Cluster.t Cluster.Map.t -> unit 167 | (** [update_references t subst] updates the reference table following the given set 168 | of substitutions. Any reference to a source block must be updated to the 169 | destination block otherwise it will be left pointing to junk. Normally this 170 | is guaranteed by the Metadata.Physical.set function, but when compacting we 171 | split the operation into phases and copy the block first at the byte level, 172 | leaving the map out-of-sync *) 173 | 174 | val to_summary_string : t -> string 175 | (** [to_summary_string t] returns a terse printable summary of [t] *) 176 | 177 | module Debug : sig 178 | val assert_no_leaked_blocks : t -> unit 179 | (** Check no blocks have gone missing *) 180 | 181 | val assert_equal : t -> t -> unit 182 | (** Check that 2 maps have equivalent contents *) 183 | 184 | val metadata_blocks : t -> Cluster.IntervalSet.t 185 | (** Return the set of blocks containing metadata *) 186 | end 187 | -------------------------------------------------------------------------------- /lib/qcow_config.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) 2017 David Scott 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | *) 17 | 18 | type t = { 19 | id: string 20 | ; discard: bool 21 | ; keep_erased: int64 option 22 | ; compact_after_unmaps: int64 option 23 | ; check_on_connect: bool 24 | ; runtime_asserts: bool 25 | ; read_only: bool 26 | } 27 | 28 | let fresh_id = 29 | let id = ref 0 in 30 | fun () -> 31 | let result = "unknown_" ^ string_of_int !id in 32 | incr id ; result 33 | 34 | let create ?(id = fresh_id ()) ?(discard = false) ?keep_erased 35 | ?compact_after_unmaps ?(check_on_connect = true) ?(runtime_asserts = false) 36 | ?(read_only = false) () = 37 | { 38 | id 39 | ; discard 40 | ; keep_erased 41 | ; compact_after_unmaps 42 | ; check_on_connect 43 | ; runtime_asserts 44 | ; read_only 45 | } 46 | 47 | let to_string t = 48 | Printf.sprintf 49 | "id=%s;discard=%b;keep_erased=%scompact_after_unmaps=%s;check_on_connect=%b;runtime_asserts=%b;read_only=%b" 50 | t.id t.discard 51 | (match t.keep_erased with None -> "0" | Some x -> Int64.to_string x) 52 | ( match t.compact_after_unmaps with 53 | | None -> 54 | "0" 55 | | Some x -> 56 | Int64.to_string x 57 | ) 58 | t.check_on_connect t.runtime_asserts t.read_only 59 | 60 | let default () = 61 | { 62 | id= fresh_id () 63 | ; discard= false 64 | ; keep_erased= None 65 | ; compact_after_unmaps= None 66 | ; check_on_connect= true 67 | ; runtime_asserts= false 68 | ; read_only= false 69 | } 70 | 71 | let of_string txt = 72 | let open Astring in 73 | try 74 | let strings = String.cuts ~sep:";" txt in 75 | Ok 76 | (List.fold_left 77 | (fun t line -> 78 | match String.cut ~sep:"=" line with 79 | | None -> 80 | t 81 | | Some (k, v) -> ( 82 | match String.Ascii.lowercase k with 83 | | "id" -> 84 | {t with id= v} 85 | | "discard" -> 86 | {t with discard= bool_of_string v} 87 | | "keep_erased" -> 88 | let keep_erased = 89 | if v = "0" then None else Some (Int64.of_string v) 90 | in 91 | {t with keep_erased} 92 | | "compact_after_unmaps" -> 93 | let compact_after_unmaps = 94 | if v = "0" then None else Some (Int64.of_string v) 95 | in 96 | {t with compact_after_unmaps} 97 | | "check_on_connect" -> 98 | {t with check_on_connect= bool_of_string v} 99 | | "runtime_asserts" -> 100 | {t with runtime_asserts= bool_of_string v} 101 | | "read_only" -> 102 | {t with read_only= bool_of_string v} 103 | | x -> 104 | failwith ("Unknown qcow configuration key: " ^ x) 105 | ) 106 | ) 107 | (default ()) strings 108 | ) 109 | with e -> Error (`Msg (Printexc.to_string e)) 110 | -------------------------------------------------------------------------------- /lib/qcow_config.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) 2017 David Scott 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | *) 17 | 18 | type t = { 19 | id: string (** unique name for the prometheus metrics *) 20 | ; discard: bool (** discard (aka TRIM) is enabled *) 21 | ; keep_erased: int64 option 22 | (** maintain a free pool of this many erased sectors *) 23 | ; compact_after_unmaps: int64 option 24 | (** once more than this many sectors are free, perform a compact *) 25 | ; check_on_connect: bool (** perform an integrity check on connect *) 26 | ; runtime_asserts: bool (** constantly verify GC invariants are held *) 27 | ; read_only: bool (** guarantee to not modify the file *) 28 | } 29 | 30 | val create : 31 | ?id:string 32 | -> ?discard:bool 33 | -> ?keep_erased:int64 34 | -> ?compact_after_unmaps:int64 35 | -> ?check_on_connect:bool 36 | -> ?runtime_asserts:bool 37 | -> ?read_only:bool 38 | -> unit 39 | -> t 40 | 41 | val default : unit -> t 42 | (** default configuration values *) 43 | 44 | val to_string : t -> string 45 | (** convert the configuration to a string *) 46 | 47 | val of_string : string -> (t, [> `Msg of string]) result 48 | (** parse the output of [to_string t] *) 49 | -------------------------------------------------------------------------------- /lib/qcow_cstructs.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) 2017 Docker Inc 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | *) 17 | 18 | type t = Cstruct.t list 19 | 20 | let pp_t ppf t = 21 | List.iter 22 | (fun t -> 23 | Format.fprintf ppf "[%d,%d](%d)" t.Cstruct.off t.Cstruct.len 24 | (Bigarray.Array1.dim t.Cstruct.buffer) 25 | ) 26 | t 27 | 28 | let len = List.fold_left (fun acc c -> Cstruct.length c + acc) 0 29 | 30 | let err fmt = 31 | let b = Buffer.create 20 in 32 | (* for thread safety. *) 33 | let ppf = Format.formatter_of_buffer b in 34 | let k ppf = 35 | Format.pp_print_flush ppf () ; 36 | invalid_arg (Buffer.contents b) 37 | in 38 | Format.kfprintf k ppf fmt 39 | 40 | let rec shift t x = 41 | if x = 0 then 42 | t 43 | else 44 | match t with 45 | | [] -> 46 | err "Cstructs.shift %a %d" pp_t t x 47 | | y :: ys -> 48 | let y' = Cstruct.length y in 49 | if y' > x then 50 | Cstruct.shift y x :: ys 51 | else 52 | shift ys (x - y') 53 | 54 | let to_string t = 55 | let b = Buffer.create 20 in 56 | List.iter (fun x -> Buffer.add_string b @@ Cstruct.to_string x) t ; 57 | Buffer.contents b 58 | 59 | let sub t off len = 60 | let t' = shift t off in 61 | (* trim the length *) 62 | let rec trim acc ts remaining = 63 | match (remaining, ts) with 64 | | 0, _ -> 65 | List.rev acc 66 | | _, [] -> 67 | err "invalid bounds in Cstructs.sub %a off=%d len=%d" pp_t t off len 68 | | n, t :: ts -> 69 | let to_take = min (Cstruct.length t) n in 70 | (* either t is consumed and we only need ts, or t has data remaining in which 71 | case we're finished *) 72 | trim (Cstruct.sub t 0 to_take :: acc) ts (remaining - to_take) 73 | in 74 | trim [] t' len 75 | 76 | let to_cstruct = function 77 | | [common_case] -> 78 | common_case 79 | | uncommon_case -> 80 | Cstruct.concat uncommon_case 81 | 82 | (* Return a Cstruct.t representing (off, len) by either returning a reference 83 | or making a copy if the value is split across two fragments. Ideally this 84 | would return a string rather than a Cstruct.t for efficiency *) 85 | let get f t off len = 86 | let t' = shift t off in 87 | match t' with 88 | | x :: xs -> 89 | (* Return a reference to the existing buffer *) 90 | if Cstruct.length x >= len then 91 | Cstruct.sub x 0 len 92 | else (* Copy into a fresh buffer *) 93 | let rec copy remaining frags = 94 | if Cstruct.length remaining > 0 then 95 | match frags with 96 | | [] -> 97 | err "invalid bounds in Cstructs.%s %a off=%d len=%d" f pp_t t 98 | off len 99 | | x :: xs -> 100 | let to_copy = 101 | min (Cstruct.length x) (Cstruct.length remaining) 102 | in 103 | Cstruct.blit x 0 remaining 0 to_copy ; 104 | (* either we've copied all of x, or we've filled the remaining buffer *) 105 | copy (Cstruct.shift remaining to_copy) xs 106 | in 107 | let result = Cstruct.create len in 108 | copy result (x :: xs) ; 109 | result 110 | | [] -> 111 | err "invalid bounds in Cstructs.%s %a off=%d len=%d" f pp_t t off len 112 | 113 | let get_uint8 t off = Cstruct.get_uint8 (get "get_uint8" t off 1) 0 114 | 115 | let memset ts x = List.iter (fun t -> Cstruct.memset t x) ts 116 | 117 | module BE = struct 118 | open Cstruct.BE 119 | 120 | let get_uint16 t off = get_uint16 (get "get_uint16" t off 2) 0 121 | 122 | let get_uint32 t off = get_uint32 (get "get_uint32" t off 4) 0 123 | end 124 | -------------------------------------------------------------------------------- /lib/qcow_cstructs.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) 2017 Docker Inc 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | *) 17 | 18 | (** A subset of the Cstruct signature with type t = Cstruct.t list 19 | 20 | This should be replaced with another parser, perhaps angstrom? *) 21 | 22 | (** Data stored as a list of fragments *) 23 | type t = Cstruct.t list 24 | 25 | val to_string : t -> string 26 | 27 | val shift : t -> int -> t 28 | 29 | val len : t -> int 30 | 31 | val sub : t -> int -> int -> t 32 | 33 | val get_uint8 : t -> int -> int 34 | 35 | val to_cstruct : t -> Cstruct.t 36 | (** Returns a contiguous Cstruct.t, which may or may not involve a copy. *) 37 | 38 | val memset : t -> int -> unit 39 | 40 | module BE : sig 41 | val get_uint16 : t -> int -> int 42 | 43 | val get_uint32 : t -> int -> int32 44 | end 45 | -------------------------------------------------------------------------------- /lib/qcow_debug.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) 2017 David Scott 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | *) 17 | 18 | let src = 19 | let src = Logs.Src.create "qcow" ~doc:"qcow2-formatted BLOCK device" in 20 | Logs.Src.set_level src (Some Logs.Info) ; 21 | src 22 | 23 | module Log = (val Logs.src_log src : Logs.LOG) 24 | 25 | module Error = Qcow_error 26 | module Physical = Qcow_physical 27 | module Metadata = Qcow_metadata 28 | open Qcow_types 29 | 30 | let check_on_disk_reference metadata ~cluster_bits (c, w) target = 31 | Metadata.read metadata c (fun contents -> 32 | let p = Metadata.Physical.of_contents contents in 33 | let target' = Metadata.Physical.get p w in 34 | let target_cluster = Physical.cluster ~cluster_bits target in 35 | let target'_cluster = Physical.cluster ~cluster_bits target' in 36 | let descr = 37 | Printf.sprintf "Physical.get %s:%d = %s (%s %s)" (Cluster.to_string c) w 38 | (Cluster.to_string target'_cluster) 39 | (if target = target' then "=" else "<>") 40 | (Cluster.to_string target_cluster) 41 | in 42 | if target <> target' then 43 | Log.err (fun f -> f "%s" descr) 44 | else 45 | Log.info (fun f -> f "%s" descr) ; 46 | Lwt.return (Ok ()) 47 | ) 48 | 49 | let rec check_references metadata cluster_map ~cluster_bits (cluster : Cluster.t) 50 | = 51 | let open Error.Lwt_write_error.Infix in 52 | match Qcow_cluster_map.find cluster_map cluster with 53 | | exception Not_found -> 54 | if Qcow_cluster_map.is_immovable cluster_map cluster then 55 | Log.info (fun f -> 56 | f "Cluster %s is an L1 cluster" (Cluster.to_string cluster) 57 | ) 58 | else 59 | Log.err (fun f -> 60 | f "No reference to cluster %s" (Cluster.to_string cluster) 61 | ) ; 62 | Lwt.return (Ok ()) 63 | | c', w' -> 64 | let target = 65 | Physical.make ~is_mutable:true ~is_compressed:false 66 | (Cluster.to_int cluster lsl cluster_bits) 67 | in 68 | check_on_disk_reference metadata ~cluster_bits (c', w') target 69 | >>= fun () -> check_references metadata cluster_map ~cluster_bits c' 70 | 71 | let on_duplicate_reference metadata cluster_map ~cluster_bits (c, w) (c', w') 72 | cluster = 73 | let open Error.Lwt_write_error.Infix in 74 | let cluster = Cluster.of_int64 cluster in 75 | let rec follow (c, w) (cluster : Cluster.t) = 76 | let target = 77 | Physical.make ~is_mutable:true ~is_compressed:true 78 | (Cluster.to_int cluster lsl cluster_bits) 79 | in 80 | check_on_disk_reference metadata ~cluster_bits (c, w) target >>= fun () -> 81 | match Qcow_cluster_map.find cluster_map c with 82 | | exception Not_found -> 83 | Log.err (fun f -> f "No reference to cluster %s" (Cluster.to_string c)) ; 84 | Lwt.return (Ok ()) 85 | | c', w' -> 86 | follow (c', w') c 87 | in 88 | follow (Cluster.of_int64 c', w') cluster >>= fun () -> 89 | follow (Cluster.of_int64 c, w) cluster 90 | -------------------------------------------------------------------------------- /lib/qcow_debug.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) 2017 David Scott 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | *) 17 | open Qcow_types 18 | 19 | val on_duplicate_reference : 20 | Qcow_metadata.t 21 | -> Qcow_cluster_map.t 22 | -> cluster_bits:int 23 | -> int64 * int 24 | -> int64 * int 25 | -> int64 26 | -> (unit, [> `Disconnected | `Is_read_only | `Msg of string]) result Lwt.t 27 | 28 | val check_references : 29 | Qcow_metadata.t 30 | -> Qcow_cluster_map.t 31 | -> cluster_bits:int 32 | -> Cluster.t 33 | -> (unit, [> `Disconnected | `Is_read_only | `Msg of string]) result Lwt.t 34 | (** [check_references metadata map cluster_bits target] follows the back references 35 | from physical offset [target], verifying the references on disk as it goes *) 36 | -------------------------------------------------------------------------------- /lib/qcow_diet.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) 2016 David Scott 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | *) 17 | 18 | module type ELT = sig 19 | (** The type of the set elements. *) 20 | type t [@@deriving sexp] 21 | 22 | include Set.OrderedType with type t := t 23 | 24 | val zero : t 25 | (** The zeroth element *) 26 | 27 | val pred : t -> t 28 | (** Predecessor of an element *) 29 | 30 | val succ : t -> t 31 | (** Successor of an element *) 32 | 33 | val sub : t -> t -> t 34 | (** [sub a b] returns [a] - [b] *) 35 | 36 | val add : t -> t -> t 37 | (** [add a b] returns [a] + [b] *) 38 | end 39 | 40 | module Make (Elt : ELT) : Qcow_s.INTERVAL_SET with type elt = Elt.t 41 | 42 | module Test : sig 43 | val all : (string * (unit -> unit)) list 44 | end 45 | -------------------------------------------------------------------------------- /lib/qcow_error.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) 2015 David Scott 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | *) 17 | type error = [`Msg of string] 18 | 19 | type 'a t = ('a, error) result 20 | 21 | let return x = Ok x 22 | 23 | let error_msg fmt = Printf.ksprintf (fun s -> Error (`Msg s)) fmt 24 | 25 | let ( >>= ) m f = match m with Error x -> Error x | Ok x -> f x 26 | 27 | let rec any = function 28 | | [] -> 29 | Ok () 30 | | Error e :: _ -> 31 | Error e 32 | | _ :: rest -> 33 | any rest 34 | 35 | module Lwt_error = struct 36 | open Lwt.Infix 37 | 38 | module Infix = struct 39 | let ( >>= ) m f = 40 | m >>= function 41 | | Ok x -> 42 | f x 43 | | Error (`Msg s) -> 44 | Lwt.return (Error (`Msg s)) 45 | | Error `Disconnected -> 46 | Lwt.return (Error `Disconnected) 47 | end 48 | 49 | let or_fail_with m = 50 | let open Lwt in 51 | m >>= function 52 | | Error (`Msg s) -> 53 | Lwt.fail_with s 54 | | Error `Disconnected -> 55 | Lwt.fail_with "disconnected" 56 | | Ok x -> 57 | Lwt.return x 58 | 59 | module List = struct 60 | let map_p f xs = 61 | let threads = List.map f xs in 62 | Lwt_list.fold_left_s 63 | (fun acc t -> 64 | t >>= fun x -> 65 | match (acc, x) with 66 | | Error e, _ -> 67 | Lwt.return (Error e) 68 | | _, Error e -> 69 | Lwt.return (Error e) 70 | | Ok acc, Ok x -> 71 | Lwt.return (Ok (x :: acc)) 72 | ) 73 | (Ok []) threads 74 | >>= function 75 | | Error e -> 76 | Lwt.return (Error e) 77 | | Ok xs -> 78 | Lwt.return (Ok (List.rev xs)) 79 | end 80 | end 81 | 82 | module Lwt_write_error = struct 83 | module Infix = struct 84 | open Lwt.Infix 85 | 86 | let ( >>= ) m f = 87 | m >>= function 88 | | Ok x -> 89 | f x 90 | | Error (`Msg s) -> 91 | Lwt.return (Error (`Msg s)) 92 | | Error `Is_read_only -> 93 | Lwt.return (Error `Is_read_only) 94 | | Error `Disconnected -> 95 | Lwt.return (Error `Disconnected) 96 | end 97 | 98 | let or_fail_with m = 99 | let open Lwt in 100 | m >>= function 101 | | Error (`Msg s) -> 102 | Lwt.fail_with s 103 | | Error `Is_read_only -> 104 | Lwt.fail_with "is read only" 105 | | Error `Disconnected -> 106 | Lwt.fail_with "disconnected" 107 | | Ok x -> 108 | Lwt.return x 109 | end 110 | 111 | exception Duplicate_reference of (int64 * int) * (int64 * int) * int64 112 | -------------------------------------------------------------------------------- /lib/qcow_error.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) 2015 David Scott 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | *) 17 | 18 | (** Common error reporting functions *) 19 | 20 | type error = 21 | [`Msg of string (** A fatal error condition; the string should be logged *)] 22 | 23 | type 'a t = ('a, error) result 24 | 25 | val return : 'a -> ('a, error) result 26 | 27 | val error_msg : 28 | ('a, unit, string, ('b, [> `Msg of string]) result) format4 -> 'a 29 | 30 | val ( >>= ) : ('a, 'b) result -> ('a -> ('c, 'b) result) -> ('c, 'b) result 31 | 32 | val any : (unit, 'b) result list -> (unit, 'b) result 33 | 34 | module Lwt_error : sig 35 | module Infix : sig 36 | val ( >>= ) : 37 | ('a, [< `Disconnected | `Msg of 'b]) result Lwt.t 38 | -> ('a -> ('c, ([> `Disconnected | `Msg of 'b] as 'd)) result Lwt.t) 39 | -> ('c, 'd) result Lwt.t 40 | end 41 | 42 | val or_fail_with : 43 | ('a, [< `Disconnected | `Msg of string]) result Lwt.t -> 'a Lwt.t 44 | 45 | module List : sig 46 | val map_p : 47 | ('a -> ('b, 'error) result Lwt.t) 48 | -> 'a list 49 | -> ('b list, 'error) result Lwt.t 50 | (** [map_p f xs] computes [f x] where [x \in xs] concurrently and returns 51 | a list of successful results or the first error encountered. All threads 52 | will have terminated by the time the function returns. *) 53 | end 54 | end 55 | 56 | module Lwt_write_error : sig 57 | module Infix : sig 58 | val ( >>= ) : 59 | ('a, [< `Disconnected | `Is_read_only | `Msg of 'b]) result Lwt.t 60 | -> ( 'a 61 | -> ('c, ([> `Disconnected | `Is_read_only | `Msg of 'b] as 'd)) result 62 | Lwt.t 63 | ) 64 | -> ('c, 'd) result Lwt.t 65 | end 66 | 67 | val or_fail_with : 68 | ('a, [< `Disconnected | `Is_read_only | `Msg of string]) result Lwt.t 69 | -> 'a Lwt.t 70 | end 71 | 72 | exception Duplicate_reference of (int64 * int) * (int64 * int) * int64 73 | -------------------------------------------------------------------------------- /lib/qcow_header.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) 2015 David Scott 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | *) 17 | open Sexplib.Std 18 | open Astring 19 | open Result 20 | open Qcow_error 21 | module OldInt64 = Int64 22 | open Qcow_types 23 | module Physical = Qcow_physical 24 | 25 | let ( <| ) = OldInt64.shift_left 26 | 27 | let ( |> ) = OldInt64.shift_right_logical 28 | 29 | module Version = struct 30 | type t = [`One | `Two | `Three] [@@deriving sexp] 31 | 32 | let sizeof _ = 4 33 | 34 | let write t rest = 35 | Int32.write (match t with `One -> 1l | `Two -> 2l | `Three -> 3l) rest 36 | 37 | let read rest = 38 | Int32.read rest >>= fun (version, rest) -> 39 | match version with 40 | | 1l -> 41 | return (`One, rest) 42 | | 2l -> 43 | return (`Two, rest) 44 | | 3l -> 45 | return (`Three, rest) 46 | | _ -> 47 | error_msg "Unknown version: %ld" version 48 | 49 | let compare (a : t) (b : t) = Stdlib.compare a b 50 | end 51 | 52 | module CryptMethod = struct 53 | type t = [`Aes | `None] [@@deriving sexp] 54 | 55 | let sizeof _ = 4 56 | 57 | let write t rest = Int32.write (match t with `Aes -> 1l | `None -> 0l) rest 58 | 59 | let read rest = 60 | Int32.read rest >>= fun (m, rest) -> 61 | match m with 62 | | 0l -> 63 | return (`None, rest) 64 | | 1l -> 65 | return (`Aes, rest) 66 | | _ -> 67 | error_msg "Unknown crypt_method: %ld" m 68 | 69 | let compare (a : t) (b : t) = Stdlib.compare a b 70 | end 71 | 72 | module Feature = struct 73 | type ty = [`Incompatible | `Compatible | `Autoclear] [@@deriving sexp] 74 | 75 | type feature = [`Corrupt | `Dirty | `Lazy_refcounts | `Unknown of string] 76 | [@@deriving sexp] 77 | 78 | type t = {ty: ty; bit: int; feature: feature} [@@deriving sexp] 79 | 80 | let understood = 81 | [ 82 | {ty= `Incompatible; bit= 0; feature= `Dirty} 83 | ; {ty= `Incompatible; bit= 1; feature= `Corrupt} 84 | ; {ty= `Compatible; bit= 0; feature= `Lazy_refcounts} 85 | ] 86 | 87 | let sizeof _ = 48 88 | 89 | let write t rest = 90 | Int8.write 91 | (match t.ty with `Incompatible -> 0 | `Compatible -> 1 | `Autoclear -> 2) 92 | rest 93 | >>= fun rest -> 94 | Int8.write t.bit rest >>= fun rest -> 95 | let str = 96 | match t.feature with 97 | | `Corrupt -> 98 | "corrupt bit" 99 | | `Dirty -> 100 | "dirty bit" 101 | | `Lazy_refcounts -> 102 | "lazy refcounts" 103 | | `Unknown x -> 104 | x 105 | in 106 | Cstruct.(memset (sub rest 0 46) 0) ; 107 | Cstruct.blit_from_string str 0 rest 0 (String.length str) ; 108 | Result.Ok (Cstruct.shift rest 46) 109 | 110 | let read rest = 111 | Int8.read rest >>= fun (ty, rest) -> 112 | ( match ty with 113 | | 0 -> 114 | Ok `Incompatible 115 | | 1 -> 116 | Ok `Compatible 117 | | 2 -> 118 | Ok `Autoclear 119 | | n -> 120 | error_msg "Unknown header extension type %d" n 121 | ) 122 | >>= fun ty -> 123 | Int8.read rest >>= fun (bit, rest) -> 124 | let feature = 125 | String.trim ~drop:(fun c -> c = '\000') Cstruct.(to_string (sub rest 0 46)) 126 | in 127 | let feature = 128 | match feature with 129 | | "corrupt bit" -> 130 | `Corrupt 131 | | "dirty bit" -> 132 | `Dirty 133 | | "lazy refcounts" -> 134 | `Lazy_refcounts 135 | | x -> 136 | `Unknown x 137 | in 138 | Ok ({ty; bit; feature}, Cstruct.shift rest 46) 139 | 140 | let read_all rest = 141 | let rec loop acc rest = 142 | if Cstruct.length rest = 0 then 143 | Ok (List.rev acc) 144 | else if Cstruct.length rest < 48 then 145 | error_msg "Trailing garbage in feature area: %s" 146 | (String.Ascii.escape (Cstruct.to_string rest)) 147 | else 148 | read rest >>= fun (first, rest) -> loop (first :: acc) rest 149 | in 150 | loop [] rest 151 | 152 | let write_all ts rest = 153 | let rec loop rest = function 154 | | [] -> 155 | Ok rest 156 | | t :: ts -> 157 | write t rest >>= fun rest -> loop rest ts 158 | in 159 | loop rest ts 160 | end 161 | 162 | type offset = int64 [@@deriving sexp] 163 | 164 | type extension = 165 | [ `Unknown of int32 * string 166 | | `Backing_file of string 167 | | `Feature_name_table of Feature.t list ] 168 | [@@deriving sexp] 169 | 170 | type additional = { 171 | dirty: bool 172 | ; corrupt: bool 173 | ; lazy_refcounts: bool 174 | ; autoclear_features: int64 175 | ; refcount_order: int32 176 | } 177 | [@@deriving sexp] 178 | 179 | type t = { 180 | version: Version.t 181 | ; backing_file_offset: offset 182 | ; backing_file_size: int32 183 | ; cluster_bits: int32 184 | ; size: int64 185 | ; crypt_method: CryptMethod.t 186 | ; l1_size: int32 187 | ; l1_table_offset: Physical.t 188 | ; refcount_table_offset: Physical.t 189 | ; refcount_table_clusters: int32 190 | ; nb_snapshots: int32 191 | ; snapshots_offset: offset 192 | ; additional: additional option 193 | ; extensions: extension list 194 | } 195 | [@@deriving sexp] 196 | 197 | let compare (a : t) (b : t) = Stdlib.compare a b 198 | 199 | let to_string t = Sexplib.Sexp.to_string_hum (sexp_of_t t) 200 | 201 | let sizeof t = 202 | let base = 4 + 4 + 8 + 4 + 4 + 8 + 4 + 4 + 8 + 8 + 4 + 4 + 8 in 203 | let additional = 204 | match t.additional with None -> 0 | Some _ -> 8 + 8 + 8 + 4 + 4 205 | in 206 | let unpadded_sizeof_extension = function 207 | | `Unknown (_, data) -> 208 | String.length data 209 | | `Backing_file data -> 210 | String.length data 211 | | `Feature_name_table features -> 212 | List.fold_left ( + ) (4 + 4) (List.map Feature.sizeof features) 213 | in 214 | let pad_to_8 x = if x mod 8 = 0 then x else x + (8 - (x mod 8)) in 215 | let extensions = 216 | List.( 217 | fold_left ( + ) 0 218 | (map (fun x -> pad_to_8 @@ unpadded_sizeof_extension x) t.extensions) 219 | ) 220 | in 221 | base + additional + extensions 222 | 223 | let write t rest = 224 | let initial_buffer_length = Cstruct.length rest in 225 | big_enough_for "Header" rest (sizeof t) >>= fun () -> 226 | Int8.write (int_of_char 'Q') rest >>= fun rest -> 227 | Int8.write (int_of_char 'F') rest >>= fun rest -> 228 | Int8.write (int_of_char 'I') rest >>= fun rest -> 229 | Int8.write 0xfb rest >>= fun rest -> 230 | Version.write t.version rest >>= fun rest -> 231 | Int64.write t.backing_file_offset rest >>= fun rest -> 232 | Int32.write t.backing_file_size rest >>= fun rest -> 233 | Int32.write t.cluster_bits rest >>= fun rest -> 234 | Int64.write t.size rest >>= fun rest -> 235 | CryptMethod.write t.crypt_method rest >>= fun rest -> 236 | Int32.write t.l1_size rest >>= fun rest -> 237 | Int64.write (Int64.of_int @@ Physical.to_bytes t.l1_table_offset) rest 238 | >>= fun rest -> 239 | Int64.write (Int64.of_int @@ Physical.to_bytes t.refcount_table_offset) rest 240 | >>= fun rest -> 241 | Int32.write t.refcount_table_clusters rest >>= fun rest -> 242 | Int32.write t.nb_snapshots rest >>= fun rest -> 243 | Int64.write t.snapshots_offset rest >>= fun rest -> 244 | match t.additional with 245 | | None -> 246 | return rest 247 | | Some e -> 248 | let incompatible_features = 249 | let bits = 250 | [ 251 | (if e.dirty then 1L <| 0 else 0L) 252 | ; (if e.corrupt then 1L <| 1 else 0L) 253 | ] 254 | in 255 | List.fold_left Int64.logor 0L bits 256 | in 257 | Int64.write incompatible_features rest >>= fun rest -> 258 | let compatible_features = 259 | let bits = [(if e.lazy_refcounts then 1L <| 0 else 0L)] in 260 | List.fold_left Int64.logor 0L bits 261 | in 262 | Int64.write compatible_features rest >>= fun rest -> 263 | Int64.write e.autoclear_features rest >>= fun rest -> 264 | Int32.write e.refcount_order rest >>= fun rest -> 265 | (* The extensions are not counted in the header_length *) 266 | let header_length = 267 | Int32.of_int (4 + initial_buffer_length - Cstruct.length rest) 268 | in 269 | Int32.write header_length rest >>= fun rest -> 270 | let write_extension rest = function 271 | | `Unknown (kind, data) -> 272 | Int32.write kind rest >>= fun rest -> 273 | let length = String.length data in 274 | Int32.write (Int32.of_int length) rest >>= fun rest -> 275 | Cstruct.blit_from_string data 0 rest 0 length ; 276 | Ok (Cstruct.shift rest (String.length data)) 277 | | `Backing_file filename -> 278 | Int32.write 0xE2792ACAl rest >>= fun rest -> 279 | let length = String.length filename in 280 | Int32.write (Int32.of_int length) rest >>= fun rest -> 281 | Cstruct.blit_from_string filename 0 rest 0 length ; 282 | Ok (Cstruct.shift rest (String.length filename)) 283 | | `Feature_name_table fs -> 284 | let length = List.fold_left ( + ) 0 (List.map Feature.sizeof fs) in 285 | Int32.write 0x6803f857l rest >>= fun rest -> 286 | Int32.write (Int32.of_int length) rest >>= fun rest -> 287 | Feature.write_all fs rest 288 | in 289 | let rec loop rest = function 290 | | [] -> 291 | Int32.write 0l rest 292 | | e :: es -> 293 | write_extension rest e >>= fun rest -> loop rest es 294 | in 295 | loop rest t.extensions 296 | 297 | let read rest = 298 | Int8.read rest >>= fun (x, rest) -> 299 | ( if char_of_int x = 'Q' then 300 | return rest 301 | else 302 | error_msg "Expected magic: got %02x" x 303 | ) 304 | >>= fun rest -> 305 | Int8.read rest >>= fun (x, rest) -> 306 | ( if char_of_int x = 'F' then 307 | return rest 308 | else 309 | error_msg "Expected magic: got %02x" x 310 | ) 311 | >>= fun rest -> 312 | Int8.read rest >>= fun (x, rest) -> 313 | ( if char_of_int x = 'I' then 314 | return rest 315 | else 316 | error_msg "Expected magic: got %02x" x 317 | ) 318 | >>= fun rest -> 319 | Int8.read rest >>= fun (x, rest) -> 320 | ( if x = 0xfb then 321 | return rest 322 | else 323 | error_msg "Expected magic: got %02x" x 324 | ) 325 | >>= fun rest -> 326 | Version.read rest >>= fun (version, rest) -> 327 | Int64.read rest >>= fun (backing_file_offset, rest) -> 328 | Int32.read rest >>= fun (backing_file_size, rest) -> 329 | Int32.read rest >>= fun (cluster_bits, rest) -> 330 | Int64.read rest >>= fun (size, rest) -> 331 | CryptMethod.read rest >>= fun (crypt_method, rest) -> 332 | Int32.read rest >>= fun (l1_size, rest) -> 333 | let l1_table_offset = Physical.read rest in 334 | let rest = Cstruct.shift rest 8 in 335 | let refcount_table_offset = Physical.read rest in 336 | let rest = Cstruct.shift rest 8 in 337 | Int32.read rest >>= fun (refcount_table_clusters, rest) -> 338 | Int32.read rest >>= fun (nb_snapshots, rest) -> 339 | Int64.read rest >>= fun (snapshots_offset, rest) -> 340 | ( match version with 341 | | `One | `Two -> 342 | return (None, [], 72, rest) 343 | | _ -> 344 | Int64.read rest >>= fun (incompatible_features, rest) -> 345 | let dirty = Int64.logand 1L (incompatible_features |> 0) = 1L in 346 | let corrupt = Int64.logand 1L (incompatible_features |> 1) = 1L in 347 | ( if incompatible_features |> 2 <> 0L then 348 | error_msg "unknown incompatible_features set: 0x%Lx" 349 | incompatible_features 350 | else 351 | return () 352 | ) 353 | >>= fun () -> 354 | Int64.read rest >>= fun (compatible_features, rest) -> 355 | let lazy_refcounts = Int64.logand 1L (compatible_features |> 0) = 1L in 356 | Int64.read rest >>= fun (autoclear_features, rest) -> 357 | ( if autoclear_features <> 0L then 358 | error_msg "dealing with autoclear_features not implemented" 359 | else 360 | return () 361 | ) 362 | >>= fun () -> 363 | Int32.read rest >>= fun (refcount_order, rest) -> 364 | Int32.read rest >>= fun (header_length, rest) -> 365 | let rec read_lowlevel rest = 366 | Int32.read rest >>= fun (kind, rest) -> 367 | if kind = 0l then 368 | return ([], rest) 369 | else 370 | Int32.read rest >>= fun (len, rest) -> 371 | let len = Int32.to_int len in 372 | let payload = Cstruct.sub rest 0 len in 373 | let rest = Cstruct.shift rest len in 374 | let padding_length = if len mod 8 = 0 then 0 else 8 - (len mod 8) in 375 | let rest = Cstruct.shift rest padding_length in 376 | read_lowlevel rest >>= fun (extensions, rest) -> 377 | return ((kind, payload) :: extensions, rest) 378 | in 379 | let parse_extension (kind, payload) = 380 | match kind with 381 | | 0xE2792ACAl -> 382 | Ok (`Backing_file (Cstruct.to_string payload)) 383 | | 0x6803f857l -> 384 | Feature.read_all payload >>= fun features -> 385 | Ok (`Feature_name_table features) 386 | | _ -> 387 | Ok (`Unknown (kind, Cstruct.to_string payload)) 388 | in 389 | read_lowlevel rest >>= fun (e, rest) -> 390 | List.fold_left 391 | (fun acc x -> 392 | acc >>= fun acc -> 393 | parse_extension x >>= fun extension -> Ok (extension :: acc) 394 | ) 395 | (Ok []) e 396 | >>= fun extensions -> 397 | let header_length = Int32.to_int header_length in 398 | return 399 | ( Some 400 | {dirty; corrupt; lazy_refcounts; autoclear_features; refcount_order} 401 | , extensions 402 | , header_length 403 | , rest 404 | ) 405 | ) 406 | >>= fun (additional, extensions, header_length, rest) -> 407 | let t = 408 | { 409 | version 410 | ; backing_file_offset 411 | ; backing_file_size 412 | ; cluster_bits 413 | ; size 414 | ; crypt_method 415 | ; l1_size 416 | ; l1_table_offset 417 | ; refcount_table_offset 418 | ; refcount_table_clusters 419 | ; nb_snapshots 420 | ; snapshots_offset 421 | ; additional 422 | ; extensions 423 | } 424 | in 425 | (* qemu excludes extensions from the header_length *) 426 | (* we ignore additional fields like compression_type *) 427 | if sizeof {t with extensions= []} > header_length then 428 | error_msg "Read a header_length of %d but we computed at least %d" 429 | header_length (sizeof t) 430 | else if header_length mod 8 <> 0 then 431 | error_msg "header_length must be a multiple of 8, but is %d" header_length 432 | else 433 | return (t, rest) 434 | 435 | let refcounts_per_cluster t = 436 | let cluster_bits = Int32.to_int t.cluster_bits in 437 | let cluster_size = 1L <| cluster_bits in 438 | (* Each reference count is 2 bytes long *) 439 | OldInt64.div cluster_size 2L 440 | 441 | let max_refcount_table_size t = 442 | let cluster_bits = Int32.to_int t.cluster_bits in 443 | let size = t.size in 444 | let cluster_size = 1L <| cluster_bits in 445 | let refs_per_cluster = refcounts_per_cluster t in 446 | let size_in_clusters = 447 | OldInt64.div (Int64.round_up size cluster_size) cluster_size 448 | in 449 | let refs_clusters_required = 450 | OldInt64.div 451 | (Int64.round_up size_in_clusters refs_per_cluster) 452 | refs_per_cluster 453 | in 454 | (* Each cluster containing references consumes 8 bytes in the 455 | refcount_table. How much space is that? *) 456 | let refcount_table_bytes = OldInt64.mul refs_clusters_required 8L in 457 | OldInt64.div (Int64.round_up refcount_table_bytes cluster_size) cluster_size 458 | 459 | let l2_tables_required ~cluster_bits size = 460 | (* The L2 table is of size (1L <| cluster_bits) bytes 461 | and contains (1L <| (cluster_bits - 3)) 8-byte pointers. 462 | A single L2 table therefore manages 463 | (1L <| (cluster_bits - 3)) * (1L <| cluster_bits) bytes 464 | = (1L <| (2 * cluster_bits - 3)) bytes. *) 465 | let bytes_per_l2 = 1L <| (2 * cluster_bits) - 3 in 466 | Int64.div (Int64.round_up size bytes_per_l2) bytes_per_l2 467 | -------------------------------------------------------------------------------- /lib/qcow_header.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) 2015 David Scott 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | *) 17 | 18 | module Version : sig 19 | type t = [`One | `Two | `Three] [@@deriving sexp] 20 | 21 | include Qcow_s.SERIALISABLE with type t := t 22 | 23 | val compare : t -> t -> int 24 | end 25 | 26 | module CryptMethod : sig 27 | type t = [`Aes | `None] [@@deriving sexp] 28 | 29 | include Qcow_s.SERIALISABLE with type t := t 30 | 31 | val compare : t -> t -> int 32 | end 33 | 34 | module Feature : sig 35 | type ty = [`Incompatible | `Compatible | `Autoclear] 36 | 37 | type feature = [`Corrupt | `Dirty | `Lazy_refcounts | `Unknown of string] 38 | 39 | type t = {ty: ty; bit: int; feature: feature} 40 | 41 | val understood : t list 42 | (** The features understood by this implementation *) 43 | 44 | include Qcow_s.SERIALISABLE with type t := t 45 | end 46 | 47 | (** Offset within the image *) 48 | type offset = int64 49 | 50 | type extension = 51 | [ `Unknown of int32 * string 52 | | `Backing_file of string 53 | | `Feature_name_table of Feature.t list ] 54 | [@@deriving sexp] 55 | 56 | (** Version 3 and above have additional header fields *) 57 | type additional = { 58 | dirty: bool 59 | ; corrupt: bool 60 | ; lazy_refcounts: bool 61 | ; autoclear_features: int64 62 | ; refcount_order: int32 63 | } 64 | [@@deriving sexp] 65 | 66 | (** The qcow2 header *) 67 | type t = { 68 | version: Version.t 69 | ; backing_file_offset: offset (** offset of the backing file path *) 70 | ; backing_file_size: int32 (** length of the backing file path *) 71 | ; cluster_bits: int32 (** a cluster is 2 ** cluster_bits in size *) 72 | ; size: int64 (** virtual size of the image *) 73 | ; crypt_method: CryptMethod.t 74 | ; l1_size: int32 (** number of 8-byte entries in the L1 table *) 75 | ; l1_table_offset: Qcow_physical.t (** offset of the L1 table *) 76 | ; refcount_table_offset: Qcow_physical.t (** offset of the refcount table *) 77 | ; refcount_table_clusters: int32 78 | (** size of the refcount table in clusters *) 79 | ; nb_snapshots: int32 (** the number of internal snapshots *) 80 | ; snapshots_offset: offset (** offset of the snapshot header *) 81 | ; additional: additional option (** for version 3 or higher *) 82 | ; extensions: extension list (** for version 3 or higher *) 83 | } 84 | [@@deriving sexp] 85 | 86 | val refcounts_per_cluster : t -> int64 87 | (** The number of 16-bit reference counts per cluster *) 88 | 89 | val max_refcount_table_size : t -> int64 90 | (** Compute the maximum size of the refcount table *) 91 | 92 | val l2_tables_required : cluster_bits:int -> int64 -> int64 93 | (** Compute the number of L2 tables required for this size of image *) 94 | 95 | include Qcow_s.SERIALISABLE with type t := t 96 | 97 | include Qcow_s.PRINTABLE with type t := t 98 | 99 | include Set.OrderedType with type t := t 100 | -------------------------------------------------------------------------------- /lib/qcow_int.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) 2015 David Scott 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | *) 17 | open Sexplib.Std 18 | 19 | module M = struct 20 | type t = int [@@deriving sexp] 21 | 22 | let zero = 0 23 | 24 | let succ x = x + 1 25 | 26 | let pred x = x - 1 27 | 28 | let add x y = x + y 29 | 30 | let sub x y = x - y 31 | 32 | let compare (x : t) (y : t) = Stdlib.compare x y 33 | 34 | let mul x y = x * y 35 | 36 | let div x y = x / y 37 | 38 | let to_int64 = Int64.of_int 39 | 40 | let of_int64 = Int64.to_int 41 | 42 | let to_int x = x 43 | 44 | let of_int x = x 45 | 46 | let to_string = string_of_int 47 | 48 | let shift_left x n = x lsl n 49 | 50 | let shift_right_logical x n = x lsr n 51 | 52 | let logor x y = x lor y 53 | 54 | let rem x y = x mod y 55 | end 56 | 57 | module IntervalSet = Qcow_diet.Make (M) 58 | module Map = Map.Make (M) 59 | include M 60 | 61 | let round_up x size = mul (div (add x (pred size)) size) size 62 | -------------------------------------------------------------------------------- /lib/qcow_int.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) 2015 David Scott 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | *) 17 | (** Parsers and printers for types used in qcow2 fields *) 18 | 19 | type t = int [@@deriving sexp] 20 | 21 | include Qcow_s.NUM with type t := t 22 | 23 | val of_int64 : int64 -> t 24 | 25 | val to_int64 : t -> int64 26 | 27 | val round_up : t -> t -> t 28 | (** [round_up value to] rounds [value] to the next multiple of [to] *) 29 | 30 | module IntervalSet : Qcow_s.INTERVAL_SET with type elt = t 31 | 32 | module Map : Map.S with type key = t 33 | -------------------------------------------------------------------------------- /lib/qcow_int64.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) 2015 David Scott 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | *) 17 | open Sexplib.Std 18 | open Qcow_error 19 | 20 | let big_enough_for name buf needed = 21 | let length = Cstruct.length buf in 22 | if length < needed then 23 | error_msg "%s: buffer too small (%d < %d)" name length needed 24 | else 25 | return () 26 | 27 | module M = struct 28 | include Int64 29 | 30 | type _t = int64 [@@deriving sexp] 31 | 32 | let sexp_of_t = sexp_of__t 33 | 34 | let t_of_sexp = _t_of_sexp 35 | 36 | let to_int64 x = x 37 | 38 | let of_int64 x = x 39 | end 40 | 41 | module IntervalSet = Qcow_diet.Make (M) 42 | module Map = Map.Make (M) 43 | include M 44 | 45 | let round_up x size = mul (div (add x (pred size)) size) size 46 | 47 | let round_down x size = mul (div x size) size 48 | 49 | let sizeof _ = 8 50 | 51 | let read buf = 52 | big_enough_for "Int64.read" buf 8 >>= fun () -> 53 | return (Cstruct.BE.get_uint64 buf 0, Cstruct.shift buf 8) 54 | 55 | let write t buf = 56 | big_enough_for "Int64.read" buf 8 >>= fun () -> 57 | Cstruct.BE.set_uint64 buf 0 t ; 58 | return (Cstruct.shift buf 8) 59 | -------------------------------------------------------------------------------- /lib/qcow_int64.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) 2015 David Scott 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | *) 17 | (** Parsers and printers for types used in qcow2 fields *) 18 | 19 | open Sexplib 20 | 21 | include module type of Int64 22 | 23 | val t_of_sexp : Sexp.t -> t 24 | 25 | val sexp_of_t : t -> Sexp.t 26 | 27 | val of_int64 : int64 -> t 28 | 29 | val to_int64 : t -> int64 30 | 31 | val round_up : int64 -> int64 -> int64 32 | (** [round_up value to] rounds [value] to the next multiple of [to] *) 33 | 34 | val round_down : int64 -> int64 -> int64 35 | (** [round_down value to] rounds [value] down to the multiple of [to] *) 36 | 37 | module IntervalSet : Qcow_s.INTERVAL_SET with type elt = t 38 | 39 | module Map : Map.S with type key = t 40 | 41 | include Qcow_s.SERIALISABLE with type t := t 42 | -------------------------------------------------------------------------------- /lib/qcow_locks.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) 2017 David Scott 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | *) 17 | open Qcow_types 18 | 19 | let src = 20 | let src = Logs.Src.create "qcow" ~doc:"qcow2-formatted BLOCK device" in 21 | Logs.Src.set_level src (Some Logs.Info) ; 22 | src 23 | 24 | module Log = (val Logs.src_log src : Logs.LOG) 25 | 26 | type t = { 27 | mutable locks: (Qcow_rwlock.t * int) Cluster.Map.t 28 | ; metadata_m: Lwt_mutex.t (** held during metadata changing operations *) 29 | } 30 | 31 | module Client = Qcow_rwlock.Client 32 | 33 | let make () = 34 | let locks = Cluster.Map.empty in 35 | let metadata_m = Lwt_mutex.create () in 36 | {locks; metadata_m} 37 | 38 | let with_metadata_lock t = Lwt_mutex.with_lock t.metadata_m 39 | 40 | let get_lock t cluster = 41 | let lock, refcount = 42 | if Cluster.Map.mem cluster t.locks then 43 | Cluster.Map.find cluster t.locks 44 | else 45 | ( Qcow_rwlock.make (fun () -> 46 | Printf.sprintf "cluster %s" (Cluster.to_string cluster) 47 | ) 48 | , 0 49 | ) 50 | in 51 | t.locks <- Cluster.Map.add cluster (lock, refcount + 1) t.locks ; 52 | lock 53 | 54 | let put_lock t cluster = 55 | (* put_lock is always called after get_lock *) 56 | assert (Cluster.Map.mem cluster t.locks) ; 57 | let lock, refcount = Cluster.Map.find cluster t.locks in 58 | t.locks <- 59 | ( if refcount = 1 then 60 | Cluster.Map.remove cluster t.locks 61 | else 62 | Cluster.Map.add cluster (lock, refcount - 1) t.locks 63 | ) 64 | 65 | let with_rwlock t cluster f = 66 | let lock = get_lock t cluster in 67 | Lwt.finalize 68 | (fun () -> f lock) 69 | (fun () -> put_lock t cluster ; Lwt.return_unit) 70 | 71 | type lock = {lock: Qcow_rwlock.lock; t: t; cluster: Cluster.t} 72 | 73 | let unlock lock = 74 | Qcow_rwlock.unlock lock.lock ; 75 | put_lock lock.t lock.cluster 76 | 77 | module Read = struct 78 | let with_lock ?client t cluster f = 79 | with_rwlock t cluster (fun rw -> Qcow_rwlock.Read.with_lock ?client rw f) 80 | 81 | let with_locks ?client t ~first ~last f = 82 | let rec loop n = 83 | if n > last then 84 | f () 85 | else 86 | with_rwlock t n (fun rw -> 87 | Qcow_rwlock.Read.with_lock ?client rw (fun () -> 88 | loop (Cluster.succ n) 89 | ) 90 | ) 91 | in 92 | loop first 93 | 94 | let lock ?client t cluster = 95 | let lock = get_lock t cluster in 96 | let open Lwt.Infix in 97 | Qcow_rwlock.Read.lock ?client lock >>= fun lock -> 98 | Lwt.return {lock; t; cluster} 99 | end 100 | 101 | module Write = struct 102 | let with_lock ?client t cluster f = 103 | with_rwlock t cluster (fun rw -> Qcow_rwlock.Write.with_lock ?client rw f) 104 | 105 | let with_locks ?client t ~first ~last f = 106 | let rec loop n = 107 | if n > last then 108 | f () 109 | else 110 | with_rwlock t n (fun rw -> 111 | Qcow_rwlock.Write.with_lock ?client rw (fun () -> 112 | loop (Cluster.succ n) 113 | ) 114 | ) 115 | in 116 | loop first 117 | 118 | let try_lock ?client t cluster = 119 | let lock = get_lock t cluster in 120 | match Qcow_rwlock.Write.try_lock ?client lock with 121 | | None -> 122 | put_lock t cluster ; None 123 | | Some lock -> 124 | let lock = {lock; t; cluster} in 125 | Some lock 126 | end 127 | 128 | module Debug = struct 129 | include Qcow_rwlock.Debug 130 | 131 | let dump_state t = 132 | let locks = List.map fst @@ List.map snd @@ Cluster.Map.bindings t.locks in 133 | Log.info (fun f -> 134 | f "%s" 135 | (Sexplib.Sexp.to_string_hum ~indent:2 @@ Qcow_rwlock.sexp_of_ts locks) 136 | ) 137 | end 138 | -------------------------------------------------------------------------------- /lib/qcow_locks.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) 2017 David Scott 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | *) 17 | open Qcow_types 18 | 19 | (** A set of per-cluster read and write locks *) 20 | type t 21 | 22 | val make : unit -> t 23 | (** Create a set of locks *) 24 | 25 | (** A value which represents holding a lock *) 26 | type lock 27 | 28 | val unlock : lock -> unit 29 | (** [unlock lock] releases the lock. Note releasing the same lock more than 30 | once will trigger a runtime failure. *) 31 | 32 | module Client : sig 33 | (** An entity which holds a set of locks *) 34 | type t 35 | 36 | val make : (unit -> string) -> t 37 | (** [make describe_fn] creates an entity where [describe_fn ()] returns 38 | a human-readable description of the client for use in debugging. *) 39 | end 40 | 41 | module Read : sig 42 | (** Non-exclusive read locks *) 43 | 44 | val with_lock : 45 | ?client:Client.t -> t -> Cluster.t -> (unit -> 'a Lwt.t) -> 'a Lwt.t 46 | (** [with_lock t f] executes [f ()] with the lock held for reading *) 47 | 48 | val with_locks : 49 | ?client:Client.t 50 | -> t 51 | -> first:Cluster.t 52 | -> last:Cluster.t 53 | -> (unit -> 'a Lwt.t) 54 | -> 'a Lwt.t 55 | (** [with_locks t ~first ~last f] executes [f ()] with all clusters in the 56 | interval [first .. last] inclusive locked for reading. *) 57 | 58 | val lock : ?client:Client.t -> t -> Cluster.t -> lock Lwt.t 59 | (** [lock t cluster] acquire a non-exclusive read lock on [cluster]. The 60 | resulting lock must be released by calling [unlock] *) 61 | end 62 | 63 | module Write : sig 64 | (** Exclusive write locks *) 65 | 66 | val with_lock : 67 | ?client:Client.t -> t -> Cluster.t -> (unit -> 'a Lwt.t) -> 'a Lwt.t 68 | (** [with_lock t f] executes [f ()] with the lock held for writing *) 69 | 70 | val with_locks : 71 | ?client:Client.t 72 | -> t 73 | -> first:Cluster.t 74 | -> last:Cluster.t 75 | -> (unit -> 'a Lwt.t) 76 | -> 'a Lwt.t 77 | (** [with_locks t ~first ~last f] executes [f ()] with all clusters in the 78 | interval [first .. last] inclusive locked for writing. *) 79 | 80 | val try_lock : ?client:Client.t -> t -> Cluster.t -> lock option 81 | (** [try_lock ?client t cluster] returns a write lock on [cluster] if it can 82 | be done without blocking, or returns None. *) 83 | end 84 | 85 | val with_metadata_lock : t -> (unit -> 'a Lwt.t) -> 'a Lwt.t 86 | (** [with_metadata_lock t f] executes [f ()] with the global metadata lock held. 87 | This prevents metadata blocks from moving while they're being used. *) 88 | 89 | module Debug : sig 90 | val assert_no_locks_held : Client.t -> unit 91 | (** Check that all locks have been explicitly released. *) 92 | 93 | val dump_state : t -> unit 94 | (** Write the cluster lock state to the logs for analysis *) 95 | end 96 | -------------------------------------------------------------------------------- /lib/qcow_metadata.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) 2017 Docker Inc 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | *) 17 | 18 | (** An in-memory cache of metadata clusters used to speed up lookups. 19 | 20 | Cache entries may be `read` or `update`d with a lock held to block 21 | concurrent access. 22 | *) 23 | 24 | open Qcow_types 25 | 26 | let src = 27 | let src = Logs.Src.create "qcow" ~doc:"qcow2-formatted BLOCK device" in 28 | Logs.Src.set_level src (Some Logs.Info) ; 29 | src 30 | 31 | module Log = (val Logs.src_log src : Logs.LOG) 32 | 33 | module Lwt_error = Qcow_error.Lwt_error 34 | module Lwt_write_error = Qcow_error.Lwt_write_error 35 | module Cache = Qcow_cache 36 | module Locks = Qcow_locks 37 | 38 | type error = [Mirage_block.error | `Msg of string] 39 | 40 | type write_error = [Mirage_block.write_error | `Msg of string] 41 | 42 | type t = { 43 | cache: Cache.t 44 | ; locks: Locks.t 45 | ; mutable cluster_map: Qcow_cluster_map.t option (* free/ used space map *) 46 | ; cluster_bits: int 47 | ; m: Lwt_mutex.t 48 | ; c: unit Lwt_condition.t 49 | } 50 | 51 | type contents = {t: t; data: Cstruct.t; cluster: Cluster.t} 52 | 53 | module Refcounts = struct 54 | type t = contents 55 | 56 | let of_contents x = x 57 | 58 | let get t n = Cstruct.BE.get_uint16 t.data (2 * n) 59 | 60 | let set t n v = Cstruct.BE.set_uint16 t.data (2 * n) v 61 | end 62 | 63 | module Physical = struct 64 | type t = contents 65 | 66 | let of_contents x = x 67 | 68 | let get t n = Qcow_physical.read (Cstruct.shift t.data (8 * n)) 69 | 70 | let set t n v = 71 | ( match t.t.cluster_map with 72 | | Some m -> 73 | (* Find the block currently being referenced so it can be marked 74 | as free. *) 75 | let existing = Qcow_physical.read (Cstruct.shift t.data (8 * n)) in 76 | let cluster = 77 | Qcow_physical.cluster ~cluster_bits:t.t.cluster_bits existing 78 | in 79 | let v' = Qcow_physical.cluster ~cluster_bits:t.t.cluster_bits v in 80 | Log.debug (fun f -> 81 | f "Physical.set %s:%d -> %s%s" 82 | (Cluster.to_string t.cluster) 83 | n 84 | ( if v = Qcow_physical.unmapped then 85 | "unmapped" 86 | else 87 | Cluster.to_string v' 88 | ) 89 | ( if cluster <> Cluster.zero then 90 | ", unmapping " ^ Cluster.to_string cluster 91 | else 92 | "" 93 | ) 94 | ) ; 95 | if cluster <> Cluster.zero then 96 | Qcow_cluster_map.remove m cluster ; 97 | Qcow_cluster_map.add m (t.cluster, n) v' 98 | | None -> 99 | () 100 | ) ; 101 | Qcow_physical.write v (Cstruct.shift t.data (8 * n)) 102 | 103 | let len t = Cstruct.length t.data / 8 104 | end 105 | 106 | let erase cluster = Cstruct.memset cluster.data 0 107 | 108 | let make ~cache ~cluster_bits ~locks () = 109 | let m = Lwt_mutex.create () in 110 | let c = Lwt_condition.create () in 111 | let cluster_map = None in 112 | {cache; cluster_map; cluster_bits; locks; m; c} 113 | 114 | let set_cluster_map t cluster_map = t.cluster_map <- Some cluster_map 115 | 116 | let read_and_lock ?client t cluster = 117 | let open Lwt.Infix in 118 | Locks.Read.lock ?client t.locks cluster >>= fun lock -> 119 | let open Lwt_error.Infix in 120 | Cache.read t.cache cluster >>= fun data -> 121 | Lwt.return (Ok ({t; data; cluster}, lock)) 122 | 123 | (** Read the contents of [cluster] and apply the function [f] with the 124 | lock held. *) 125 | let read ?client t cluster f = 126 | let open Lwt_error.Infix in 127 | Locks.Read.with_lock ?client t.locks cluster (fun () -> 128 | Cache.read t.cache cluster >>= fun data -> f {t; data; cluster} 129 | ) 130 | 131 | (** Read the contents of [cluster], transform it via function [f] and write 132 | back the results, all with the lock held. *) 133 | let update ?client t cluster f = 134 | let open Lwt_write_error.Infix in 135 | Locks.Write.with_lock ?client t.locks cluster (fun () -> 136 | (* Cancel any in-progress move since the data will be stale *) 137 | ( match t.cluster_map with 138 | | Some cluster_map -> 139 | Qcow_cluster_map.cancel_move cluster_map cluster 140 | | None -> 141 | () 142 | ) ; 143 | Cache.read t.cache cluster >>= fun data -> 144 | f {t; data; cluster} >>= fun result -> 145 | let open Lwt.Infix in 146 | Cache.write t.cache cluster data >>= function 147 | | Error `Is_read_only -> 148 | Lwt.return (Error `Is_read_only) 149 | | Error `Disconnected -> 150 | Lwt.return (Error `Disconnected) 151 | | Ok () -> 152 | Lwt.return (Ok result) 153 | ) 154 | -------------------------------------------------------------------------------- /lib/qcow_metadata.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) 2017 Docker Inc 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | *) 17 | open Qcow_types 18 | 19 | (** Qcow metadata: clusters containing references and clusters containing 20 | reference counts. *) 21 | type t 22 | 23 | type error = [Mirage_block.error | `Msg of string] 24 | 25 | type write_error = [Mirage_block.write_error | `Msg of string] 26 | 27 | val make : 28 | cache:Qcow_cache.t -> cluster_bits:int -> locks:Qcow_locks.t -> unit -> t 29 | (** Construct a qcow metadata structure given a set of cluster read/write/flush 30 | operations *) 31 | 32 | val set_cluster_map : t -> Qcow_cluster_map.t -> unit 33 | (** Set the associated cluster map (which will be updated on every cluster 34 | write) *) 35 | 36 | type contents 37 | 38 | module Refcounts : sig 39 | (** A cluster full of 16bit refcounts *) 40 | type t 41 | 42 | val of_contents : contents -> t 43 | (** Interpret the given cluster as a refcount cluster *) 44 | 45 | val get : t -> int -> int 46 | (** [get t n] return the [n]th refcount within [t] *) 47 | 48 | val set : t -> int -> int -> unit 49 | (** [set t n v] set the [n]th refcount within [t] to [v] *) 50 | end 51 | 52 | module Physical : sig 53 | (** A cluster full of 64 bit cluster pointers *) 54 | type t 55 | 56 | val of_contents : contents -> t 57 | (** Interpret the given cluster as a cluster of 64 bit pointers *) 58 | 59 | val get : t -> int -> Qcow_physical.t 60 | (** [get t n] return the [n]th physical address within [t] *) 61 | 62 | val set : t -> int -> Qcow_physical.t -> unit 63 | (** [set t n v] set the [n]th physical address within [t] to [v] *) 64 | 65 | val len : t -> int 66 | (** [len t] returns the number of physical addresses within [t] *) 67 | end 68 | 69 | val erase : contents -> unit 70 | (** Set the cluster contents to zeroes *) 71 | 72 | val read_and_lock : 73 | ?client:Qcow_locks.Client.t 74 | -> t 75 | -> Cluster.t 76 | -> (contents * Qcow_locks.lock, error) result Lwt.t 77 | 78 | val read : 79 | ?client:Qcow_locks.Client.t 80 | -> t 81 | -> Cluster.t 82 | -> (contents -> ('a, error) result Lwt.t) 83 | -> ('a, error) result Lwt.t 84 | (** Read the contents of the given cluster and provide them to the given function *) 85 | 86 | val update : 87 | ?client:Qcow_locks.Client.t 88 | -> t 89 | -> Cluster.t 90 | -> (contents -> ('a, write_error) result Lwt.t) 91 | -> ('a, write_error) result Lwt.t 92 | (** Read the contents of the given cluster, transform them through the given 93 | function and write the results back to disk *) 94 | -------------------------------------------------------------------------------- /lib/qcow_padded.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) 2017 Docker Inc 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | *) 17 | 18 | module Cstructs = Qcow_cstructs 19 | 20 | module Make (B : Qcow_s.RESIZABLE_BLOCK) = struct 21 | include B 22 | 23 | let handle_error = function 24 | | `Disconnected -> 25 | Lwt.return (Error `Disconnected) 26 | | _ -> 27 | Format.kasprintf Lwt.fail_with "Unknown error in qcow_paddle.ml" 28 | 29 | let read base base_sector buf = 30 | let open Lwt in 31 | B.get_info base >>= fun base_info -> 32 | let buf_len = Int64.of_int (Cstructs.len buf) in 33 | let missing_sectors = 34 | Int64.sub 35 | Int64.( 36 | add base_sector 37 | (div buf_len (of_int base_info.Mirage_block.sector_size)) 38 | ) 39 | base_info.Mirage_block.size_sectors 40 | in 41 | if missing_sectors > 0L then ( 42 | let available_sectors = 43 | Int64.( 44 | sub 45 | (div buf_len (of_int base_info.Mirage_block.sector_size)) 46 | missing_sectors 47 | ) 48 | in 49 | let bytes = 50 | Int64.( 51 | to_int 52 | (mul available_sectors (of_int base_info.Mirage_block.sector_size)) 53 | ) 54 | in 55 | let open Lwt.Infix in 56 | ( if bytes > 0 then 57 | B.read base base_sector (Cstructs.sub buf 0 bytes) 58 | else 59 | Lwt.return (Ok ()) 60 | ) 61 | >>= function 62 | | Error e -> 63 | handle_error e 64 | | Ok () -> 65 | Cstructs.(memset (shift buf (max 0 bytes)) 0) ; 66 | Lwt.return (Ok ()) 67 | ) else 68 | B.read base base_sector buf >>= function 69 | | Error e -> 70 | handle_error e 71 | | Ok () -> 72 | Lwt.return (Ok ()) 73 | end 74 | -------------------------------------------------------------------------------- /lib/qcow_padded.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) 2017 Docker Inc 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | *) 17 | 18 | module Make (B : Qcow_s.RESIZABLE_BLOCK) : sig 19 | (** A block device which is padded with virtual zeroes so that reads beyond 20 | the current end don't fail. *) 21 | 22 | include Qcow_s.RESIZABLE_BLOCK with type t = B.t 23 | end 24 | -------------------------------------------------------------------------------- /lib/qcow_physical.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) 2015 David Scott 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | *) 17 | 18 | open Sexplib.Std 19 | open Qcow_types 20 | 21 | let ( <| ) = Cluster.shift_left 22 | 23 | let ( |> ) = Cluster.shift_right_logical 24 | 25 | type t = Cluster.t (* the encoded form on the disk *) 26 | 27 | let unmapped = Cluster.zero 28 | 29 | let one = Cluster.succ Cluster.zero 30 | 31 | let make ?(is_mutable = false) ?(is_compressed = false) x = 32 | let x = Cluster.of_int x in 33 | let bytes = x <| 2 |> 2 in 34 | let is_mutable = if is_mutable then one <| 63 else Cluster.zero in 35 | let is_compressed = if is_compressed then one <| 62 else Cluster.zero in 36 | Cluster.(logor (logor bytes is_mutable) is_compressed) 37 | 38 | let is_mutable t = t |> 63 <> Cluster.zero 39 | 40 | let is_compressed t = t <| 1 |> 63 <> Cluster.zero 41 | 42 | let shift t bytes = 43 | let bytes = Cluster.of_int bytes in 44 | let bytes' = t <| 2 |> 2 in 45 | let is_mutable = is_mutable t in 46 | let is_compressed = is_compressed t in 47 | make ~is_mutable ~is_compressed Cluster.(to_int @@ add bytes' bytes) 48 | 49 | let sector ~sector_size t = 50 | let x = t <| 2 |> 2 in 51 | Cluster.(to_int64 @@ div x (of_int sector_size)) 52 | 53 | (* Take an offset and round it down to the nearest physical sector, returning 54 | the sector number and an offset within the sector *) 55 | let to_sector ~sector_size t = 56 | let x = t <| 2 |> 2 in 57 | ( Cluster.(to_int64 @@ div x (of_int sector_size)) 58 | , Cluster.(to_int (rem x (of_int sector_size))) 59 | ) 60 | 61 | let to_bytes t = Cluster.to_int (t <| 2 |> 2) 62 | 63 | let add x y = Cluster.add x (Cluster.of_int y) 64 | 65 | let cluster ~cluster_bits t = 66 | let x = t <| 2 |> 2 in 67 | Cluster.(div x (one <| cluster_bits)) 68 | 69 | let within_cluster ~cluster_bits t = 70 | let x = t <| 2 |> 2 in 71 | Cluster.(to_int (rem x (one <| cluster_bits))) / 8 72 | 73 | let read rest = Cluster.of_int64 @@ Cstruct.BE.get_uint64 rest 0 74 | 75 | let write t rest = 76 | let t = Cluster.to_int64 t in 77 | Cstruct.BE.set_uint64 rest 0 t 78 | 79 | type _t = {bytes: Cluster.t; is_mutable: bool; is_compressed: bool} 80 | [@@deriving sexp] 81 | 82 | let sexp_of_t t = 83 | let bytes = t <| 2 |> 2 in 84 | let is_mutable = is_mutable t in 85 | let is_compressed = is_compressed t in 86 | let _t = {bytes; is_mutable; is_compressed} in 87 | sexp_of__t _t 88 | 89 | let t_of_sexp s = 90 | let _t = _t_of_sexp s in 91 | let is_mutable = if _t.is_mutable then one <| 63 else Cluster.zero in 92 | let is_compressed = if _t.is_compressed then one <| 62 else Cluster.zero in 93 | Cluster.(logor (logor _t.bytes is_mutable) is_compressed) 94 | 95 | let to_string t = Sexplib.Sexp.to_string (sexp_of_t t) 96 | -------------------------------------------------------------------------------- /lib/qcow_physical.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) 2015 David Scott 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | *) 17 | 18 | open Qcow_types 19 | 20 | (** A physical address within the backing disk *) 21 | type t [@@deriving sexp] 22 | 23 | val is_compressed : t -> bool 24 | (** True if the address has been marked as being compressed *) 25 | 26 | val is_mutable : t -> bool 27 | (** True if the offset is safe to mutate directly (i.e. is not referenced 28 | by a snapshot *) 29 | 30 | val unmapped : t 31 | (** An unmapped physical address *) 32 | 33 | val shift : t -> int -> t 34 | (** [shift t bytes] adds [bytes] to t, maintaining other properties *) 35 | 36 | val make : ?is_mutable:bool -> ?is_compressed:bool -> int -> t 37 | (** Create an address at the given byte offset. This defaults to [is_mutable = true] 38 | which meand there are no snapshots implying that directly writing to this 39 | offset is ok; and [is_compressed = false]. *) 40 | 41 | val add : t -> int -> t 42 | (** Add a byte offset to a physical address *) 43 | 44 | val to_sector : sector_size:int -> t -> int64 * int 45 | (** Return the sector on disk, plus a remainder within the sector *) 46 | 47 | val sector : sector_size:int -> t -> int64 48 | (** Return the sector on disk containing the address *) 49 | 50 | val to_bytes : t -> int 51 | (** Return the byte offset on disk *) 52 | 53 | val cluster : cluster_bits:int -> t -> Cluster.t 54 | (** Return the cluster containing the address *) 55 | 56 | val within_cluster : cluster_bits:int -> t -> int 57 | (** Return the index within the cluster of the address *) 58 | 59 | val read : Cstruct.t -> t 60 | (** Read a [t] from the given buffer *) 61 | 62 | val write : t -> Cstruct.t -> unit 63 | (** Write [t] to the buffer *) 64 | 65 | include Qcow_s.PRINTABLE with type t := t 66 | -------------------------------------------------------------------------------- /lib/qcow_recycler.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) 2017 Docker Inc 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | *) 17 | open Qcow_types 18 | 19 | module Make (B : Qcow_s.RESIZABLE_BLOCK) : sig 20 | (** A cluster recycling engine *) 21 | type t 22 | 23 | val create : 24 | base:B.t 25 | -> sector_size:int 26 | -> cluster_bits:int 27 | -> cache:Qcow_cache.t 28 | -> locks:Qcow_locks.t 29 | -> metadata:Qcow_metadata.t 30 | -> runtime_asserts:bool 31 | -> t 32 | (** Initialise a cluster recycler over the given block device *) 33 | 34 | val set_cluster_map : t -> Qcow_cluster_map.t -> unit 35 | (** Set the associated cluster map (which will be updated on every cluster 36 | write) *) 37 | 38 | val start_background_thread : 39 | t -> keep_erased:int64 -> ?compact_after_unmaps:int64 -> unit -> unit 40 | (** Start a background thread which will perform block recycling *) 41 | 42 | val allocate : t -> Cluster.t -> Cluster.IntervalSet.t option 43 | (** [allocate t n] returns [n] clusters which are ready for re-use. If there 44 | are not enough clusters free then this returns None. *) 45 | 46 | val erase : t -> Cluster.IntervalSet.t -> (unit, B.write_error) result Lwt.t 47 | (** Write zeroes over the specified set of clusters *) 48 | 49 | val copy : t -> Cluster.t -> Cluster.t -> (unit, B.write_error) result Lwt.t 50 | (** [copy src dst] copies the cluster [src] to [dst] *) 51 | 52 | val move_all : 53 | ?progress_cb:(percent:int -> unit) 54 | -> t 55 | -> Qcow_cluster_map.Move.t list 56 | -> (unit, Qcow_metadata.write_error) result Lwt.t 57 | (** [move_all t mv] perform the initial data copy of the move operations [mv] *) 58 | 59 | val update_references : t -> (int64, Qcow_metadata.write_error) result Lwt.t 60 | (** [update_references t] rewrites references to any recently copied and 61 | flushed block, returning the number of writes completed. *) 62 | 63 | val flush : t -> (unit, B.write_error) result Lwt.t 64 | (** Issue a flush to the block device, update internal recycler state. *) 65 | end 66 | -------------------------------------------------------------------------------- /lib/qcow_rwlock.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) 2016 David Scott 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | *) 17 | open Sexplib.Std 18 | 19 | let src = 20 | let src = Logs.Src.create "qcow" ~doc:"qcow2-formatted BLOCK device" in 21 | Logs.Src.set_level src (Some Logs.Info) ; 22 | src 23 | 24 | module Log = (val Logs.src_log src : Logs.LOG) 25 | 26 | (* A resource that can be locked *) 27 | type t = { 28 | t_description_fn: unit -> string 29 | ; m: Lwt_mutex.t 30 | ; c: unit Lwt_condition.t 31 | ; mutable all_locks: lock list 32 | } 33 | 34 | (* A lock held on a resource *) 35 | and lock = { 36 | t: t 37 | ; client: client 38 | ; mutable reader: bool (* or writer *) 39 | ; mutable released: bool 40 | } 41 | 42 | (* A client owning the lock *) 43 | and client = { 44 | client_description_fn: unit -> string 45 | ; mutable my_locks: lock list 46 | } 47 | 48 | type ts = t list 49 | 50 | let make t_description_fn = 51 | let m = Lwt_mutex.create () in 52 | let c = Lwt_condition.create () in 53 | let all_locks = [] in 54 | {t_description_fn; m; c; all_locks} 55 | 56 | module To_sexp = struct 57 | (* Project instances of type t into a simpler set of records, organised for 58 | printing. *) 59 | module Lock = struct 60 | type t = {description: string; mode: [`Read | `Write]; released: bool} 61 | [@@deriving sexp_of] 62 | end 63 | 64 | module Client = struct 65 | type t = {description: string; locks: Lock.t list} [@@deriving sexp_of] 66 | end 67 | 68 | type t = {description: string; clients: Client.t list} [@@deriving sexp_of] 69 | 70 | let rec setify eq = function 71 | | [] -> 72 | [] 73 | | x :: xs -> 74 | if List.filter (fun y -> eq x y) xs <> [] then 75 | setify eq xs 76 | else 77 | x :: setify eq xs 78 | 79 | let lock l = 80 | let description = l.t.t_description_fn () in 81 | let mode = if l.reader then `Read else `Write in 82 | let released = l.released in 83 | {Lock.description; mode; released} 84 | 85 | let client c = 86 | let description = c.client_description_fn () in 87 | (* Make the per-client list easier to read by de-duplicating it *) 88 | let locks = setify ( = ) @@ List.map lock c.my_locks in 89 | {Client.description; locks} 90 | 91 | let t t = 92 | let description = t.t_description_fn () in 93 | let clients = 94 | List.map client 95 | @@ setify ( == ) 96 | @@ List.map (fun l -> l.client) t.all_locks 97 | in 98 | {description; clients} 99 | 100 | type ts = Client.t list [@@deriving sexp_of] 101 | 102 | let ts ts = 103 | let all_locks = List.concat @@ List.map (fun t -> t.all_locks) ts in 104 | List.map client @@ setify ( == ) @@ List.map (fun l -> l.client) all_locks 105 | end 106 | 107 | let sexp_of_t x = To_sexp.(sexp_of_t @@ t x) 108 | 109 | let sexp_of_ts xs = To_sexp.(sexp_of_ts @@ ts xs) 110 | 111 | let sexp_of_client x = To_sexp.(Client.sexp_of_t @@ client x) 112 | 113 | let anon_client = 114 | let next_idx = ref 0 in 115 | fun () -> 116 | let idx = !next_idx in 117 | incr next_idx ; 118 | let client_description_fn () = Printf.sprintf "Anonymous client %d" idx in 119 | let my_locks = [] in 120 | {client_description_fn; my_locks} 121 | 122 | let unlock lock = 123 | assert (not lock.released) ; 124 | lock.released <- true ; 125 | lock.client.my_locks <- List.filter (fun l -> l != lock) lock.client.my_locks ; 126 | lock.t.all_locks <- List.filter (fun l -> l != lock) lock.t.all_locks ; 127 | Lwt_condition.broadcast lock.t.c () 128 | 129 | let any f xs = List.fold_left (fun acc x -> acc || f x) false xs 130 | 131 | module Read = struct 132 | let lock ?(client = anon_client ()) t = 133 | let open Lwt.Infix in 134 | Lwt_mutex.with_lock t.m (fun () -> 135 | let rec wait () = 136 | (* If any other client has a write lock then wait *) 137 | let any_other_writer = 138 | any (fun l -> l.client != client && not l.reader) t.all_locks 139 | in 140 | if any_other_writer then 141 | Lwt_condition.wait t.c ~mutex:t.m >>= fun () -> wait () 142 | else 143 | let reader = true and released = false in 144 | let lock = {t; client; reader; released} in 145 | t.all_locks <- lock :: t.all_locks ; 146 | client.my_locks <- lock :: client.my_locks ; 147 | Lwt.return lock 148 | in 149 | wait () 150 | ) 151 | 152 | let with_lock ?(client = anon_client ()) t f = 153 | let open Lwt.Infix in 154 | lock ~client t >>= fun lock -> 155 | Lwt.finalize f (fun () -> unlock lock ; Lwt.return_unit) 156 | end 157 | 158 | module Write = struct 159 | let any_other_client t client = any (fun l -> l.client != client) t.all_locks 160 | 161 | let with_lock ?(client = anon_client ()) t f = 162 | let open Lwt.Infix in 163 | Lwt_mutex.with_lock t.m (fun () -> 164 | let rec wait () = 165 | (* If any other client has a lock then wait *) 166 | if any_other_client t client then 167 | Lwt_condition.wait t.c ~mutex:t.m >>= fun () -> wait () 168 | else 169 | let reader = false and released = false in 170 | let lock = {t; client; reader; released} in 171 | t.all_locks <- lock :: t.all_locks ; 172 | client.my_locks <- lock :: client.my_locks ; 173 | Lwt.return lock 174 | in 175 | wait () 176 | ) 177 | >>= fun lock -> Lwt.finalize f (fun () -> unlock lock ; Lwt.return_unit) 178 | 179 | let try_lock ?(client = anon_client ()) t = 180 | if any_other_client t client then 181 | None 182 | else 183 | let reader = false and released = false in 184 | let lock = {t; client; reader; released} in 185 | t.all_locks <- lock :: t.all_locks ; 186 | client.my_locks <- lock :: client.my_locks ; 187 | Some lock 188 | end 189 | 190 | module Client = struct 191 | type t = client 192 | 193 | let make client_description_fn = 194 | let my_locks = [] in 195 | {client_description_fn; my_locks} 196 | end 197 | 198 | module Debug = struct 199 | let assert_no_locks_held client = 200 | if client.my_locks <> [] then ( 201 | Printf.fprintf stderr "Client still holds locks:\n%s\n%!" 202 | (Sexplib.Sexp.to_string_hum ~indent:2 @@ sexp_of_client client) ; 203 | assert false 204 | ) 205 | end 206 | -------------------------------------------------------------------------------- /lib/qcow_rwlock.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) 2016 David Scott 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | *) 17 | 18 | (** A lock which permits multiple concurrent threads to acquire it for reading 19 | but demands exclusivity for writing *) 20 | type t [@@deriving sexp_of] 21 | 22 | type ts = t list [@@deriving sexp_of] 23 | 24 | val make : (unit -> string) -> t 25 | (** [make describe_fn] creates a new lock, where [describe_fn ()] returns a 26 | human-readable description string suitable for debug output. *) 27 | 28 | (** A value which represents holding a lock *) 29 | type lock 30 | 31 | val unlock : lock -> unit 32 | (** [unlock locked] releases the lock associated with [locked] *) 33 | 34 | module Client : sig 35 | (** An entity which holds a set of locks *) 36 | type t 37 | 38 | val make : (unit -> string) -> t 39 | (** [make describe_fn] creates an entity where [describe_fn ()] returns 40 | a human-readable description of the client for use in debugging. *) 41 | end 42 | 43 | module Read : sig 44 | val with_lock : ?client:Client.t -> t -> (unit -> 'a Lwt.t) -> 'a Lwt.t 45 | (** [with_lock ?client t f] executes [f ()] when no other client has held 46 | the lock exclusively for writing. Note this means that I may hold the lock 47 | for writing and then re-lock it for reading. 48 | *) 49 | 50 | val lock : ?client:Client.t -> t -> lock Lwt.t 51 | (** [lock ?client t] locks [t]. This function blocks while another client 52 | holds the lock for writing. The lock must be released with [unlock] *) 53 | end 54 | 55 | module Write : sig 56 | val with_lock : ?client:Client.t -> t -> (unit -> 'a Lwt.t) -> 'a Lwt.t 57 | (** [with_lock ?client t f] executes [f ()] when no-other client is holding 58 | the lock for reading or writing. Note this means that I may hold the lock 59 | for reading and then re-lock it for writing. *) 60 | 61 | val try_lock : ?client:Client.t -> t -> lock option 62 | (** [try_lock ?client t] acquires a write lock on [t] if immediately possible, 63 | or returns None *) 64 | end 65 | 66 | module Debug : sig 67 | val assert_no_locks_held : Client.t -> unit 68 | (** Check that all locks have been explicitly released. *) 69 | end 70 | -------------------------------------------------------------------------------- /lib/qcow_s.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) 2015 David Scott 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | *) 17 | 18 | (** Common signatures used by the library *) 19 | 20 | module type LOG = sig 21 | (** Common logging functions *) 22 | 23 | val debug : ('a, unit, string, unit) format4 -> 'a 24 | 25 | val info : ('a, unit, string, unit) format4 -> 'a 26 | 27 | val error : ('a, unit, string, unit) format4 -> 'a 28 | end 29 | 30 | module type SERIALISABLE = sig 31 | (** Values which can be read and written *) 32 | 33 | (** Instances of this type can be read and written *) 34 | type t 35 | 36 | val sizeof : t -> int 37 | (** The size of a buffer needed to hold [t] *) 38 | 39 | val read : Cstruct.t -> (t * Cstruct.t, [`Msg of string]) result 40 | (** Read a [t] from the given buffer and return it, along with the 41 | unused remainder of the buffer. If the buffer cannot 42 | be parsed then return an error.*) 43 | 44 | val write : t -> Cstruct.t -> (Cstruct.t, [`Msg of string]) result 45 | (** Write a [t] into the given buffer. If the buffer is too small, 46 | then return an error. Return the unused remainder of the buffer.*) 47 | end 48 | 49 | module type PRINTABLE = sig 50 | (** Values which can be pretty-printed *) 51 | 52 | (** Instances of this type can be pretty-printed *) 53 | type t 54 | 55 | val to_string : t -> string 56 | (** Produce a pretty human-readable string from a value *) 57 | end 58 | 59 | module type RESIZABLE_BLOCK = sig 60 | include Mirage_block.S 61 | 62 | val resize : t -> int64 -> (unit, write_error) result Lwt.t 63 | (** Resize the file to the given number of sectors. *) 64 | 65 | val flush : t -> (unit, write_error) result Lwt.t 66 | (** [flush t] flushes any buffers, if the file has been opened in buffered 67 | mode *) 68 | end 69 | 70 | module type INTERVAL_SET = sig 71 | (** The type of the set elements *) 72 | type elt 73 | 74 | (** An interval: a range (x, y) of set values where all the elements from 75 | x to y inclusive are in the set *) 76 | type interval 77 | 78 | module Interval : sig 79 | val make : elt -> elt -> interval 80 | (** [make first last] construct an interval describing all the elements from 81 | [first] to [last] inclusive. *) 82 | 83 | val x : interval -> elt 84 | (** the starting element of the interval *) 85 | 86 | val y : interval -> elt 87 | (** the ending element of the interval *) 88 | end 89 | 90 | (** The type of sets *) 91 | type t [@@deriving sexp] 92 | 93 | val empty : t 94 | (** The empty set *) 95 | 96 | val is_empty : t -> bool 97 | (** Test whether a set is empty or not *) 98 | 99 | val cardinal : t -> elt 100 | (** [cardinal t] is the number of elements in the set [t] *) 101 | 102 | val mem : elt -> t -> bool 103 | (** [mem elt t] tests whether [elt] is in set [t] *) 104 | 105 | val fold : (interval -> 'a -> 'a) -> t -> 'a -> 'a 106 | (** [fold f t acc] folds [f] across all the intervals in [t] *) 107 | 108 | val fold_s : (interval -> 'a -> 'a Lwt.t) -> t -> 'a -> 'a Lwt.t 109 | (** [fold_s f t acc] folds [f] across all the intervals in [t] *) 110 | 111 | val fold_individual : (elt -> 'a -> 'a) -> t -> 'a -> 'a 112 | (** [fold_individual f t acc] folds [f] across all the individual elements of [t] *) 113 | 114 | val add : interval -> t -> t 115 | (** [add interval t] returns the set consisting of [t] plus [interval] *) 116 | 117 | val remove : interval -> t -> t 118 | (** [remove interval t] returns the set consisting of [t] minus [interval] *) 119 | 120 | val min_elt : t -> interval 121 | (** [min_elt t] returns the smallest (in terms of the ordering) interval in 122 | [t], or raises [Not_found] if the set is empty. *) 123 | 124 | val max_elt : t -> interval 125 | (** [max_elt t] returns the largest (in terms of the ordering) interval in 126 | [t], or raises [Not_found] if the set is empty. *) 127 | 128 | val choose : t -> interval 129 | (** [choose t] returns one interval, or raises Not_found if the set is empty *) 130 | 131 | val take : t -> elt -> (t * t) option 132 | (** [take n] returns [Some a, b] where [cardinal a = n] and [diff t a = b] 133 | or [None] if [cardinal t < n] *) 134 | 135 | val union : t -> t -> t 136 | (** set union *) 137 | 138 | val diff : t -> t -> t 139 | (** set difference *) 140 | 141 | val inter : t -> t -> t 142 | (** set intersection *) 143 | end 144 | 145 | module type NUM = sig 146 | type t 147 | 148 | val zero : t 149 | 150 | val pred : t -> t 151 | 152 | val succ : t -> t 153 | 154 | val add : t -> t -> t 155 | 156 | val sub : t -> t -> t 157 | 158 | val mul : t -> t -> t 159 | 160 | val div : t -> t -> t 161 | 162 | val of_int64 : int64 -> t 163 | 164 | val to_int64 : t -> int64 165 | 166 | val of_int : int -> t 167 | 168 | val to_int : t -> int 169 | 170 | val to_string : t -> string 171 | 172 | val shift_left : t -> int -> t 173 | 174 | val shift_right_logical : t -> int -> t 175 | 176 | val logor : t -> t -> t 177 | 178 | val rem : t -> t -> t 179 | end 180 | -------------------------------------------------------------------------------- /lib/qcow_s.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) 2015 David Scott 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | *) 17 | 18 | (** Common signatures used by the library *) 19 | 20 | module type LOG = sig 21 | (** Common logging functions *) 22 | 23 | val debug : ('a, unit, string, unit) format4 -> 'a 24 | 25 | val info : ('a, unit, string, unit) format4 -> 'a 26 | 27 | val error : ('a, unit, string, unit) format4 -> 'a 28 | end 29 | 30 | module type SERIALISABLE = sig 31 | (** Values which can be read and written *) 32 | 33 | (** Instances of this type can be read and written *) 34 | type t 35 | 36 | val sizeof : t -> int 37 | (** The size of a buffer needed to hold [t] *) 38 | 39 | val read : Cstruct.t -> (t * Cstruct.t, [`Msg of string]) result 40 | (** Read a [t] from the given buffer and return it, along with the 41 | unused remainder of the buffer. If the buffer cannot 42 | be parsed then return an error.*) 43 | 44 | val write : t -> Cstruct.t -> (Cstruct.t, [`Msg of string]) result 45 | (** Write a [t] into the given buffer. If the buffer is too small, 46 | then return an error. Return the unused remainder of the buffer.*) 47 | end 48 | 49 | module type PRINTABLE = sig 50 | (** Values which can be pretty-printed *) 51 | 52 | (** Instances of this type can be pretty-printed *) 53 | type t 54 | 55 | val to_string : t -> string 56 | (** Produce a pretty human-readable string from a value *) 57 | end 58 | 59 | module type RESIZABLE_BLOCK = sig 60 | include Mirage_block.S 61 | 62 | val resize : t -> int64 -> (unit, write_error) result Lwt.t 63 | (** Resize the file to the given number of sectors. *) 64 | 65 | val flush : t -> (unit, write_error) result Lwt.t 66 | (** [flush t] flushes any buffers, if the file has been opened in buffered 67 | mode *) 68 | end 69 | 70 | module type INTERVAL_SET = sig 71 | (** The type of the set elements *) 72 | type elt 73 | 74 | (** An interval: a range (x, y) of set values where all the elements from 75 | x to y inclusive are in the set *) 76 | type interval 77 | 78 | module Interval : sig 79 | val make : elt -> elt -> interval 80 | (** [make first last] construct an interval describing all the elements from 81 | [first] to [last] inclusive. *) 82 | 83 | val x : interval -> elt 84 | (** the starting element of the interval *) 85 | 86 | val y : interval -> elt 87 | (** the ending element of the interval *) 88 | end 89 | 90 | (** The type of sets *) 91 | type t [@@deriving sexp] 92 | 93 | val empty : t 94 | (** The empty set *) 95 | 96 | val is_empty : t -> bool 97 | (** Test whether a set is empty or not *) 98 | 99 | val cardinal : t -> elt 100 | (** [cardinal t] is the number of elements in the set [t] *) 101 | 102 | val mem : elt -> t -> bool 103 | (** [mem elt t] tests whether [elt] is in set [t] *) 104 | 105 | val fold : (interval -> 'a -> 'a) -> t -> 'a -> 'a 106 | (** [fold f t acc] folds [f] across all the intervals in [t] *) 107 | 108 | val fold_s : (interval -> 'a -> 'a Lwt.t) -> t -> 'a -> 'a Lwt.t 109 | (** [fold_s f t acc] folds [f] across all the intervals in [t] *) 110 | 111 | val fold_individual : (elt -> 'a -> 'a) -> t -> 'a -> 'a 112 | (** [fold_individual f t acc] folds [f] across all the individual elements of [t] *) 113 | 114 | val add : interval -> t -> t 115 | (** [add interval t] returns the set consisting of [t] plus [interval] *) 116 | 117 | val remove : interval -> t -> t 118 | (** [remove interval t] returns the set consisting of [t] minus [interval] *) 119 | 120 | val min_elt : t -> interval 121 | (** [min_elt t] returns the smallest (in terms of the ordering) interval in 122 | [t], or raises [Not_found] if the set is empty. *) 123 | 124 | val max_elt : t -> interval 125 | (** [max_elt t] returns the largest (in terms of the ordering) interval in 126 | [t], or raises [Not_found] if the set is empty. *) 127 | 128 | val choose : t -> interval 129 | (** [choose t] returns one interval, or raises Not_found if the set is empty *) 130 | 131 | val take : t -> elt -> (t * t) option 132 | (** [take n] returns [Some a, b] where [cardinal a = n] and [diff t a = b] 133 | or [None] if [cardinal t < n] *) 134 | 135 | val union : t -> t -> t 136 | (** set union *) 137 | 138 | val diff : t -> t -> t 139 | (** set difference *) 140 | 141 | val inter : t -> t -> t 142 | (** set intersection *) 143 | end 144 | 145 | module type NUM = sig 146 | type t 147 | 148 | val zero : t 149 | 150 | val pred : t -> t 151 | 152 | val succ : t -> t 153 | 154 | val add : t -> t -> t 155 | 156 | val sub : t -> t -> t 157 | 158 | val mul : t -> t -> t 159 | 160 | val div : t -> t -> t 161 | 162 | val of_int64 : int64 -> t 163 | 164 | val to_int64 : t -> int64 165 | 166 | val of_int : int -> t 167 | 168 | val to_int : t -> int 169 | 170 | val to_string : t -> string 171 | 172 | val shift_left : t -> int -> t 173 | 174 | val shift_right_logical : t -> int -> t 175 | 176 | val logor : t -> t -> t 177 | 178 | val rem : t -> t -> t 179 | end 180 | -------------------------------------------------------------------------------- /lib/qcow_stream.mli: -------------------------------------------------------------------------------- 1 | module Header = Qcow_header 2 | module Cache = Qcow_cache 3 | open Qcow_types 4 | 5 | exception Reference_outside_file of int64 * int64 6 | 7 | val start_stream_decode : 8 | Lwt_unix.file_descr -> (int64 * int32 * int64 ref * int64 Cluster.Map.t) Lwt.t 9 | (** Decodes QCOW header and tables from the beginning of the stream, 10 | constructing a map of data clusters. 11 | Returns (virtual_size, cluster_bits, last_read_cluster, data_cluster_map) 12 | *) 13 | 14 | val copy_data : 15 | progress_cb:(int -> unit) 16 | -> int64 ref 17 | -> int32 18 | -> Lwt_unix.file_descr 19 | -> Lwt_unix.file_descr 20 | -> int64 Cluster.Map.t 21 | -> unit Lwt.t 22 | (** [copy_data last_read_cluster cluster_bits input_fd output_fd data_cluster_map] 23 | Copies data cluster-by-cluster concurrently *) 24 | 25 | val stream_decode : 26 | ?progress_cb:(int -> unit) 27 | -> ?header_info:int64 * int32 * int64 ref * int64 Cluster.Map.t 28 | -> Unix.file_descr 29 | -> string 30 | -> unit 31 | (** [stream_decode ?progress_cb ?header_info fd output_path] decodes the input 32 | QCOW stream from [fd], writing out the raw file to [output_path]. 33 | 34 | Accepts [header_info] returned by [start_stream_decode] if the header has 35 | already been parsed separately (to determine the virtual size, for example). 36 | 37 | If provided, [progress_cb] is a callback that will be called with integer 38 | percentage values representing copying progress. 39 | *) 40 | -------------------------------------------------------------------------------- /lib/qcow_types.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) 2015 David Scott 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | *) 17 | open Sexplib.Std 18 | open Qcow_error 19 | 20 | let big_enough_for name buf needed = 21 | let length = Cstruct.length buf in 22 | if length < needed then 23 | error_msg "%s: buffer too small (%d < %d)" name length needed 24 | else 25 | return () 26 | 27 | module Int8 = struct 28 | type t = int [@@deriving sexp] 29 | 30 | let sizeof _ = 1 31 | 32 | let read buf = 33 | big_enough_for "Int8.read" buf 1 >>= fun () -> 34 | return (Cstruct.get_uint8 buf 0, Cstruct.shift buf 1) 35 | 36 | let write t buf = 37 | big_enough_for "Int8.write" buf 1 >>= fun () -> 38 | Cstruct.set_uint8 buf 0 t ; 39 | return (Cstruct.shift buf 1) 40 | end 41 | 42 | module Int16 = struct 43 | type t = int [@@deriving sexp] 44 | 45 | let sizeof _ = 2 46 | 47 | let read buf = 48 | big_enough_for "Int16.read" buf 2 >>= fun () -> 49 | return (Cstruct.BE.get_uint16 buf 0, Cstruct.shift buf 2) 50 | 51 | let write t buf = 52 | big_enough_for "Int16.write" buf 2 >>= fun () -> 53 | Cstruct.BE.set_uint16 buf 0 t ; 54 | return (Cstruct.shift buf 2) 55 | end 56 | 57 | module Int32 = struct 58 | include Int32 59 | 60 | type _t = int32 [@@deriving sexp] 61 | 62 | let sexp_of_t = sexp_of__t 63 | 64 | let t_of_sexp = _t_of_sexp 65 | 66 | let sizeof _ = 4 67 | 68 | let read buf = 69 | big_enough_for "Int32.read" buf 4 >>= fun () -> 70 | return (Cstruct.BE.get_uint32 buf 0, Cstruct.shift buf 4) 71 | 72 | let write t buf = 73 | big_enough_for "Int32.read" buf 4 >>= fun () -> 74 | Cstruct.BE.set_uint32 buf 0 t ; 75 | return (Cstruct.shift buf 4) 76 | end 77 | 78 | module Int64 = Qcow_int64 79 | module Int = Qcow_int 80 | 81 | (* 82 | module Cluster = struct 83 | include Qcow_word_size.Cluster 84 | end 85 | *) 86 | module Cluster = Qcow_int64 87 | -------------------------------------------------------------------------------- /lib/qcow_types.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) 2015 David Scott 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | *) 17 | (** Parsers and printers for types used in qcow2 fields *) 18 | 19 | open Sexplib 20 | 21 | val big_enough_for : string -> Cstruct.t -> int -> unit Qcow_error.t 22 | (** [big_enough_for name buf length] returns an error with a log message 23 | if buffer [buf] is smaller than [length]. The [name] will be included 24 | in the error message. *) 25 | 26 | module Int8 : sig 27 | type t = int [@@deriving sexp] 28 | 29 | include Qcow_s.SERIALISABLE with type t := t 30 | end 31 | 32 | module Int16 : sig 33 | type t = int [@@deriving sexp] 34 | 35 | include Qcow_s.SERIALISABLE with type t := t 36 | end 37 | 38 | module Int32 : sig 39 | include module type of Int32 40 | 41 | val t_of_sexp : Sexp.t -> t 42 | 43 | val sexp_of_t : t -> Sexp.t 44 | 45 | include Qcow_s.SERIALISABLE with type t := t 46 | end 47 | 48 | module Int64 : module type of Qcow_int64 49 | 50 | module Int : module type of Qcow_int 51 | 52 | module Cluster : sig 53 | type t [@@deriving sexp] 54 | 55 | include Qcow_s.NUM with type t := t 56 | 57 | val to_float : t -> float 58 | 59 | val round_up : t -> t -> t 60 | (** [round_up value to] rounds [value] to the next multiple of [to] *) 61 | 62 | module IntervalSet : Qcow_s.INTERVAL_SET with type elt = t 63 | 64 | module Map : Map.S with type key = t 65 | end 66 | -------------------------------------------------------------------------------- /lib/qcow_virtual.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) 2015 David Scott 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | *) 17 | open Sexplib.Std 18 | 19 | (* An address in a qcow image is broken into 3 levels: *) 20 | type t = { 21 | l1_index: int64 (* index in the L1 table *) 22 | ; l2_index: int64 (* index in the L2 table *) 23 | ; cluster: int64 (* index within the cluster *) 24 | } 25 | [@@deriving sexp] 26 | 27 | let ( <| ) = Int64.shift_left 28 | 29 | let ( |> ) = Int64.shift_right_logical 30 | 31 | let make ~cluster_bits x = 32 | let l2_bits = cluster_bits - 3 in 33 | let l1_index = x |> l2_bits + cluster_bits in 34 | let l2_index = x <| 64 - l2_bits - cluster_bits |> 64 - l2_bits in 35 | let cluster = x <| 64 - cluster_bits |> 64 - cluster_bits in 36 | {l1_index; l2_index; cluster} 37 | 38 | let to_offset ~cluster_bits t = 39 | let l2_bits = cluster_bits - 3 in 40 | let l1_index = t.l1_index <| l2_bits + cluster_bits in 41 | let l2_index = t.l2_index <| cluster_bits in 42 | Int64.(logor (logor l1_index l2_index) t.cluster) 43 | 44 | let to_string t = Sexplib.Sexp.to_string (sexp_of_t t) 45 | -------------------------------------------------------------------------------- /lib/qcow_virtual.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) 2015 David Scott 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | *) 17 | 18 | (** A virtual address in a qcow image is broken into 3 levels: 19 | - an index in the L1 table, pointing to 20 | - an index in the L2 table, pointing to 21 | - a cluster within which we need an offset *) 22 | type t = { 23 | l1_index: int64 (* index in the L1 table *) 24 | ; l2_index: int64 (* index in the L2 table *) 25 | ; cluster: int64 (* index within the cluster *) 26 | } 27 | [@@deriving sexp] 28 | 29 | val make : cluster_bits:int -> int64 -> t 30 | (** [make cluster_bits byte] computes the address within the file 31 | of the virtual [byte] offset *) 32 | 33 | val to_offset : cluster_bits:int -> t -> int64 34 | (** [to_offset cluster_bits address] computes the virtual byte offset 35 | of the virtual address *) 36 | 37 | include Qcow_s.PRINTABLE with type t := t 38 | -------------------------------------------------------------------------------- /lib/qcow_word_size.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) 2017 David Scott 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | *) 17 | 18 | (** Host system word size dependent types *) 19 | 20 | module Cluster : sig 21 | type t [@@deriving sexp] 22 | 23 | include Qcow_s.NUM with type t := t 24 | 25 | val round_up : t -> t -> t 26 | (** [round_up value to] rounds [value] to the next multiple of [to] *) 27 | 28 | module IntervalSet : Qcow_s.INTERVAL_SET with type elt = t 29 | 30 | module Map : Map.S with type key = t 31 | end 32 | -------------------------------------------------------------------------------- /lib_test/compact_random.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) 2013 Citrix Inc 3 | * 4 | * Permission to use, copy, modify, and/or distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH 9 | * REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY 10 | * AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, 11 | * INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM 12 | * LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR 13 | * OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR 14 | * PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | module Lwt_error = Error.Lwt_error 17 | module Lwt_write_error = Error.Lwt_write_error 18 | module FromResult = Error.FromResult 19 | 20 | open Utils 21 | 22 | module Block = UnsafeBlock 23 | module B = Qcow.Make(Block) 24 | 25 | let debug = ref false 26 | 27 | (* Create a file which can store [nr_clusters], then randomly write and discard, 28 | checking with read whether the expected data is in each cluster. By convention 29 | we write the cluster index into each cluster so we can detect if they 30 | permute or alias. *) 31 | let random_write_discard_compact nr_clusters stop_after = 32 | (* create a large disk *) 33 | let open Lwt.Infix in 34 | let cluster_bits = 16 in (* FIXME: avoid hardcoding this *) 35 | let cluster_size = 1 lsl cluster_bits in 36 | let size = Int64.(mul nr_clusters (of_int cluster_size)) in 37 | let path = Filename.concat test_dir (Int64.to_string size) ^ ".compact" in 38 | let t = 39 | truncate path 40 | >>= fun () -> 41 | Block.connect path 42 | >>= fun block -> 43 | let keep_erased = 44 | if !B.Debug.Setting.compact_mid_write 45 | then None (* running compact mid write races with the eraser thread *) 46 | else Some 2048L in 47 | let config = B.Config.create ?keep_erased ~discard:true ~runtime_asserts:true () in 48 | B.create block ~size ~lazy_refcounts:false ~config () 49 | >>= function 50 | | Error _ -> failwith "B.create failed" 51 | | Ok qcow -> 52 | B.get_info qcow 53 | >>= fun info -> 54 | let sectors_per_cluster = cluster_size / info.Mirage_block.sector_size in 55 | let nr_sectors = Int64.(div size (of_int info.Mirage_block.sector_size)) in 56 | 57 | (* add to this set on write, remove on discard *) 58 | let module SectorSet = Qcow_diet.Make(Qcow_types.Int64) in 59 | let written = ref SectorSet.empty in 60 | let i = SectorSet.Interval.make 0L (Int64.pred info.Mirage_block.size_sectors) in 61 | let empty = ref SectorSet.(add i empty) in 62 | let nr_iterations = ref 0 in 63 | 64 | let buffer_size = 1048576 in (* perform 1MB of I/O at a time, maximum *) 65 | let buffer_size_sectors = Int64.of_int (buffer_size / info.Mirage_block.sector_size) in 66 | let write_buffer = Io_page.(to_cstruct @@ get (buffer_size / page_size)) in 67 | let read_buffer = Io_page.(to_cstruct @@ get (buffer_size / page_size)) in 68 | 69 | let write x n = 70 | assert (Int64.add x n <= nr_sectors); 71 | let one_write x n = 72 | assert (n <= buffer_size_sectors); 73 | let buf = Cstruct.sub write_buffer 0 (Int64.to_int n * info.Mirage_block.sector_size) in 74 | let rec for_each_sector x remaining = 75 | if Cstruct.length remaining = 0 then () else begin 76 | let cluster = Int64.(div x (of_int sectors_per_cluster)) in 77 | let sector = Cstruct.sub remaining 0 512 in 78 | (* Only write the first byte *) 79 | Cstruct.BE.set_uint64 sector 0 cluster; 80 | for_each_sector (Int64.succ x) (Cstruct.shift remaining 512) 81 | end in 82 | for_each_sector x buf; 83 | B.write qcow x [ buf ] 84 | >>= function 85 | | Error _ -> failwith "write" 86 | | Ok () -> Lwt.return_unit in 87 | let rec loop x n = 88 | if n = 0L then Lwt.return_unit else begin 89 | let n' = min buffer_size_sectors n in 90 | one_write x n' 91 | >>= fun () -> 92 | loop (Int64.add x n') (Int64.sub n n') 93 | end in 94 | loop x n 95 | >>= fun () -> 96 | if n > 0L then begin 97 | let y = Int64.(add x (pred n)) in 98 | let i = SectorSet.Interval.make x y in 99 | written := SectorSet.add i !written; 100 | empty := SectorSet.remove i !empty; 101 | end; 102 | Lwt.return_unit in 103 | 104 | let discard x n = 105 | assert (Int64.add x n <= nr_sectors); 106 | let y = Int64.(add x (pred n)) in 107 | B.discard qcow ~sector:x ~n () 108 | >>= function 109 | | Error _ -> failwith "discard" 110 | | Ok () -> 111 | if n > 0L then begin 112 | let i = SectorSet.Interval.make x y in 113 | written := SectorSet.remove i !written; 114 | empty := SectorSet.add i !empty; 115 | end; 116 | Lwt.return_unit in 117 | let check_contents sector buf expected = 118 | (* Only check the first byte: assume the rest of the sector are the same *) 119 | let actual = Cstruct.BE.get_uint64 buf 0 in 120 | if actual <> expected 121 | then failwith (Printf.sprintf "contents of sector %Ld incorrect: expected %Ld but actual %Ld" sector expected actual) in 122 | let check_all_clusters () = 123 | let rec check p set = match SectorSet.choose set with 124 | | i -> 125 | let x = SectorSet.Interval.x i in 126 | let y = SectorSet.Interval.y i in 127 | begin 128 | let n = Int64.(succ (sub y x)) in 129 | assert (Int64.add x n <= nr_sectors); 130 | let one_read x n = 131 | assert (n <= buffer_size_sectors); 132 | let buf = Cstruct.sub read_buffer 0 (Int64.to_int n * info.Mirage_block.sector_size) in 133 | B.read qcow x [ buf ] 134 | >>= function 135 | | Error _ -> failwith "read" 136 | | Ok () -> 137 | let rec for_each_sector x remaining = 138 | if Cstruct.length remaining = 0 then () else begin 139 | let cluster = Int64.(div x (of_int sectors_per_cluster)) in 140 | let expected = p cluster in 141 | let sector = Cstruct.sub remaining 0 512 in 142 | check_contents x sector expected; 143 | for_each_sector (Int64.succ x) (Cstruct.shift remaining 512) 144 | end in 145 | for_each_sector x buf; 146 | Lwt.return_unit in 147 | let rec loop x n = 148 | if n = 0L then Lwt.return_unit else begin 149 | let n' = min buffer_size_sectors n in 150 | one_read x n' 151 | >>= fun () -> 152 | loop (Int64.add x n') (Int64.sub n n') 153 | end in 154 | loop x n 155 | >>= fun () -> 156 | check p (SectorSet.remove i set) 157 | end 158 | | exception Not_found -> 159 | Lwt.return_unit in 160 | Lwt.pick [ 161 | check (fun _ -> 0L) !empty; 162 | Lwt_unix.sleep 30. >>= fun () -> Lwt.fail (Failure "check empty") 163 | ] 164 | >>= fun () -> 165 | Lwt.pick [ 166 | check (fun x -> x) !written; 167 | Lwt_unix.sleep 30. >>= fun () -> Lwt.fail (Failure "check written") 168 | ] in 169 | Random.init 0; 170 | let rec loop () = 171 | incr nr_iterations; 172 | B.Debug.assert_no_leaked_blocks qcow; 173 | B.Debug.assert_cluster_map_in_sync qcow 174 | >>= fun () -> 175 | if !nr_iterations = stop_after then Lwt.return (Ok ()) else begin 176 | (* Call flush so any erased blocks become reusable *) 177 | B.flush qcow 178 | >>= function 179 | | Error _ -> failwith "flush" 180 | | Ok () -> 181 | let r = Random.int 21 in 182 | (* A random action: mostly a write or a discard, occasionally a compact *) 183 | ( if 0 <= r && r < 10 then begin 184 | let sector = Random.int64 nr_sectors in 185 | let n = Random.int64 (Int64.sub nr_sectors sector) in 186 | if !debug then Printf.fprintf stderr "write %Ld %Ld\n%!" sector n; 187 | Printf.printf ".%!"; 188 | Lwt.pick [ 189 | write sector n; 190 | Lwt_unix.sleep 30. >>= fun () -> Lwt.fail (Failure "write timeout") 191 | ] 192 | end else begin 193 | let sector = Random.int64 nr_sectors in 194 | let n = Random.int64 (Int64.sub nr_sectors sector) in 195 | if !debug then Printf.fprintf stderr "discard %Ld %Ld\n%!" sector n; 196 | Printf.printf "-%!"; 197 | Lwt.pick [ 198 | discard sector n; 199 | Lwt_unix.sleep 30. >>= fun () -> Lwt.fail (Failure "discard timeout") 200 | ] 201 | end ) 202 | >>= fun () -> 203 | check_all_clusters (); 204 | >>= fun () -> 205 | loop () 206 | end in 207 | Lwt.catch loop 208 | (fun e -> 209 | Printf.fprintf stderr "Test failed on iteration # %d\n%!" !nr_iterations; 210 | Printexc.print_backtrace stderr; 211 | let s = Sexplib.Sexp.to_string_hum (SectorSet.sexp_of_t !written) in 212 | Lwt_io.open_file ~flags:[Unix.O_CREAT; Unix.O_TRUNC; Unix.O_WRONLY ] ~perm:0o644 ~mode:Lwt_io.output "/tmp/written.sexp" 213 | >>= fun oc -> 214 | Lwt_io.write oc s 215 | >>= fun () -> 216 | Lwt_io.close oc 217 | >>= fun () -> 218 | let s = Sexplib.Sexp.to_string_hum (SectorSet.sexp_of_t !empty) in 219 | Lwt_io.open_file ~flags:[Unix.O_CREAT; Unix.O_TRUNC; Unix.O_WRONLY ] ~perm:0o644 ~mode:Lwt_io.output "/tmp/empty.sexp" 220 | >>= fun oc -> 221 | Lwt_io.write oc s 222 | >>= fun () -> 223 | Lwt_io.close oc 224 | >>= fun () -> 225 | Printf.fprintf stderr ".qcow2 file is at: %s\n" path; 226 | Lwt.fail e 227 | ) in 228 | or_failwith @@ Lwt_main.run t 229 | 230 | let _ = 231 | Logs.set_reporter (Logs_fmt.reporter ()); 232 | let clusters = ref 128 in 233 | let stop_after = ref 1024 in 234 | Arg.parse [ 235 | "-clusters", Arg.Set_int clusters, Printf.sprintf "Total number of clusters (default %d)" !clusters; 236 | "-stop-after", Arg.Set_int stop_after, Printf.sprintf "Number of iterations to stop after (default: 1024, 0 means never)"; 237 | "-debug", Arg.Set debug, "enable debug"; 238 | "-compact-mid-write", Arg.Set B.Debug.Setting.compact_mid_write, "Enable the compact-mid-write debug option"; 239 | ] (fun x -> 240 | Printf.fprintf stderr "Unexpected argument: %s\n" x; 241 | exit 1 242 | ) "Perform random read/write/discard/compact operations on a qcow file"; 243 | 244 | random_write_discard_compact (Int64.of_int !clusters) (!stop_after) 245 | -------------------------------------------------------------------------------- /lib_test/dune: -------------------------------------------------------------------------------- 1 | (executables 2 | (names test compact_random) 3 | (libraries qcow io-page logs logs.fmt oUnit ezjsonm 4 | mirage-block-unix mirage-block-ramdisk mirage-block-combinators) 5 | (preprocess 6 | (pps ppx_sexp_conv))) 7 | -------------------------------------------------------------------------------- /lib_test/error.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) 2016 David Scott 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | *) 17 | open Lwt.Infix 18 | 19 | module Lwt_error = struct 20 | open Lwt.Infix 21 | module Infix = struct 22 | let ( >>= ) m f = m >>= function 23 | | Ok x -> f x 24 | | Error `Disconnected -> Lwt.fail_with "Disconnected" 25 | | Error _ -> Lwt.fail_with "Unknown error" 26 | end 27 | end 28 | 29 | module Lwt_write_error = struct 30 | module Infix = struct 31 | open Lwt.Infix 32 | let ( >>= ) m f = m >>= function 33 | | Ok x -> f x 34 | | Error `Is_read_only -> Lwt.fail_with "Is_read_only" 35 | | Error `Disconnected -> Lwt.fail_with "Disconnected" 36 | | Error _ -> Lwt.fail_with "Unknown error" 37 | end 38 | end 39 | 40 | module Infix = struct 41 | let (>>=) m f = m >>= function 42 | | Error e -> Lwt.return (Error e) 43 | | Ok x -> f x 44 | end 45 | 46 | module FromResult = struct 47 | let (>>=) m f = match m with 48 | | Result.Error x -> Lwt.return (Error x) 49 | | Result.Ok x -> f x 50 | end 51 | -------------------------------------------------------------------------------- /lib_test/error.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) 2016 David Scott 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | *) 17 | module Lwt_error: sig 18 | module Infix : sig 19 | val ( >>= ) : 20 | ('a, [> `Disconnected ]) result Lwt.t -> 21 | ('a -> 'b Lwt.t) -> 'b Lwt.t 22 | end 23 | end 24 | 25 | module Lwt_write_error: sig 26 | module Infix : sig 27 | val ( >>= ) : 28 | ('a, [> `Is_read_only | `Disconnected ]) result Lwt.t -> 29 | ('a -> 'b Lwt.t) -> 'b Lwt.t 30 | end 31 | end 32 | 33 | module Infix: sig 34 | val ( >>= ) : ('a, 'b) result Lwt.t -> 35 | ('a -> ('c, 'b) result Lwt.t) -> ('c, 'b) result Lwt.t 36 | 37 | end 38 | 39 | module FromResult: sig 40 | val ( >>= ) : 41 | ('a, 'b) result -> 42 | ('a -> ('c, 'b) result Lwt.t) -> ('c, 'b) result Lwt.t 43 | end 44 | -------------------------------------------------------------------------------- /lib_test/extent.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) 2013 Citrix Inc 3 | * 4 | * Permission to use, copy, modify, and/or distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH 9 | * REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY 10 | * AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, 11 | * INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM 12 | * LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR 13 | * OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR 14 | * PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | open Sexplib.Std 17 | open Int64 18 | 19 | type t = { 20 | start: int64; 21 | length: int64; 22 | } [@@deriving sexp] 23 | type ts = t list [@@deriving sexp] 24 | 25 | let to_string t = Sexplib.Sexp.to_string_hum (sexp_of_ts t) 26 | 27 | type overlap = 28 | | AABB 29 | | BBAA 30 | | BABA 31 | | BAAB 32 | | ABBA 33 | | ABAB 34 | [@@deriving sexp] 35 | 36 | let classify { start = a_start; length = a_length } { start = b_start; length = b_length } = 37 | let a_end = add a_start a_length in 38 | let b_end = add b_start b_length in 39 | if b_end < a_start 40 | then BBAA 41 | else if a_end < b_start 42 | then AABB 43 | else begin 44 | (* there is some overlap *) 45 | if b_start < a_start then begin 46 | if b_end < a_end then BABA else BAAB 47 | end else begin 48 | if b_end < a_end then ABBA else ABAB 49 | end 50 | end 51 | 52 | let difference ({ start = a_start; length = a_length } as a) ({ start = b_start; length = b_length } as b) = 53 | let a_end = add a_start a_length in 54 | let b_end = add b_start b_length in 55 | match classify a b with 56 | | BBAA | AABB -> [ a ] 57 | | BABA -> [ { start = b_end; length = sub a_end b_end } ] 58 | | BAAB -> [ ] 59 | | ABBA -> [ { start = a_start; length = sub b_start a_start; }; 60 | { start = b_end; length = sub a_end b_end } ] 61 | | ABAB -> [ { start = a_start; length = sub b_start a_start } ] 62 | 63 | let intersect ({ start = a_start; length = a_length } as a) ({ start = b_start; length = b_length } as b) : t list = 64 | let a_end = add a_start a_length in 65 | let b_end = add b_start b_length in 66 | match classify a b with 67 | | BBAA | AABB -> [ ] 68 | | BABA -> [ { start = a_start; length = sub b_end a_start } ] 69 | | BAAB -> [ { start = a_start; length = sub a_end a_start } ] 70 | | ABBA -> [ { start = b_start; length = sub b_end b_start } ] 71 | | ABAB -> [ { start = b_start; length = sub a_end b_start } ] 72 | -------------------------------------------------------------------------------- /lib_test/qemu.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) 2016 Unikernel Systems 3 | * 4 | * Permission to use, copy, modify, and/or distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH 9 | * REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY 10 | * AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, 11 | * INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM 12 | * LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR 13 | * OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR 14 | * PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | (* Wrappers for qemu-img, qemu-nbd to allow us to compare the contents of 18 | ocaml-qcow images and qemu-produced images. *) 19 | open Utils 20 | 21 | module Img = struct 22 | let create file size = 23 | ignore_output @@ run "qemu-img" [ "create"; "-f"; "qcow2"; "-o"; "lazy_refcounts=on"; file; Int64.to_string size ]; 24 | (* workaround for https://github.com/mirage/mirage-block-unix/issues/59 *) 25 | Lwt_main.run begin 26 | let open Lwt.Infix in 27 | Lwt_unix.LargeFile.stat file 28 | >>= fun stat -> 29 | let bytes = stat.Lwt_unix.LargeFile.st_size in 30 | let remainder = Int64.rem bytes 512L in 31 | let padding_required = if remainder = 0L then 0L else Int64.sub 512L remainder in 32 | Lwt_unix.openfile file [ Lwt_unix.O_WRONLY; Lwt_unix.O_APPEND ] 0o0 33 | >>= fun fd -> 34 | let buf = Cstruct.create (Int64.to_int padding_required) in 35 | Cstruct.memset buf 0; 36 | Lwt_cstruct.complete (Lwt_cstruct.write fd) buf 37 | >>= fun () -> 38 | Lwt_unix.close fd 39 | end 40 | 41 | let check file = 42 | ignore_output @@ run "qemu-img" [ "check"; file ] 43 | 44 | type info = { 45 | virtual_size: int64; 46 | filename: string; 47 | cluster_size: int; 48 | actual_size: int; 49 | compat: string; 50 | lazy_refcounts: bool option; 51 | refcount_bits: int option; 52 | corrupt: bool option; 53 | dirty_flag: bool; 54 | } 55 | 56 | let info file = 57 | let lines, _ = run "qemu-img" [ "info"; "--output"; "json"; file ] in 58 | let json = Ezjsonm.(get_dict @@ from_string @@ String.concat "\n" lines) in 59 | let find name json = 60 | if List.mem_assoc name json 61 | then List.assoc name json 62 | else failwith (Printf.sprintf "Failed to find '%s' in %s" name (String.concat "\n" lines)) in 63 | let virtual_size = Ezjsonm.get_int64 @@ find "virtual-size" json in 64 | let filename = Ezjsonm.get_string @@ find "filename" json in 65 | let cluster_size = Ezjsonm.get_int @@ find "cluster-size" json in 66 | let format = Ezjsonm.get_string @@ find "format" json in 67 | if format <> "qcow2" then failwith (Printf.sprintf "Expected qcow2 format, got %s" format); 68 | let actual_size = Ezjsonm.get_int @@ find "actual-size" json in 69 | let specific = Ezjsonm.get_dict @@ find "format-specific" json in 70 | let ty = Ezjsonm.get_string @@ find "type" specific in 71 | if ty <> "qcow2" then failwith (Printf.sprintf "Expected qcow2 type, got %s" ty); 72 | let data = Ezjsonm.get_dict @@ find "data" specific in 73 | let compat = Ezjsonm.get_string @@ find "compat" data in 74 | let lazy_refcounts = try Some (Ezjsonm.get_bool @@ find "lazy-refcounts" data) with _ -> None in 75 | let refcount_bits = try Some (Ezjsonm.get_int @@ find "refcount-bits" data) with _ -> None in 76 | let corrupt = try Some (Ezjsonm.get_bool @@ find "corrupt" data) with _ -> None in 77 | let dirty_flag = Ezjsonm.get_bool @@ find "dirty-flag" json in 78 | { virtual_size; filename; cluster_size; actual_size; compat; 79 | lazy_refcounts; refcount_bits; corrupt; dirty_flag } 80 | end 81 | -------------------------------------------------------------------------------- /lib_test/qemu.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) 2016 Unikernel Systems 3 | * 4 | * Permission to use, copy, modify, and/or distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH 9 | * REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY 10 | * AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, 11 | * INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM 12 | * LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR 13 | * OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR 14 | * PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | (** Wrappers for qemu-img to allow us to compare the contents of 18 | ocaml-qcow images and qemu-produced images. *) 19 | 20 | module Img: sig 21 | 22 | val create: string -> int64 -> unit 23 | (** [create path size] creates a qcow2 format image at [path] with size [size] *) 24 | 25 | val check: string -> unit 26 | (** [check path] runs "qemu-img check" on the given qcow2 image. *) 27 | 28 | type info = { 29 | virtual_size: int64; 30 | filename: string; 31 | cluster_size: int; 32 | actual_size: int; 33 | compat: string; 34 | lazy_refcounts: bool option; 35 | refcount_bits: int option; 36 | corrupt: bool option; 37 | dirty_flag: bool; 38 | } 39 | 40 | val info: string -> info 41 | (** [info path] returns metadata associated with the given qcow2 image. *) 42 | end 43 | -------------------------------------------------------------------------------- /lib_test/sizes.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) 2013 Citrix Inc 3 | * 4 | * Permission to use, copy, modify, and/or distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH 9 | * REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY 10 | * AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, 11 | * INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM 12 | * LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR 13 | * OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR 14 | * PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | let mib = Int64.mul 1024L 1024L 18 | let gib = Int64.mul mib 1024L 19 | let tib = Int64.mul gib 1024L 20 | let pib = Int64.mul tib 1024L 21 | 22 | let boundaries cluster_bits = 23 | let cluster_size = Int64.shift_left 1L cluster_bits in 24 | let pointers_in_cluster = Int64.(div cluster_size 8L) in [ 25 | "0", 0L; 26 | Printf.sprintf "one %Ld byte cluster" cluster_size, cluster_size; 27 | Printf.sprintf "one L2 table (containing %Ld 8-byte pointers to cluster)" 28 | pointers_in_cluster, 29 | Int64.(mul cluster_size pointers_in_cluster); 30 | Printf.sprintf "one L1 table (containing %Ld 8-byte pointers to L2 tables)" 31 | pointers_in_cluster, 32 | Int64.(mul (mul cluster_size pointers_in_cluster) pointers_in_cluster) 33 | ] 34 | 35 | let sizes sector_size cluster_bits = [ 36 | "one sector", Int64.of_int sector_size; 37 | "one page", 4096L; 38 | "one cluster", Int64.shift_left 1L cluster_bits; 39 | ] 40 | 41 | let off_by ((label', offset'), (label, offset)) = [ 42 | label, offset; 43 | label ^ " + " ^ label', Int64.add offset offset'; 44 | label ^ " - " ^ label', Int64.sub offset offset'; 45 | label ^ " + 2 * " ^ label', Int64.(add offset (mul 2L offset')); 46 | ] 47 | 48 | let rec cross xs ys = match xs, ys with 49 | | [], _ -> [] 50 | | x :: xs, ys -> List.map (fun y -> x, y) ys @ (cross xs ys) 51 | 52 | (* Parameterise over sector, page, cluster, more *) 53 | let interesting_ranges sector_size size_sectors cluster_bits = 54 | let size_bytes = Int64.(mul size_sectors (of_int sector_size)) in 55 | let starts = List.concat (List.map off_by (cross (sizes sector_size cluster_bits) (boundaries cluster_bits))) in 56 | let all = starts @ (List.map (fun (label, offset) -> label ^ " from the end", Int64.sub size_bytes offset) starts) in 57 | (* add lengths *) 58 | let all = List.map (fun ((label', length'), (label, offset)) -> 59 | label' ^ " @ " ^ label, offset, length' 60 | ) (cross (sizes sector_size cluster_bits) all) in 61 | List.filter 62 | (fun (_label, offset, length) -> 63 | offset >= 0L && (Int64.add offset length <= size_bytes) 64 | ) all 65 | -------------------------------------------------------------------------------- /lib_test/utils.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) 2016 Unikernel Systems 3 | * 4 | * Permission to use, copy, modify, and/or distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH 9 | * REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY 10 | * AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, 11 | * INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM 12 | * LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR 13 | * OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR 14 | * PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | let debug fmt = 18 | Printf.ksprintf (fun s -> 19 | Printf.fprintf stderr "%s\n%!" s 20 | ) fmt 21 | 22 | let read_lines oc = 23 | let rec aux acc = 24 | let line = 25 | try Some (input_line oc) 26 | with End_of_file -> None 27 | in 28 | match line with 29 | | Some l -> aux (l :: acc) 30 | | None -> List.rev acc 31 | in 32 | aux [] 33 | 34 | let or_failwith = function 35 | | Ok x -> x 36 | | Error (`Msg m) -> failwith m 37 | 38 | let ignore_output (_: (string list * string list)) = () 39 | 40 | type process = int * (in_channel * out_channel * in_channel) * string 41 | 42 | let check_exit_status cmdline = function 43 | | Unix.WEXITED 0 -> Ok () 44 | | Unix.WEXITED n -> debug "%s failed" cmdline; Error (`Msg (cmdline ^ ": " ^ (string_of_int n))) 45 | | Unix.WSIGNALED n -> debug "%s killed by signal %d" cmdline n; Error (`Msg (cmdline ^ " killed by signal %d" ^ (string_of_int n))) 46 | | Unix.WSTOPPED n -> debug "%s stopped by signal %d" cmdline n; Error (`Msg (cmdline ^ " stopped by signal %d" ^ (string_of_int n))) 47 | 48 | let start cmd args : process = 49 | let stdin_r, stdin_w = Unix.pipe () in 50 | let stdout_r, stdout_w = Unix.pipe () in 51 | let stderr_r, stderr_w = Unix.pipe () in 52 | let pid = Unix.create_process cmd (Array.of_list (cmd :: args)) stdin_r stdout_w stderr_w in 53 | Unix.close stdin_r; 54 | Unix.close stdout_w; 55 | Unix.close stderr_w; 56 | let ic = Unix.out_channel_of_descr stdin_w in 57 | let oc = Unix.in_channel_of_descr stdout_r in 58 | let ec = Unix.in_channel_of_descr stderr_r in 59 | pid, (oc, ic, ec), Printf.sprintf "%s %s" cmd (String.concat " " args) 60 | 61 | let signal (pid, _, _) s = Unix.kill pid s 62 | 63 | let wait' (pid, (oc, ic, ec), cmdline) = 64 | close_out ic; 65 | close_in oc; 66 | close_in ec; 67 | let _, exit_status = 68 | let rec loop () = 69 | try 70 | Unix.waitpid [] pid 71 | with Unix.Unix_error(Unix.EINTR, _, _) -> loop () in 72 | loop () in 73 | check_exit_status cmdline exit_status 74 | 75 | let wait (pid, (oc, ic, ec), cmdline) = 76 | or_failwith @@ wait' (pid, (oc, ic, ec), cmdline) 77 | 78 | let run cmd args = 79 | let pid, (oc, ic, ec), cmdline = start cmd args in 80 | let out = read_lines oc in 81 | let err = read_lines ec in 82 | match wait' (pid, (oc, ic, ec), cmdline) with 83 | | Ok _ -> out, err 84 | | Error (`Msg m) -> failwith (m ^ "\n" ^ (String.concat "\n" out) ^ "\n" ^ (String.concat "\n" err)) 85 | 86 | (* No need for data integrity during tests *) 87 | module UnsafeBlock = struct 88 | include Block 89 | let flush _ = Lwt.return (Ok ()) 90 | end 91 | 92 | let truncate path = 93 | let open Lwt.Infix in 94 | Lwt_unix.openfile path [ Unix.O_CREAT; Unix.O_TRUNC ] 0o0644 95 | >>= fun fd -> 96 | Lwt_unix.close fd 97 | 98 | (* Create a temporary directory for our images. We want these to be 99 | manually examinable afterwards, so we give images human-readable names *) 100 | let test_dir = 101 | (* a bit racy but if we lose, the test will simply fail *) 102 | let path = Filename.temp_file "ocaml-qcow" "" in 103 | Unix.unlink path; 104 | Unix.mkdir path 0o0755; 105 | debug "Creating temporary files in %s" path; 106 | path 107 | 108 | let malloc (length: int) = 109 | let npages = (length + 4095)/4096 in 110 | Cstruct.sub Io_page.(to_cstruct (get npages)) 0 length 111 | -------------------------------------------------------------------------------- /pkg/pkg.ml: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env ocaml 2 | 3 | #use "topfind" 4 | 5 | #require "topkg-jbuilder.auto" 6 | -------------------------------------------------------------------------------- /qcow-stream.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "Library offering QCOW streaming capabilities" 4 | maintainer: [ 5 | "Dave Scott " "Pau Ruiz Safont" "Edwin Török " 6 | ] 7 | authors: ["David Scott"] 8 | license: "ISC" 9 | tags: ["org:mirage"] 10 | homepage: "https://github.com/mirage/ocaml-qcow" 11 | bug-reports: "https://github.com/mirage/ocaml-qcow/issues" 12 | depends: [ 13 | "dune" {>= "3.18"} 14 | "qcow-types" {= version} 15 | "cstruct-lwt" 16 | "io-page" 17 | "lwt" 18 | "odoc" {with-doc} 19 | ] 20 | build: [ 21 | ["dune" "subst"] {dev} 22 | [ 23 | "dune" 24 | "build" 25 | "-p" 26 | name 27 | "-j" 28 | jobs 29 | "@install" 30 | "@runtest" {with-test} 31 | "@doc" {with-doc} 32 | ] 33 | ] 34 | dev-repo: "git+https://github.com/mirage/ocaml-qcow.git" 35 | x-maintenance-intent: ["latest"] 36 | -------------------------------------------------------------------------------- /qcow-tool.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "A command-line tool for manipulating qcow2-formatted data" 4 | maintainer: [ 5 | "Dave Scott " "Pau Ruiz Safont" "Edwin Török " 6 | ] 7 | authors: ["David Scott"] 8 | license: "ISC" 9 | tags: ["org:mirage"] 10 | homepage: "https://github.com/mirage/ocaml-qcow" 11 | bug-reports: "https://github.com/mirage/ocaml-qcow/issues" 12 | depends: [ 13 | "dune" {>= "3.18"} 14 | "ocaml" {>= "4.12.0"} 15 | "qcow" {= version} 16 | "qcow-stream" {= version} 17 | "conf-qemu-img" {with-test} 18 | "cmdliner" {>= "1.1.0"} 19 | "cstruct" 20 | "result" 21 | "unix-type-representations" 22 | "lwt" 23 | "mirage-block" {>= "3.0.0"} 24 | "sha" {>= "1.10"} 25 | "sexplib" 26 | "logs" 27 | "fmt" {>= "0.8.2"} 28 | "astring" 29 | "io-page" {>= "2.4.0"} 30 | "ounit" {with-test} 31 | "mirage-block-ramdisk" {with-test} 32 | "ezjsonm" {with-test} 33 | "odoc" {with-doc} 34 | ] 35 | build: [ 36 | ["dune" "subst"] {dev} 37 | [ 38 | "dune" 39 | "build" 40 | "-p" 41 | name 42 | "-j" 43 | jobs 44 | "@install" 45 | "@runtest" {with-test} 46 | "@doc" {with-doc} 47 | ] 48 | ] 49 | dev-repo: "git+https://github.com/mirage/ocaml-qcow.git" 50 | x-maintenance-intent: ["latest"] 51 | -------------------------------------------------------------------------------- /qcow-types.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "Minimal set of dependencies for qcow-stream, shared with qcow" 4 | maintainer: [ 5 | "Dave Scott " "Pau Ruiz Safont" "Edwin Török " 6 | ] 7 | authors: ["David Scott"] 8 | license: "ISC" 9 | tags: ["org:mirage"] 10 | homepage: "https://github.com/mirage/ocaml-qcow" 11 | bug-reports: "https://github.com/mirage/ocaml-qcow/issues" 12 | depends: [ 13 | "dune" {>= "3.18"} 14 | "ocaml" {>= "4.12.0"} 15 | "astring" 16 | "cstruct" {>= "6.1.0"} 17 | "logs" 18 | "lwt" 19 | "mirage-block" 20 | "ppx_sexp_conv" 21 | "prometheus" 22 | "sexplib" 23 | "odoc" {with-doc} 24 | ] 25 | build: [ 26 | ["dune" "subst"] {dev} 27 | [ 28 | "dune" 29 | "build" 30 | "-p" 31 | name 32 | "-j" 33 | jobs 34 | "@install" 35 | "@runtest" {with-test} 36 | "@doc" {with-doc} 37 | ] 38 | ] 39 | dev-repo: "git+https://github.com/mirage/ocaml-qcow.git" 40 | x-maintenance-intent: ["latest"] 41 | -------------------------------------------------------------------------------- /qcow.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "Support for Qcow2 images" 4 | maintainer: [ 5 | "Dave Scott " "Pau Ruiz Safont" "Edwin Török " 6 | ] 7 | authors: ["David Scott"] 8 | license: "ISC" 9 | tags: ["org:mirage"] 10 | homepage: "https://github.com/mirage/ocaml-qcow" 11 | bug-reports: "https://github.com/mirage/ocaml-qcow/issues" 12 | depends: [ 13 | "dune" {>= "3.18"} 14 | "ocaml" {>= "4.12.0"} 15 | "qcow-types" {= version} 16 | "base-bytes" 17 | "cstruct" {>= "3.4.0"} 18 | "result" 19 | "io-page" {>= "2.4.0"} 20 | "lwt" {>= "5.5.0"} 21 | "mirage-block" {>= "3.0.0"} 22 | "mirage-block-unix" {>= "2.5.0"} 23 | "mirage-block-combinators" 24 | "mirage-sleep" 25 | "sexplib" 26 | "logs" 27 | "fmt" {>= "0.8.2"} 28 | "astring" 29 | "prometheus" 30 | "unix-type-representations" 31 | "stdlib-shims" 32 | "sha" 33 | "ppx_deriving" 34 | "ppx_sexp_conv" 35 | "ounit" {with-test} 36 | "mirage-block-ramdisk" {with-test & >= "0.5"} 37 | "ezjsonm" {with-test} 38 | "odoc" {with-doc} 39 | ] 40 | build: [ 41 | ["dune" "subst"] {dev} 42 | [ 43 | "dune" 44 | "build" 45 | "-p" 46 | name 47 | "-j" 48 | jobs 49 | "@install" 50 | "@runtest" {with-test} 51 | "@doc" {with-doc} 52 | ] 53 | ] 54 | dev-repo: "git+https://github.com/mirage/ocaml-qcow.git" 55 | x-maintenance-intent: ["latest"] 56 | --------------------------------------------------------------------------------