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