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