2 * Copyright (C) 2011 Red Hat Inc.
4 * This program is free software; you can redistribute it and/or modify
5 * it under the terms of the GNU General Public License as published by
6 * the Free Software Foundation; either version 2 of the License, or
7 * (at your option) any later version.
9 * This program is distributed in the hope that it will be useful,
10 * but WITHOUT ANY WARRANTY; without even the implied warranty of
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12 * GNU General Public License for more details.
14 * You should have received a copy of the GNU General Public License along
15 * with this program; if not, write to the Free Software Foundation, Inc.,
16 * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
26 let () = Random.self_init ()
28 (* Command line argument parsing. *)
29 let prog = Filename.basename Sys.executable_name
31 let indisk, outdisk, compress, convert, format, ignores, machine_readable,
32 quiet, verbose, trace =
33 let display_version () =
34 let g = new G.guestfs () in
35 let version = g#version () in
36 printf "virt-sparsify %Ld.%Ld.%Ld%s\n"
37 version.G.major version.G.minor version.G.release version.G.extra;
41 let add xs s = xs := s :: !xs in
43 let compress = ref false in
44 let convert = ref "" in
45 let format = ref "" in
46 let ignores = ref [] in
47 let machine_readable = ref false in
48 let quiet = ref false in
49 let verbose = ref false in
50 let trace = ref false in
52 let argspec = Arg.align [
53 "--compress", Arg.Set compress, " Compressed output format";
54 "--convert", Arg.Set_string convert, "format Format of output disk (default: same as input)";
55 "--format", Arg.Set_string format, "format Format of input disk";
56 "--ignore", Arg.String (add ignores), "fs Ignore filesystem";
57 "--machine-readable", Arg.Set machine_readable, " Make output machine readable";
58 "-q", Arg.Set quiet, " Quiet output";
59 "--quiet", Arg.Set quiet, " -\"-";
60 "-v", Arg.Set verbose, " Enable debugging messages";
61 "--verbose", Arg.Set verbose, " -\"-";
62 "-V", Arg.Unit display_version, " Display version and exit";
63 "--version", Arg.Unit display_version, " -\"-";
64 "-x", Arg.Set trace, " Enable tracing of libguestfs calls";
67 let anon_fun s = disks := s :: !disks in
70 %s: sparsify a virtual machine disk
72 virt-sparsify [--options] indisk outdisk
74 A short summary of the options is given below. For detailed help please
75 read the man page virt-sparsify(1).
78 Arg.parse argspec anon_fun usage_msg;
80 (* Dereference the rest of the args. *)
81 let compress = !compress in
82 let convert = match !convert with "" -> None | str -> Some str in
83 let format = match !format with "" -> None | str -> Some str in
84 let ignores = List.rev !ignores in
85 let machine_readable = !machine_readable in
87 let verbose = !verbose in
90 (* No arguments and machine-readable mode? Print out some facts
91 * about what this binary supports.
93 if !disks = [] && machine_readable then (
94 printf "virt-sparsify\n";
95 let g = new G.guestfs () in
96 g#add_drive_opts "/dev/null";
98 if feature_available g [| "ntfsprogs"; "ntfs3g" |] then
100 if feature_available g [| "btrfs" |] then
105 (* Verify we got exactly 2 disks. *)
106 let indisk, outdisk =
107 match List.rev !disks with
108 | [indisk; outdisk] -> indisk, outdisk
110 error "usage is: %s [--options] indisk outdisk" prog in
112 (* The input disk must be an absolute path, so we can store the name
113 * in the overlay disk.
116 if not (Filename.is_relative indisk) then
119 Sys.getcwd () // indisk in
121 (* Check indisk filename doesn't contain a comma (limitation of qemu-img). *)
123 try ignore (String.index indisk ','); true
124 with Not_found -> false in
125 if contains_comma then
126 error "input filename '%s' contains a comma; qemu-img command line syntax prevents us from using such an image" indisk;
128 indisk, outdisk, compress, convert, format, ignores, machine_readable,
129 quiet, verbose, trace
133 printf "Create overlay file to protect source disk ...\n%!"
135 (* Create the temporary overlay file. *)
137 let tmp = Filename.temp_file "sparsify" ".qcow2" in
139 (* Unlink on exit. *)
140 at_exit (fun () -> try unlink tmp with _ -> ());
142 (* Create it with the indisk as the backing file. *)
144 sprintf "qemu-img create -f qcow2 -o backing_file=%s%s %s > /dev/null"
145 (Filename.quote indisk)
148 | Some fmt -> sprintf ",backing_fmt=%s" (Filename.quote fmt))
149 (Filename.quote tmp) in
152 if Sys.command cmd <> 0 then
153 error "external command failed: %s" cmd;
159 printf "Examine source disk ...\n%!"
161 (* Connect to libguestfs. *)
163 let g = new G.guestfs () in
164 if trace then g#set_trace true;
165 if verbose then g#set_verbose true;
167 (* Note that the temporary overlay disk is always qcow2 format. *)
168 g#add_drive_opts ~format:"qcow2" ~readonly:false overlaydisk;
170 if not quiet then Progress.set_up_progress_bar ~machine_readable g;
175 (* Get the size in bytes of the input disk. *)
176 let insize = g#blockdev_getsize64 "/dev/sda"
178 (* Write zeroes for non-ignored filesystems that we are able to mount. *)
180 let filesystems = g#list_filesystems () in
181 let filesystems = List.map fst filesystems in
182 let filesystems = List.sort compare filesystems in
185 let fs = canonicalize fs in
186 List.exists (fun fs' -> fs = canonicalize fs') ignores
191 if not (is_ignored fs) then (
193 try g#mount_options "" fs "/"; true
198 printf "Fill free space in %s with zero ...\n%!" fs;
200 (* Choose a random filename, just letters and numbers, in
201 * 8.3 format. This ought to be compatible with any
202 * filesystem and not clash with existing files.
204 let filename = "/" ^ string_random8 () ^ ".tmp" in
206 (* This command is expected to fail. *)
207 (try g#dd "/dev/zero" filename with _ -> ());
209 (* Make sure the last part of the file is written to disk. *)
219 (* Fill unused space in volume groups. *)
221 let vgs = g#vgs () in
222 let vgs = Array.to_list vgs in
223 let vgs = List.sort compare vgs in
226 if not (List.mem vg ignores) then (
227 let lvname = string_random8 () in
228 let lvdev = "/dev/" ^ vg ^ "/" ^ lvname in
231 try g#lvcreate lvname vg 32; true
236 printf "Fill free space in volgroup %s with zero ...\n%!" vg;
238 (* XXX Don't have lvcreate -l 100%FREE. Fake it. *)
239 g#lvresize_free lvdev 100;
241 (* This command is expected to fail. *)
242 (try g#dd "/dev/zero" lvdev with _ -> ());
250 (* Don't need libguestfs now. *)
254 (* What should the output format be? If the user specified an
255 * input format, use that, else detect it from the source image.
259 | Some fmt -> fmt (* user specified output conversion *)
262 | Some fmt -> fmt (* user specified input format, use that *)
264 (* Don't know, so we must autodetect. *)
265 let cmd = sprintf "file -bsL %s" (Filename.quote indisk) in
266 let chan = open_process_in cmd in
267 let line = input_line chan in
268 let stat = close_process_in chan in
272 error "external command failed: %s" cmd
274 error "external command '%s' killed by signal %d" cmd i
276 error "external command '%s' stopped by signal %d" cmd i
278 if string_prefix line "QEMU QCOW Image (v2)" then
280 else if string_find line "VirtualBox" >= 0 then
283 "raw" (* XXX guess *)
285 (* Now run qemu-img convert which copies the overlay to the
286 * destination and automatically does sparsification.
290 printf "Copy to destination and make sparse ...\n%!";
293 sprintf "qemu-img convert -f qcow2 -O %s%s %s %s"
294 (Filename.quote output_format)
295 (if compress then " -c" else "")
296 (Filename.quote overlaydisk) (Filename.quote outdisk) in
299 if Sys.command cmd <> 0 then
300 error "external command failed: %s" cmd
306 wrap "Sparsify operation completed with no errors. Before deleting the old disk, carefully check that the target disk boots and works correctly.\n";