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, debug_gc,
32 format, ignores, machine_readable,
33 option, quiet, verbose, trace =
34 let display_version () =
35 let g = new G.guestfs () in
36 let version = g#version () in
37 printf "virt-sparsify %Ld.%Ld.%Ld%s\n"
38 version.G.major version.G.minor version.G.release version.G.extra;
42 let add xs s = xs := s :: !xs in
44 let compress = ref false in
45 let convert = ref "" in
46 let debug_gc = ref false in
47 let format = ref "" in
48 let ignores = ref [] in
49 let machine_readable = ref false in
50 let option = ref "" in
51 let quiet = ref false in
52 let verbose = ref false in
53 let trace = ref false in
55 let argspec = Arg.align [
56 "--compress", Arg.Set compress, " Compressed output format";
57 "--convert", Arg.Set_string convert, "format Format of output disk (default: same as input)";
58 "--debug-gc", Arg.Set debug_gc, " Debug GC and memory allocations";
59 "--format", Arg.Set_string format, "format Format of input disk";
60 "--ignore", Arg.String (add ignores), "fs Ignore filesystem";
61 "--machine-readable", Arg.Set machine_readable, " Make output machine readable";
62 "-o", Arg.Set_string option, "option Add qemu-img options";
63 "-q", Arg.Set quiet, " Quiet output";
64 "--quiet", Arg.Set quiet, " -\"-";
65 "-v", Arg.Set verbose, " Enable debugging messages";
66 "--verbose", Arg.Set verbose, " -\"-";
67 "-V", Arg.Unit display_version, " Display version and exit";
68 "--version", Arg.Unit display_version, " -\"-";
69 "-x", Arg.Set trace, " Enable tracing of libguestfs calls";
72 let anon_fun s = disks := s :: !disks in
75 %s: sparsify a virtual machine disk
77 virt-sparsify [--options] indisk outdisk
79 A short summary of the options is given below. For detailed help please
80 read the man page virt-sparsify(1).
83 Arg.parse argspec anon_fun usage_msg;
85 (* Dereference the rest of the args. *)
86 let compress = !compress in
87 let convert = match !convert with "" -> None | str -> Some str in
88 let debug_gc = !debug_gc in
89 let format = match !format with "" -> None | str -> Some str in
90 let ignores = List.rev !ignores in
91 let machine_readable = !machine_readable in
92 let option = match !option with "" -> None | str -> Some str in
94 let verbose = !verbose in
97 (* No arguments and machine-readable mode? Print out some facts
98 * about what this binary supports.
100 if !disks = [] && machine_readable then (
101 printf "virt-sparsify\n";
102 let g = new G.guestfs () in
103 g#add_drive_opts "/dev/null";
105 if feature_available g [| "ntfsprogs"; "ntfs3g" |] then
107 if feature_available g [| "btrfs" |] then
112 (* Verify we got exactly 2 disks. *)
113 let indisk, outdisk =
114 match List.rev !disks with
115 | [indisk; outdisk] -> indisk, outdisk
117 error "usage is: %s [--options] indisk outdisk" prog in
119 (* The input disk must be an absolute path, so we can store the name
120 * in the overlay disk.
123 if not (Filename.is_relative indisk) then
126 Sys.getcwd () // indisk in
128 (* Check indisk filename doesn't contain a comma (limitation of qemu-img). *)
130 try ignore (String.index indisk ','); true
131 with Not_found -> false in
132 if contains_comma then
133 error "input filename '%s' contains a comma; qemu-img command line syntax prevents us from using such an image" indisk;
135 indisk, outdisk, compress, convert,
136 debug_gc, format, ignores, machine_readable,
137 option, quiet, verbose, trace
141 printf "Create overlay file to protect source disk ...\n%!"
143 (* Create the temporary overlay file. *)
145 let tmp = Filename.temp_file "sparsify" ".qcow2" in
147 (* Unlink on exit. *)
148 at_exit (fun () -> try unlink tmp with _ -> ());
150 (* Create it with the indisk as the backing file. *)
152 sprintf "qemu-img create -f qcow2 -o backing_file=%s%s %s > /dev/null"
153 (Filename.quote indisk)
156 | Some fmt -> sprintf ",backing_fmt=%s" (Filename.quote fmt))
157 (Filename.quote tmp) in
160 if Sys.command cmd <> 0 then
161 error "external command failed: %s" cmd;
167 printf "Examine source disk ...\n%!"
169 (* Connect to libguestfs. *)
171 let g = new G.guestfs () in
172 if trace then g#set_trace true;
173 if verbose then g#set_verbose true;
175 (* Note that the temporary overlay disk is always qcow2 format. *)
176 g#add_drive_opts ~format:"qcow2" ~readonly:false overlaydisk;
178 if not quiet then Progress.set_up_progress_bar ~machine_readable g;
183 (* Get the size in bytes of the input disk. *)
184 let insize = g#blockdev_getsize64 "/dev/sda"
186 (* Write zeroes for non-ignored filesystems that we are able to mount. *)
188 let filesystems = g#list_filesystems () in
189 let filesystems = List.map fst filesystems in
190 let filesystems = List.sort compare filesystems in
193 let fs = canonicalize fs in
194 List.exists (fun fs' -> fs = canonicalize fs') ignores
199 if not (is_ignored fs) then (
201 try g#mount_options "" fs "/"; true
206 printf "Fill free space in %s with zero ...\n%!" fs;
208 (* Choose a random filename, just letters and numbers, in
209 * 8.3 format. This ought to be compatible with any
210 * filesystem and not clash with existing files.
212 let filename = "/" ^ string_random8 () ^ ".tmp" in
214 (* This command is expected to fail. *)
215 (try g#dd "/dev/zero" filename with _ -> ());
217 (* Make sure the last part of the file is written to disk. *)
227 (* Fill unused space in volume groups. *)
229 let vgs = g#vgs () in
230 let vgs = Array.to_list vgs in
231 let vgs = List.sort compare vgs in
234 if not (List.mem vg ignores) then (
235 let lvname = string_random8 () in
236 let lvdev = "/dev/" ^ vg ^ "/" ^ lvname in
239 try g#lvcreate lvname vg 32; true
244 printf "Fill free space in volgroup %s with zero ...\n%!" vg;
246 (* XXX Don't have lvcreate -l 100%FREE. Fake it. *)
247 g#lvresize_free lvdev 100;
249 (* This command is expected to fail. *)
250 (try g#dd "/dev/zero" lvdev with _ -> ());
258 (* Don't need libguestfs now. *)
262 (* What should the output format be? If the user specified an
263 * input format, use that, else detect it from the source image.
267 | Some fmt -> fmt (* user specified output conversion *)
270 | Some fmt -> fmt (* user specified input format, use that *)
272 (* Don't know, so we must autodetect. *)
273 let cmd = sprintf "file -bsL %s" (Filename.quote indisk) in
274 let chan = open_process_in cmd in
275 let line = input_line chan in
276 let stat = close_process_in chan in
280 error "external command failed: %s" cmd
282 error "external command '%s' killed by signal %d" cmd i
284 error "external command '%s' stopped by signal %d" cmd i
286 if string_prefix line "QEMU QCOW Image (v2)" then
288 else if string_find line "VirtualBox" >= 0 then
291 "raw" (* XXX guess *)
293 (* Now run qemu-img convert which copies the overlay to the
294 * destination and automatically does sparsification.
298 printf "Copy to destination and make sparse ...\n%!";
301 sprintf "qemu-img convert -f qcow2 -O %s%s%s %s %s"
302 (Filename.quote output_format)
303 (if compress then " -c" else "")
306 | Some option -> " -o " ^ Filename.quote option)
307 (Filename.quote overlaydisk) (Filename.quote outdisk) in
310 if Sys.command cmd <> 0 then
311 error "external command failed: %s" cmd
317 wrap "Sparsify operation completed with no errors. Before deleting the old disk, carefully check that the target disk boots and works correctly.\n";