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