sparsify/sparsify.ml

   1 (* virt-sparsify
   2  * Copyright (C) 2011 Red Hat Inc.
   3  *
   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.
   8  *
   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.
  13  *
  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.
  17  *)
  18
  19 open Unix
  20 open Printf
  21
  22 module G = Guestfs
  23
  24 open Utils
  25
  26 let () = Random.self_init ()
  27
  28 (* Command line argument parsing. *)
  29 let prog = Filename.basename Sys.executable_name
  30
  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;
  39     exit 0
  40   in
  41
  42   let add xs s = xs := s :: !xs in
  43
  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
  54
  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";
  70   ] in
  71   let disks = ref [] in
  72   let anon_fun s = disks := s :: !disks in
  73   let usage_msg =
  74     sprintf "\
  75 %s: sparsify a virtual machine disk
  76
  77  virt-sparsify [--options] indisk outdisk
  78
  79 A short summary of the options is given below.  For detailed help please
  80 read the man page virt-sparsify(1).
  81 "
  82       prog in
  83   Arg.parse argspec anon_fun usage_msg;
  84
  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
  93   let quiet = !quiet in
  94   let verbose = !verbose in
  95   let trace = !trace in
  96
  97   (* No arguments and machine-readable mode?  Print out some facts
  98    * about what this binary supports.
  99    *)
 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";
 104     g#launch ();
 105     if feature_available g [| "ntfsprogs"; "ntfs3g" |] then
 106       printf "ntfs\n";
 107     if feature_available g [| "btrfs" |] then
 108       printf "btrfs\n";
 109     exit 0
 110   );
 111
 112   (* Verify we got exactly 2 disks. *)
 113   let indisk, outdisk =
 114     match List.rev !disks with
 115     | [indisk; outdisk] -> indisk, outdisk
 116     | _ ->
 117         error "usage is: %s [--options] indisk outdisk" prog in
 118
 119   (* The input disk must be an absolute path, so we can store the name
 120    * in the overlay disk.
 121    *)
 122   let indisk =
 123     if not (Filename.is_relative indisk) then
 124       indisk
 125     else
 126       Sys.getcwd () // indisk in
 127
 128   (* Check indisk filename doesn't contain a comma (limitation of qemu-img). *)
 129   let contains_comma =
 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;
 134
 135   indisk, outdisk, compress, convert,
 136     debug_gc, format, ignores, machine_readable,
 137     option, quiet, verbose, trace
 138
 139 let () =
 140   if not quiet then
 141     printf "Create overlay file to protect source disk ...\n%!"
 142
 143 (* Create the temporary overlay file. *)
 144 let overlaydisk =
 145   let tmp = Filename.temp_file "sparsify" ".qcow2" in
 146
 147   (* Unlink on exit. *)
 148   at_exit (fun () -> try unlink tmp with _ -> ());
 149
 150   (* Create it with the indisk as the backing file. *)
 151   let cmd =
 152     sprintf "qemu-img create -f qcow2 -o backing_file=%s%s %s > /dev/null"
 153       (Filename.quote indisk)
 154       (match format with
 155       | None -> ""
 156       | Some fmt -> sprintf ",backing_fmt=%s" (Filename.quote fmt))
 157       (Filename.quote tmp) in
 158   if verbose then
 159     printf "%s\n%!" cmd;
 160   if Sys.command cmd <> 0 then
 161     error "external command failed: %s" cmd;
 162
 163   tmp
 164
 165 let () =
 166   if not quiet then
 167     printf "Examine source disk ...\n%!"
 168
 169 (* Connect to libguestfs. *)
 170 let g =
 171   let g = new G.guestfs () in
 172   if trace then g#set_trace true;
 173   if verbose then g#set_verbose true;
 174
 175   (* Note that the temporary overlay disk is always qcow2 format. *)
 176   g#add_drive_opts ~format:"qcow2" ~readonly:false overlaydisk;
 177
 178   if not quiet then Progress.set_up_progress_bar ~machine_readable g;
 179   g#launch ();
 180
 181   g
 182
 183 (* Get the size in bytes of the input disk. *)
 184 let insize = g#blockdev_getsize64 "/dev/sda"
 185
 186 (* Write zeroes for non-ignored filesystems that we are able to mount. *)
 187 let () =
 188   let filesystems = g#list_filesystems () in
 189   let filesystems = List.map fst filesystems in
 190   let filesystems = List.sort compare filesystems in
 191
 192   let is_ignored fs =
 193     let fs = canonicalize fs in
 194     List.exists (fun fs' -> fs = canonicalize fs') ignores
 195   in
 196
 197   List.iter (
 198     fun fs ->
 199       if not (is_ignored fs) then (
 200         let mounted =
 201           try g#mount_options "" fs "/"; true
 202           with _ -> false in
 203
 204         if mounted then (
 205           if not quiet then
 206             printf "Fill free space in %s with zero ...\n%!" fs;
 207
 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.
 211            *)
 212           let filename = "/" ^ string_random8 () ^ ".tmp" in
 213
 214           (* This command is expected to fail. *)
 215           (try g#dd "/dev/zero" filename with _ -> ());
 216
 217           (* Make sure the last part of the file is written to disk. *)
 218           g#sync ();
 219
 220           g#rm filename
 221         );
 222
 223         g#umount_all ()
 224       )
 225   ) filesystems
 226
 227 (* Fill unused space in volume groups. *)
 228 let () =
 229   let vgs = g#vgs () in
 230   let vgs = Array.to_list vgs in
 231   let vgs = List.sort compare vgs in
 232   List.iter (
 233     fun vg ->
 234       if not (List.mem vg ignores) then (
 235         let lvname = string_random8 () in
 236         let lvdev = "/dev/" ^ vg ^ "/" ^ lvname in
 237
 238         let created =
 239           try g#lvcreate lvname vg 32; true
 240           with _ -> false in
 241
 242         if created then (
 243           if not quiet then
 244             printf "Fill free space in volgroup %s with zero ...\n%!" vg;
 245
 246           (* XXX Don't have lvcreate -l 100%FREE.  Fake it. *)
 247           g#lvresize_free lvdev 100;
 248
 249           (* This command is expected to fail. *)
 250           (try g#dd "/dev/zero" lvdev with _ -> ());
 251
 252            g#sync ();
 253            g#lvremove lvdev
 254         )
 255       )
 256   ) vgs
 257
 258 (* Don't need libguestfs now. *)
 259 let () =
 260   g#close ()
 261
 262 (* What should the output format be?  If the user specified an
 263  * input format, use that, else detect it from the source image.
 264  *)
 265 let output_format =
 266   match convert with
 267   | Some fmt -> fmt             (* user specified output conversion *)
 268   | None ->
 269     match format with
 270     | Some fmt -> fmt           (* user specified input format, use that *)
 271     | None ->
 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
 277       (match stat with
 278       | WEXITED 0 -> ()
 279       | WEXITED _ ->
 280         error "external command failed: %s" cmd
 281       | WSIGNALED i ->
 282         error "external command '%s' killed by signal %d" cmd i
 283       | WSTOPPED i ->
 284         error "external command '%s' stopped by signal %d" cmd i
 285       );
 286       if string_prefix line "QEMU QCOW Image (v2)" then
 287         "qcow2"
 288       else if string_find line "VirtualBox" >= 0 then
 289         "vdi"
 290       else
 291         "raw" (* XXX guess *)
 292
 293 (* Now run qemu-img convert which copies the overlay to the
 294  * destination and automatically does sparsification.
 295  *)
 296 let () =
 297   if not quiet then
 298     printf "Copy to destination and make sparse ...\n%!";
 299
 300   let cmd =
 301     sprintf "qemu-img convert -f qcow2 -O %s%s%s %s %s"
 302       (Filename.quote output_format)
 303       (if compress then " -c" else "")
 304       (match option with
 305       | None -> ""
 306       | Some option -> " -o " ^ Filename.quote option)
 307       (Filename.quote overlaydisk) (Filename.quote outdisk) in
 308 (*  if verbose then*)
 309     printf "%s\n%!" cmd;
 310   if Sys.command cmd <> 0 then
 311     error "external command failed: %s" cmd
 312
 313 (* Finished. *)
 314 let () =
 315   if not quiet then (
 316     print_newline ();
 317     wrap "Sparsify operation completed with no errors.  Before deleting the old disk, carefully check that the target disk boots and works correctly.\n";
 318   );
 319
 320   if debug_gc then
 321     Gc.compact ();
 322
 323   exit 0