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