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 option, 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 option = ref "" in
49 let quiet = ref false in
50 let verbose = ref false in
51 let trace = ref false in
53 let argspec = Arg.align [
54 "--compress", Arg.Set compress, " Compressed output format";
55 "--convert", Arg.Set_string convert, "format Format of output disk (default: same as input)";
56 "--format", Arg.Set_string format, "format Format of input disk";
57 "--ignore", Arg.String (add ignores), "fs Ignore filesystem";
58 "--machine-readable", Arg.Set machine_readable, " Make output machine readable";
59 "-o", Arg.Set_string option, "option Add qemu-img options";
60 "-q", Arg.Set quiet, " Quiet output";
61 "--quiet", Arg.Set quiet, " -\"-";
62 "-v", Arg.Set verbose, " Enable debugging messages";
63 "--verbose", Arg.Set verbose, " -\"-";
64 "-V", Arg.Unit display_version, " Display version and exit";
65 "--version", Arg.Unit display_version, " -\"-";
66 "-x", Arg.Set trace, " Enable tracing of libguestfs calls";
69 let anon_fun s = disks := s :: !disks in
72 %s: sparsify a virtual machine disk
74 virt-sparsify [--options] indisk outdisk
76 A short summary of the options is given below. For detailed help please
77 read the man page virt-sparsify(1).
80 Arg.parse argspec anon_fun usage_msg;
82 (* Dereference the rest of the args. *)
83 let compress = !compress in
84 let convert = match !convert with "" -> None | str -> Some str in
85 let format = match !format with "" -> None | str -> Some str in
86 let ignores = List.rev !ignores in
87 let machine_readable = !machine_readable in
88 let option = match !option with "" -> None | str -> Some str in
90 let verbose = !verbose in
93 (* No arguments and machine-readable mode? Print out some facts
94 * about what this binary supports.
96 if !disks = [] && machine_readable then (
97 printf "virt-sparsify\n";
98 let g = new G.guestfs () in
99 g#add_drive_opts "/dev/null";
101 if feature_available g [| "ntfsprogs"; "ntfs3g" |] then
103 if feature_available g [| "btrfs" |] then
108 (* Verify we got exactly 2 disks. *)
109 let indisk, outdisk =
110 match List.rev !disks with
111 | [indisk; outdisk] -> indisk, outdisk
113 error "usage is: %s [--options] indisk outdisk" prog in
115 (* The input disk must be an absolute path, so we can store the name
116 * in the overlay disk.
119 if not (Filename.is_relative indisk) then
122 Sys.getcwd () // indisk in
124 (* Check indisk filename doesn't contain a comma (limitation of qemu-img). *)
126 try ignore (String.index indisk ','); true
127 with Not_found -> false in
128 if contains_comma then
129 error "input filename '%s' contains a comma; qemu-img command line syntax prevents us from using such an image" indisk;
131 indisk, outdisk, compress, convert, format, ignores, machine_readable,
132 option, quiet, verbose, trace
136 printf "Create overlay file to protect source disk ...\n%!"
138 (* Create the temporary overlay file. *)
140 let tmp = Filename.temp_file "sparsify" ".qcow2" in
142 (* Unlink on exit. *)
143 at_exit (fun () -> try unlink tmp with _ -> ());
145 (* Create it with the indisk as the backing file. *)
147 sprintf "qemu-img create -f qcow2 -o backing_file=%s%s %s > /dev/null"
148 (Filename.quote indisk)
151 | Some fmt -> sprintf ",backing_fmt=%s" (Filename.quote fmt))
152 (Filename.quote tmp) in
155 if Sys.command cmd <> 0 then
156 error "external command failed: %s" cmd;
162 printf "Examine source disk ...\n%!"
164 (* Connect to libguestfs. *)
166 let g = new G.guestfs () in
167 if trace then g#set_trace true;
168 if verbose then g#set_verbose true;
170 (* Note that the temporary overlay disk is always qcow2 format. *)
171 g#add_drive_opts ~format:"qcow2" ~readonly:false overlaydisk;
173 if not quiet then Progress.set_up_progress_bar ~machine_readable g;
178 (* Get the size in bytes of the input disk. *)
179 let insize = g#blockdev_getsize64 "/dev/sda"
181 (* Write zeroes for non-ignored filesystems that we are able to mount. *)
183 let filesystems = g#list_filesystems () in
184 let filesystems = List.map fst filesystems in
185 let filesystems = List.sort compare filesystems in
188 let fs = canonicalize fs in
189 List.exists (fun fs' -> fs = canonicalize fs') ignores
194 if not (is_ignored fs) then (
196 try g#mount_options "" fs "/"; true
201 printf "Fill free space in %s with zero ...\n%!" fs;
203 (* Choose a random filename, just letters and numbers, in
204 * 8.3 format. This ought to be compatible with any
205 * filesystem and not clash with existing files.
207 let filename = "/" ^ string_random8 () ^ ".tmp" in
209 (* This command is expected to fail. *)
210 (try g#dd "/dev/zero" filename with _ -> ());
212 (* Make sure the last part of the file is written to disk. *)
222 (* Fill unused space in volume groups. *)
224 let vgs = g#vgs () in
225 let vgs = Array.to_list vgs in
226 let vgs = List.sort compare vgs in
229 if not (List.mem vg ignores) then (
230 let lvname = string_random8 () in
231 let lvdev = "/dev/" ^ vg ^ "/" ^ lvname in
234 try g#lvcreate lvname vg 32; true
239 printf "Fill free space in volgroup %s with zero ...\n%!" vg;
241 (* XXX Don't have lvcreate -l 100%FREE. Fake it. *)
242 g#lvresize_free lvdev 100;
244 (* This command is expected to fail. *)
245 (try g#dd "/dev/zero" lvdev with _ -> ());
253 (* Don't need libguestfs now. *)
257 (* What should the output format be? If the user specified an
258 * input format, use that, else detect it from the source image.
262 | Some fmt -> fmt (* user specified output conversion *)
265 | Some fmt -> fmt (* user specified input format, use that *)
267 (* Don't know, so we must autodetect. *)
268 let cmd = sprintf "file -bsL %s" (Filename.quote indisk) in
269 let chan = open_process_in cmd in
270 let line = input_line chan in
271 let stat = close_process_in chan in
275 error "external command failed: %s" cmd
277 error "external command '%s' killed by signal %d" cmd i
279 error "external command '%s' stopped by signal %d" cmd i
281 if string_prefix line "QEMU QCOW Image (v2)" then
283 else if string_find line "VirtualBox" >= 0 then
286 "raw" (* XXX guess *)
288 (* Now run qemu-img convert which copies the overlay to the
289 * destination and automatically does sparsification.
293 printf "Copy to destination and make sparse ...\n%!";
296 sprintf "qemu-img convert -f qcow2 -O %s%s%s %s %s"
297 (Filename.quote output_format)
298 (if compress then " -c" else "")
301 | Some option -> " -o " ^ Filename.quote option)
302 (Filename.quote overlaydisk) (Filename.quote outdisk) in
305 if Sys.command cmd <> 0 then
306 error "external command failed: %s" cmd
312 wrap "Sparsify operation completed with no errors. Before deleting the old disk, carefully check that the target disk boots and works correctly.\n";