virt-df/virt_df_main.ml

   1 (* 'df' command for virtual domains.
   2    (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc.
   3    http://libvirt.org/
   4
   5    This program is free software; you can redistribute it and/or modify
   6    it under the terms of the GNU General Public License as published by
   7    the Free Software Foundation; either version 2 of the License, or
   8    (at your option) any later version.
   9
  10    This program is distributed in the hope that it will be useful,
  11    but WITHOUT ANY WARRANTY; without even the implied warranty of
  12    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13    GNU General Public License for more details.
  14
  15    You should have received a copy of the GNU General Public License
  16    along with this program; if not, write to the Free Software
  17    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  18  *)
  19
  20 open Printf
  21 open ExtList
  22 open Unix
  23
  24 module C = Libvirt.Connect
  25 module D = Libvirt.Domain
  26
  27 open Virt_df_gettext.Gettext
  28 open Virt_df
  29
  30 let () =
  31   (* Command line argument parsing. *)
  32   let set_uri = function "" -> uri := None | u -> uri := Some u in
  33
  34   let version () =
  35     printf "virt-df %s\n" (Libvirt_version.version);
  36
  37     let major, minor, release =
  38       let v, _ = Libvirt.get_version () in
  39       v / 1_000_000, (v / 1_000) mod 1_000, v mod 1_000 in
  40     printf "libvirt %d.%d.%d\n" major minor release;
  41     exit 0
  42   in
  43
  44   let test_mode filename =
  45     test_files := filename :: !test_files
  46   in
  47
  48   let argspec = Arg.align [
  49     "-a", Arg.Set all,
  50       " " ^ s_ "Show all domains (default: only active domains)";
  51     "--all", Arg.Set all,
  52       " " ^ s_ "Show all domains (default: only active domains)";
  53     "-c", Arg.String set_uri,
  54       "uri " ^ s_ "Connect to URI (default: Xen)";
  55     "--connect", Arg.String set_uri,
  56       "uri " ^ s_ "Connect to URI (default: Xen)";
  57     "--debug", Arg.Set debug,
  58       " " ^ s_ "Debug mode (default: false)";
  59     "-h", Arg.Set human,
  60       " " ^ s_ "Print sizes in human-readable format";
  61     "--human-readable", Arg.Set human,
  62       " " ^ s_ "Print sizes in human-readable format";
  63     "-i", Arg.Set inodes,
  64       " " ^ s_ "Show inodes instead of blocks";
  65     "--inodes", Arg.Set inodes,
  66       " " ^ s_ "Show inodes instead of blocks";
  67     "-t", Arg.String test_mode,
  68       "dev" ^ s_ "(Test mode) Display contents of block device or file";
  69     "--version", Arg.Unit version,
  70       " " ^ s_ "Display version and exit";
  71   ] in
  72
  73   let anon_fun str =
  74     raise (Arg.Bad (sprintf (f_ "%s: unknown parameter") str)) in
  75   let usage_msg = s_ "virt-df : like 'df', shows disk space used in guests
  76
  77 SUMMARY
  78   virt-df [-options]
  79
  80 OPTIONS" in
  81
  82   Arg.parse argspec anon_fun usage_msg;
  83
  84   let doms : domain list =
  85     if !test_files = [] then (
  86       let xmls =
  87         (* Connect to the hypervisor. *)
  88         let conn =
  89           let name = !uri in
  90           try C.connect_readonly ?name ()
  91           with
  92             Libvirt.Virterror err ->
  93               prerr_endline (Libvirt.Virterror.to_string err);
  94               (* If non-root and no explicit connection URI, print a warning. *)
  95               if geteuid () <> 0 && name = None then (
  96                 print_endline (s_ "NB: If you want to monitor a local Xen hypervisor, you usually need to be root");
  97               );
  98               exit 1 in
  99
 100         (* Get the list of active & inactive domains. *)
 101         let doms =
 102           let nr_active_doms = C.num_of_domains conn in
 103           let active_doms =
 104             Array.to_list (C.list_domains conn nr_active_doms) in
 105           let active_doms =
 106             List.map (D.lookup_by_id conn) active_doms in
 107           if not !all then
 108             active_doms
 109           else (
 110             let nr_inactive_doms = C.num_of_defined_domains conn in
 111             let inactive_doms =
 112               Array.to_list (C.list_defined_domains conn nr_inactive_doms) in
 113             let inactive_doms =
 114               List.map (D.lookup_by_name conn) inactive_doms in
 115             active_doms @ inactive_doms
 116           ) in
 117
 118         (* Get their XML. *)
 119         let xmls = List.map D.get_xml_desc doms in
 120
 121         (* Parse the XML. *)
 122         let xmls = List.map Xml.parse_string xmls in
 123
 124         (* Return just the XML documents - everything else will be closed
 125          * and freed including the connection to the hypervisor.
 126          *)
 127         xmls in
 128
 129       (* Grr.. Need to use a library which has XPATH support (or cduce). *)
 130       List.map (
 131         fun xml ->
 132           let nodes, domain_attrs =
 133             match xml with
 134             | Xml.Element ("domain", attrs, children) -> children, attrs
 135             | _ -> failwith (s_ "get_xml_desc didn't return <domain/>") in
 136
 137           let domid =
 138             try Some (int_of_string (List.assoc "id" domain_attrs))
 139             with Not_found -> None in
 140
 141           let rec loop = function
 142             | [] ->
 143                 failwith (s_ "get_xml_desc returned no <name> node in XML")
 144             | Xml.Element ("name", _, [Xml.PCData name]) :: _ -> name
 145             | Xml.Element ("name", _, _) :: _ ->
 146                 failwith (s_ "get_xml_desc returned strange <name> node")
 147             | _ :: rest -> loop rest
 148           in
 149           let name = loop nodes in
 150
 151           let devices =
 152             let devices =
 153               List.filter_map (
 154                 function
 155                 | Xml.Element ("devices", _, devices) -> Some devices
 156                 | _ -> None
 157               ) nodes in
 158             List.concat devices in
 159
 160           let rec target_dev_of = function
 161             | [] -> None
 162             | Xml.Element ("target", attrs, _) :: rest ->
 163                 (try Some (List.assoc "dev" attrs)
 164                  with Not_found -> target_dev_of rest)
 165             | _ :: rest -> target_dev_of rest
 166           in
 167
 168           let rec source_file_of = function
 169             | [] -> None
 170             | Xml.Element ("source", attrs, _) :: rest ->
 171                 (try Some (List.assoc "file" attrs)
 172                  with Not_found -> source_file_of rest)
 173             | _ :: rest -> source_file_of rest
 174           in
 175
 176           let rec source_dev_of = function
 177             | [] -> None
 178             | Xml.Element ("source", attrs, _) :: rest ->
 179                 (try Some (List.assoc "dev" attrs)
 180                  with Not_found -> source_dev_of rest)
 181             | _ :: rest -> source_dev_of rest
 182           in
 183
 184           let disks =
 185             List.filter_map (
 186               function
 187               | Xml.Element ("disk", attrs, children) ->
 188                   let typ =
 189                     try Some (List.assoc "type" attrs)
 190                     with Not_found -> None in
 191                   let device =
 192                     try Some (List.assoc "device" attrs)
 193                     with Not_found -> None in
 194                   let source =
 195                     match source_file_of children with
 196                     | (Some _) as source -> source
 197                     | None -> source_dev_of children in
 198                   let target = target_dev_of children in
 199
 200                   (* We only care about devices where we have
 201                    * source and target.  Ignore CD-ROM devices.
 202                    *)
 203                   (match source, target, device with
 204                    | _, _, Some "cdrom" -> None (* ignore *)
 205                    | Some source, Some target, Some device ->
 206                        (* Try to create a 'device' object for this
 207                         * device.  If it fails, print a warning
 208                         * and ignore the device.
 209                         *)
 210                        (try
 211                           let dev = new block_device source in
 212                           Some {
 213                             d_type = typ; d_device = device;
 214                             d_source = source; d_target = target;
 215                             d_dev = dev; d_content = `Unknown
 216                           }
 217                         with
 218                           Unix_error (err, func, param) ->
 219                             eprintf "%s:%s: %s" func param (error_message err);
 220                             None
 221                        )
 222                    | _ -> None (* ignore anything else *)
 223                   )
 224
 225               | _ -> None
 226             ) devices in
 227
 228           { dom_name = name; dom_id = domid;
 229             dom_disks = disks; dom_lv_filesystems = [] }
 230       ) xmls
 231     ) else (
 232       (* In test mode (-t option) the user can pass one or more
 233        * block devices or filenames (containing partitions/filesystems/etc)
 234        * which we use for testing virt-df itself.  We create fake domains
 235        * from these.
 236        *)
 237       List.map (
 238         fun filename ->
 239           {
 240             dom_name = filename; dom_id = None;
 241             dom_disks = [
 242               {
 243                 d_type = Some "disk"; d_device = "disk";
 244                 d_source = filename; d_target = "hda";
 245                 d_dev = new block_device filename; d_content = `Unknown;
 246               }
 247             ];
 248             dom_lv_filesystems = []
 249           }
 250       ) !test_files
 251     ) in
 252
 253   (* HOF to map over disks. *)
 254   let map_over_disks doms f =
 255     List.map (
 256       fun ({ dom_disks = disks } as dom) ->
 257         let disks = List.map f disks in
 258         { dom with dom_disks = disks }
 259     ) doms
 260   in
 261
 262   (* 'doms' is our list of domains and their guest block devices, and
 263    * we've successfully opened each block device.  Now probe them
 264    * to find out what they contain.
 265    *)
 266   let doms = map_over_disks doms (
 267     fun ({ d_dev = dev } as disk) ->
 268       (* See if it is partitioned first. *)
 269       let parts = probe_for_partitions dev in
 270       match parts with
 271       | Some parts ->
 272           { disk with d_content = `Partitions parts }
 273       | None ->
 274           (* Not partitioned.  Does it contain a filesystem? *)
 275           let fs = probe_for_filesystem dev in
 276           match fs with
 277           | Some fs ->
 278               { disk with d_content = `Filesystem fs }
 279           | None ->
 280               (* Not partitioned, no filesystem, is it a PV? *)
 281               let pv = probe_for_pv dev in
 282               match pv with
 283               | Some lvm_name ->
 284                   { disk with d_content = `PhysicalVolume lvm_name }
 285               | None ->
 286                   disk (* Spare/unknown. *)
 287   ) in
 288
 289   (* Now we have either detected partitions or a filesystem on each
 290    * physical device (or perhaps neither).  See what is on those
 291    * partitions.
 292    *)
 293   let doms = map_over_disks doms (
 294     function
 295     | ({ d_dev = dev; d_content = `Partitions parts } as disk) ->
 296         let ps = List.map (
 297           fun p ->
 298             if p.part_status = Bootable || p.part_status = Nonbootable then (
 299               let fs = probe_for_filesystem p.part_dev in
 300               match fs with
 301               | Some fs ->
 302                   { p with part_content = `Filesystem fs }
 303               | None ->
 304                   (* Is it a PV? *)
 305                   let pv = probe_for_pv p.part_dev in
 306                   match pv with
 307                   | Some lvm_name ->
 308                       { p with part_content = `PhysicalVolume lvm_name }
 309                   | None ->
 310                       p (* Spare/unknown. *)
 311             ) else p
 312         ) parts.parts in
 313         let parts = { parts with parts = ps } in
 314         { disk with d_content = `Partitions parts }
 315     | disk -> disk
 316   ) in
 317
 318   (* LVM filesystem detection
 319    *
 320    * For each domain, look for all disks/partitions which have been
 321    * identified as PVs and pass those back to the respective LVM
 322    * plugin for LV detection.
 323    *
 324    * (Note - a two-stage process because an LV can be spread over
 325    * several PVs, so we have to detect all PVs belonging to a
 326    * domain first).
 327    *
 328    * XXX To deal with RAID (ie. md devices) we will need to loop
 329    * around here because RAID is like LVM except that they normally
 330    * present as block devices which can be used by LVM.
 331    *)
 332   (* First: LV detection. *)
 333   let doms = List.map (
 334     fun ({ dom_disks = disks } as dom) ->
 335       (* Find all physical volumes, can be disks or partitions. *)
 336       let pvs_on_disks = List.filter_map (
 337         function
 338         | { d_dev = d_dev;
 339             d_content = `PhysicalVolume pv } -> Some (pv, d_dev)
 340         | _ -> None
 341       ) disks in
 342       let pvs_on_partitions = List.map (
 343         function
 344         | { d_content = `Partitions { parts = parts } } ->
 345             List.filter_map (
 346               function
 347               | { part_dev = part_dev;
 348                   part_content = `PhysicalVolume pv } ->
 349                     Some (pv, part_dev)
 350               | _ -> None
 351             ) parts
 352         | _ -> []
 353       ) disks in
 354       let lvs = List.concat (pvs_on_disks :: pvs_on_partitions) in
 355       dom, lvs
 356   ) doms in
 357
 358   (* Second: filesystem on LV detection. *)
 359   let doms = List.map (
 360     fun (dom, lvs) ->
 361       (* Group the LVs by plug-in type. *)
 362       let cmp (a,_) (b,_) = compare a b in
 363       let lvs = List.sort ~cmp lvs in
 364       let lvs = group_by lvs in
 365
 366       let lvs =
 367         List.map (fun (pv, devs) -> list_lvs pv.lvm_plugin_id devs) lvs in
 368       let lvs = List.concat lvs in
 369
 370       (* lvs is a list of potential LV devices.  Now run them through the
 371        * probes to see if any contain filesystems.
 372        *)
 373       let filesystems =
 374         List.filter_map (
 375           fun ({ lv_dev = dev } as lv) ->
 376             match probe_for_filesystem dev with
 377             | Some fs -> Some (lv, fs)
 378             | None -> None
 379         ) lvs in
 380
 381       { dom with dom_lv_filesystems = filesystems }
 382   ) doms in
 383
 384   (* Now print the results.
 385    *
 386    * Print the title.
 387    *)
 388   let () =
 389     let total, used, avail =
 390       match !inodes, !human with
 391       | false, false -> s_ "1K-blocks", s_ "Used", s_ "Available"
 392       | false, true -> s_ "Size", s_ "Used", s_ "Available"
 393       | true, _ -> s_ "Inodes", s_ "IUse", s_ "IFree" in
 394     printf "%-20s %10s %10s %10s %s\n%!"
 395       (s_ "Filesystem") total used avail (s_ "Type") in
 396
 397   let printable_size bytes =
 398     if bytes < 1024L *^ 1024L then
 399       sprintf "%Ld bytes" bytes
 400     else if bytes < 1024L *^ 1024L *^ 1024L then
 401       sprintf "%.1f MiB" (Int64.to_float (bytes /^ 1024L) /. 1024.)
 402     else
 403       sprintf "%.1f GiB" (Int64.to_float (bytes /^ 1024L /^ 1024L) /. 1024.)
 404   in
 405
 406   (* HOF to iterate over filesystems. *)
 407   let iter_over_filesystems doms
 408       (f : domain -> ?disk:disk -> ?partno:int -> device -> filesystem ->
 409         unit) =
 410     List.iter (
 411       fun ({ dom_disks = disks; dom_lv_filesystems = filesystems } as dom) ->
 412         (* Ordinary filesystems found on disks & partitions. *)
 413         List.iter (
 414           function
 415           | ({ d_content = `Filesystem fs; d_dev = dev } as disk) ->
 416               f dom ~disk dev fs
 417           | ({ d_content = `Partitions partitions } as disk) ->
 418               List.iteri (
 419                 fun i ->
 420                   function
 421                   | { part_content = `Filesystem fs; part_dev = dev } ->
 422                       f dom ~disk ~partno:(i+1) dev fs
 423                   | _ -> ()
 424               ) partitions.parts
 425           | _ -> ()
 426         ) disks;
 427         (* LV filesystems. *)
 428         List.iter (fun ({lv_dev = dev}, fs) -> f dom dev fs) filesystems
 429     ) doms
 430   in
 431
 432   (* Print stats for each recognized filesystem. *)
 433   let print_stats dom ?disk ?partno dev fs =
 434     (* Printable name is like "domain:hda" or "domain:hda1". *)
 435     let name =
 436       let dom_name = dom.dom_name in
 437       (* Get the disk name (eg. "hda") from the domain XML, if
 438        * we have it, otherwise use the device name (eg. for LVM).
 439        *)
 440       let disk_name =
 441         match disk with
 442         | None -> dev#name
 443         | Some disk -> disk.d_target
 444       in
 445       match partno with
 446       | None ->
 447           dom_name ^ ":" ^ disk_name
 448       | Some partno ->
 449           dom_name ^ ":" ^ disk_name ^ string_of_int partno in
 450     printf "%-20s " name;
 451
 452     if fs.fs_is_swap then (
 453       (* Swap partition. *)
 454       if not !human then
 455         printf "%10Ld                       %s\n"
 456           (fs.fs_block_size *^ fs.fs_blocks_total /^ 1024L) fs.fs_name
 457       else
 458         printf "%10s                       %s\n"
 459           (printable_size (fs.fs_block_size *^ fs.fs_blocks_total)) fs.fs_name
 460     ) else (
 461       (* Ordinary filesystem. *)
 462       if not !inodes then (             (* Block display. *)
 463         (* 'df' doesn't count the restricted blocks. *)
 464         let blocks_total = fs.fs_blocks_total -^ fs.fs_blocks_reserved in
 465         let blocks_avail = fs.fs_blocks_avail -^ fs.fs_blocks_reserved in
 466         let blocks_avail = if blocks_avail < 0L then 0L else blocks_avail in
 467
 468         if not !human then (            (* Display 1K blocks. *)
 469           printf "%10Ld %10Ld %10Ld %s\n"
 470             (blocks_total *^ fs.fs_block_size /^ 1024L)
 471             (fs.fs_blocks_used *^ fs.fs_block_size /^ 1024L)
 472             (blocks_avail *^ fs.fs_block_size /^ 1024L)
 473             fs.fs_name
 474         ) else (                        (* Human-readable blocks. *)
 475           printf "%10s %10s %10s %s\n"
 476             (printable_size (blocks_total *^ fs.fs_block_size))
 477             (printable_size (fs.fs_blocks_used *^ fs.fs_block_size))
 478             (printable_size (blocks_avail *^ fs.fs_block_size))
 479             fs.fs_name
 480         )
 481       ) else (                          (* Inodes display. *)
 482         printf "%10Ld %10Ld %10Ld %s\n"
 483           fs.fs_inodes_total fs.fs_inodes_used fs.fs_inodes_avail
 484           fs.fs_name
 485       )
 486     )
 487   in
 488   iter_over_filesystems doms print_stats