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