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, convert, debug_gc,
  32   format, ignores, machine_readable, quiet,
  33   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 convert = ref "" in
  45   let debug_gc = ref false in
  46   let format = ref "" in
  47   let ignores = ref [] in
  48   let machine_readable = ref false in
  49   let quiet = ref false in
  50   let verbose = ref false in
  51   let trace = ref false in
  52
  53   let argspec = Arg.align [
  54     "--convert", Arg.Set_string convert,    "format Format of output disk (default: same as input)";
  55     "--debug-gc", Arg.Set debug_gc,         " Debug GC and memory allocations";
  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     "-q",        Arg.Set quiet,             " Quiet output";
  60     "--quiet",   Arg.Set quiet,             " -\"-";
  61     "-v",        Arg.Set verbose,           " Enable debugging messages";
  62     "--verbose", Arg.Set verbose,           " -\"-";
  63     "-V",        Arg.Unit display_version,  " Display version and exit";
  64     "--version", Arg.Unit display_version,  " -\"-";
  65     "-x",        Arg.Set trace,             " Enable tracing of libguestfs calls";
  66   ] in
  67   let disks = ref [] in
  68   let anon_fun s = disks := s :: !disks in
  69   let usage_msg =
  70     sprintf "\
  71 %s: sparsify a virtual machine disk
  72
  73  virt-sparsify [--options] indisk outdisk
  74
  75 A short summary of the options is given below.  For detailed help please
  76 read the man page virt-sparsify(1).
  77 "
  78       prog in
  79   Arg.parse argspec anon_fun usage_msg;
  80
  81   (* Dereference the rest of the args. *)
  82   let convert = match !convert with "" -> None | str -> Some str in
  83   let debug_gc = !debug_gc in
  84   let format = match !format with "" -> None | str -> Some str in
  85   let ignores = List.rev !ignores in
  86   let machine_readable = !machine_readable in
  87   let quiet = !quiet in
  88   let verbose = !verbose in
  89   let trace = !trace in
  90
  91   (* No arguments and machine-readable mode?  Print out some facts
  92    * about what this binary supports.
  93    *)
  94   if !disks = [] && machine_readable then (
  95     printf "virt-sparsify\n";
  96     let g = new G.guestfs () in
  97     g#add_drive_opts "/dev/null";
  98     g#launch ();
  99     if feature_available g [| "ntfsprogs"; "ntfs3g" |] then
 100       printf "ntfs\n";
 101     if feature_available g [| "btrfs" |] then
 102       printf "btrfs\n";
 103     exit 0
 104   );
 105
 106   (* Verify we got exactly 2 disks. *)
 107   let indisk, outdisk =
 108     match List.rev !disks with
 109     | [indisk; outdisk] -> indisk, outdisk
 110     | _ ->
 111         error "usage is: %s [--options] indisk outdisk" prog in
 112
 113   (* The input disk must be an absolute path, so we can store the name
 114    * in the overlay disk.
 115    *)
 116   let indisk =
 117     if not (Filename.is_relative indisk) then
 118       indisk
 119     else
 120       Sys.getcwd () // indisk in
 121
 122   (* Check indisk filename doesn't contain a comma (limitation of qemu-img). *)
 123   let contains_comma =
 124     try ignore (String.index indisk ','); true
 125     with Not_found -> false in
 126   if contains_comma then
 127     error "input filename '%s' contains a comma; qemu-img command line syntax prevents us from using such an image" indisk;
 128
 129   indisk, outdisk, convert,
 130     debug_gc, format, ignores, machine_readable, quiet,
 131     verbose, trace
 132
 133 let () =
 134   if not quiet then
 135     printf "Create overlay file to protect source disk ...\n%!"
 136
 137 (* Create the temporary overlay file. *)
 138 let overlaydisk =
 139   let tmp = Filename.temp_file "sparsify" ".qcow2" in
 140
 141   (* Unlink on exit. *)
 142   at_exit (fun () -> try unlink tmp with _ -> ());
 143
 144   (* Create it with the indisk as the backing file. *)
 145   let cmd =
 146     sprintf "qemu-img create -f qcow2 -o backing_file=%s%s %s > /dev/null"
 147       (Filename.quote indisk)
 148       (match format with
 149       | None -> ""
 150       | Some fmt -> sprintf ",backing_fmt=%s" (Filename.quote fmt))
 151       (Filename.quote tmp) in
 152   if verbose then
 153     printf "%s\n%!" cmd;
 154   if Sys.command cmd <> 0 then
 155     error "external command failed: %s" cmd;
 156
 157   tmp
 158
 159 let () =
 160   if not quiet then
 161     printf "Examine source disk ...\n%!"
 162
 163 (* Connect to libguestfs. *)
 164 let g =
 165   let g = new G.guestfs () in
 166   if trace then g#set_trace true;
 167   if verbose then g#set_verbose true;
 168
 169   (* Note that the temporary overlay disk is always qcow2 format. *)
 170   g#add_drive_opts ~format:"qcow2" ~readonly:false overlaydisk;
 171
 172   if not quiet then Progress.set_up_progress_bar ~machine_readable g;
 173   g#launch ();
 174
 175   g
 176
 177 (* Get the size in bytes of the input disk. *)
 178 let insize = g#blockdev_getsize64 "/dev/sda"
 179
 180 (* Write zeroes for non-ignored filesystems that we are able to mount. *)
 181 let () =
 182   let filesystems = g#list_filesystems () in
 183   let filesystems = List.map fst filesystems in
 184   let filesystems = List.sort compare filesystems in
 185
 186   let is_ignored fs =
 187     let fs = canonicalize fs in
 188     List.exists (fun fs' -> fs = canonicalize fs') ignores
 189   in
 190
 191   List.iter (
 192     fun fs ->
 193       if not (is_ignored fs) then (
 194         let mounted =
 195           try g#mount_options "" fs "/"; true
 196           with _ -> false in
 197
 198         if mounted then (
 199           if not quiet then
 200             printf "Fill free space in %s with zero ...\n%!" fs;
 201
 202           (* Choose a random filename, just letters and numbers, in
 203            * 8.3 format.  This ought to be compatible with any
 204            * filesystem and not clash with existing files.
 205            *)
 206           let filename = "/" ^ string_random8 () ^ ".tmp" in
 207
 208           (* This command is expected to fail. *)
 209           (try g#dd "/dev/zero" filename with _ -> ());
 210
 211           (* Make sure the last part of the file is written to disk. *)
 212           g#sync ();
 213
 214           g#rm filename
 215         );
 216
 217         g#umount_all ()
 218       )
 219   ) filesystems
 220
 221 (* Fill unused space in volume groups. *)
 222 let () =
 223   let vgs = g#vgs () in
 224   let vgs = Array.to_list vgs in
 225   let vgs = List.sort compare vgs in
 226   List.iter (
 227     fun vg ->
 228       if not (List.mem vg ignores) then (
 229         let lvname = string_random8 () in
 230         let lvdev = "/dev/" ^ vg ^ "/" ^ lvname in
 231
 232         let created =
 233           try g#lvcreate lvname vg 32; true
 234           with _ -> false in
 235
 236         if created then (
 237           if not quiet then
 238             printf "Fill free space in volgroup %s with zero ...\n%!" vg;
 239
 240           (* XXX Don't have lvcreate -l 100%FREE.  Fake it. *)
 241           g#lvresize_free lvdev 100;
 242
 243           (* This command is expected to fail. *)
 244           (try g#dd "/dev/zero" lvdev with _ -> ());
 245
 246            g#sync ();
 247            g#lvremove lvdev
 248         )
 249       )
 250   ) vgs
 251
 252 (* Don't need libguestfs now. *)
 253 let () =
 254   g#close ()
 255
 256 (* What should the output format be?  If the user specified an
 257  * input format, use that, else detect it from the source image.
 258  *)
 259 let output_format =
 260   match convert with
 261   | Some fmt -> fmt             (* user specified output conversion *)
 262   | None ->
 263     match format with
 264     | Some fmt -> fmt           (* user specified input format, use that *)
 265     | None ->
 266       (* Don't know, so we must autodetect. *)
 267       let cmd = sprintf "file -bsL %s" (Filename.quote indisk) in
 268       let chan = open_process_in cmd in
 269       let line = input_line chan in
 270       let stat = close_process_in chan in
 271       (match stat with
 272       | WEXITED 0 -> ()
 273       | WEXITED _ ->
 274         error "external command failed: %s" cmd
 275       | WSIGNALED i ->
 276         error "external command '%s' killed by signal %d" cmd i
 277       | WSTOPPED i ->
 278         error "external command '%s' stopped by signal %d" cmd i
 279       );
 280       if string_prefix line "QEMU QCOW Image (v2)" then
 281         "qcow2"
 282       else if string_find line "VirtualBox" >= 0 then
 283         "vdi"
 284       else
 285         "raw" (* XXX guess *)
 286
 287 (* Now run qemu-img convert which copies the overlay to the
 288  * destination and automatically does sparsification.
 289  *)
 290 let () =
 291   if not quiet then
 292     printf "Copy to destination and make sparse ...\n%!";
 293
 294   let cmd =
 295     sprintf "qemu-img convert -f qcow2 -O %s %s %s"
 296       (Filename.quote output_format)
 297       (Filename.quote overlaydisk) (Filename.quote outdisk) in
 298   if verbose then
 299     printf "%s\n%!" cmd;
 300   if Sys.command cmd <> 0 then
 301     error "external command failed: %s" cmd
 302
 303 (* Finished. *)
 304 let () =
 305   if not quiet then (
 306     print_newline ();
 307     wrap "Sparsify operation completed with no errors.  Before deleting the old disk, carefully check that the target disk boots and works correctly.\n";
 308   );
 309
 310   if debug_gc then
 311     Gc.compact ();
 312
 313   exit 0